MonadLab-0.0: examples/InterpD.hs

module InterpD where

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

-- 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
          | Print Term | Amb Term Term

instance Show V where
   show Wrong   = "Wrong"
   show (Num n) = show n
   show (Fun _) = "<function>"
   show (Ref _) = "<reference>"
   show Unit    = "Unit"

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
interp (Print t)      = interp t >>= \ v ->
                        tellOutM (show v) >>
                           return Unit
interp (Amb t1 t2)    = mergeM [interp t1,interp t2]

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