EDSL.hs

{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs, StandaloneDeriving #-}
import Control.Monad.Identity
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.Error
import Control.Applicative
import Data.Map
import Prelude hiding (lookup, log)

type Name = String
type Ctx = Map String Int

data Expr a where
  Num :: Int -> Expr Int                                -- number literal
  Bool :: Bool -> Expr Bool                             -- boolean literal
  Add :: Expr Int -> Expr Int -> Expr Int               -- addition
  Var :: Name -> Expr Int                               -- variable
  Let :: Name -> Expr Int -> Expr a -> Expr a           -- let binding
  Trace :: String -> Expr a -> Expr a                   -- debug
  IfThenElse :: Expr Bool -> Expr a -> Expr a -> Expr a -- conditional

deriving instance Show (Expr a)

newtype Eval a = Eval { runEval :: WriterT String (ErrorT String (Reader Ctx)) a }
               deriving (Monad, Applicative, Functor, MonadReader Ctx, MonadError String, MonadWriter String)

eval  :: Expr a -> Either String (a, String)
eval = flip runReader (fromList []) . runErrorT . runWriterT . runEval . evalM 

evalM :: Expr a -> Eval a
evalM (Num n) = return n
evalM (Bool b) = return b
evalM (Add e1 e2) = (+) <$> evalM e1 <*> evalM e2
evalM (Var n) = do
  ctx <- ask
  case lookup n ctx of
    Just v  -> return v
    Nothing -> throwError $ strMsg $ "No value for " ++ n
evalM (Let n e1 inE) = case eval e1 of
                            Right (i, log) -> censor (log ++) $ local (insert n i) (evalM inE)
                            Left err       -> throwError $ strMsg $ "Invalid let expr " ++ show e1 ++ " (" ++ err ++ ")"
evalM (Trace msg e) = censor (msg ++) (evalM e)
evalM (IfThenElse bexpr texpr fexpr) = case eval bexpr of
  Right (True, log)  -> censor (log ++) $ evalM texpr
  Right (False, log) -> censor (log ++) $ evalM fexpr
  Left err           -> throwError $ strMsg $ "Invalid condition " ++ show bexpr ++ " (" ++ err ++ ")"

e = Let "alma" (Add (Num 1) (Num 2)) (Let "bool" (Num 2) (IfThenElse (Bool True) (Add (Trace "hello" (Var "alma")) (Num 3)) (Trace "false" (Var "alma"))))