MonadLab-0.0: examples/InterpB.hs

module InterpB where

-- The interpreter monad
-- (Generated by MonadLab)
import InterpMonadB

-- Language syntax
type Name = String
data Term = Var Name | Con Int | Add Term Term
          | Lam Name Term | App Term Term
          | LetRef Name Term Term | Deref Term
          | PutRef Term Term | Seq Term Term

mkfun :: Name -> M V -> M V
mkfun x phi =
   rdEnvM >>= \ e ->
     return (Fun $ \ arg -> inEnvM ((x,arg):e) phi)

appEnv :: Name -> M V
appEnv x = rdEnvM >>= \ e ->
           case lookup x e of
              Nothing  -> return Wrong
              (Just v) -> return v

getLoc :: Loc -> M V
getLoc l = getStoM >>= \s ->
           case lookup l s of
              Nothing  -> return Wrong
              (Just v) -> return v

putLoc :: Loc -> V -> M ()
putLoc l v = getStoM >>= \s -> putStoM $ (l,v):s

findFreeLoc :: M Loc
findFreeLoc = getStoM >>= \s -> return (ffl 0 s)
                  -- This is clearly inefficient, but it gets the idea across.
                  where ffl :: Loc -> Store -> Loc
                        ffl n sto = case lookup n sto of
                                        Nothing -> n
                                        _       -> ffl (n+1) sto

inExtEnvRef :: Name -> V -> M V -> M V
inExtEnvRef x v phi = findFreeLoc >>= \l ->
                      putLoc l v >>
                      rdEnvM >>= \ e ->
                        inEnvM ((x,(Ref l)):e) phi

apply :: V -> V -> M V
apply (Fun k) a = k a
apply _ _       = return Wrong

-- The interpreter
add :: V -> V -> M V
add (Num i) (Num j) = return (Num (i+j))
add _ _             = return Wrong

interp :: Term -> M V
interp (Var x)        = appEnv x
interp (Con i)        = return (Num i)
interp (Add u v)      = interp u >>= \ a ->
                        interp v >>= \ b ->
                           add a b
interp (Lam x v)      = mkfun x (interp v)
interp (App t u)      = interp t >>= \ f -> 
                        interp u >>= \ a -> 
                           apply f a
interp (LetRef x v t) = interp v >>= \val ->
                        inExtEnvRef x val (interp t)
interp (Deref t)      = interp t >>= \ref ->
                        case ref of
                           (Ref l) -> getLoc l
                           _       -> return Wrong
interp (PutRef r v)   = interp r >>= \ref ->
                        case ref of
                           (Ref l) -> interp v >>=
                                      putLoc l >>
                                         return Unit
                           _       -> return Wrong
interp (Seq t1 t2)    = interp t1 >> interp t2

test :: Term -> V
test t = runM (interp t) initEnv initSto
         where initEnv = []
               initSto = []