-- SPDX-FileCopyrightText: 2010 Heinrich Apfelmus
-- SPDX-FileCopyrightText: 2020 Chris Pressey, Cat's Eye Technologies
-- SPDX-License-Identifier: LicenseRef-BSD-3-Clause-X-Operational

module OperationalSansGADTs where

import Control.Monad (liftM, ap)

--
-- Adapted from "The Operational Monad Tutorial":
-- https://apfelmus.nfshost.com/articles/operational-monad.html
-- For better or worse, I rewrote it without the GADTs.
--

data Program instr a b = Then (instr a) (a -> Program instr a b)
                       | Return b

singleton :: instr b -> Program instr b b
singleton i = i `Then` Return

instance Monad (Program instr a) where
    (>>=)  = bind where
                 bind (Return a)    js = js a
                 bind (i `Then` is) js = i `Then` (\a -> is a >>= js)
    return = Return

instance Applicative (Program instr a) where
    pure   = return
    (<*>)  = ap

instance Functor (Program instr a) where
    fmap   = liftM

-- -- -- -- --

type StackProgram a = Program StackInstruction a

data StackInstruction a = Pop
                        | Push Int

type Stack a = [a]

interpret :: Program StackInstruction Int t -> (Stack Int) -> t
interpret (Push a `Then` is) stack     = interpret (is 0) (a:stack)
interpret (Pop    `Then` is) (b:stack) = interpret (is b) stack
interpret (Return c)         stack     = c

pop :: Program StackInstruction b b
pop  = singleton Pop

push :: Int -> Program StackInstruction b b
push = singleton . Push

main = do
    print $ (flip interpret) [7] $ do
        push 11
        a <- pop
        b <- pop
        return (a*b)