-- 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)