Fix interpreter

src/Interpreter.hs

@@ -1,38 +1,72 @@
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings   #-}
 module Interpreter where
 
+import           Auxiliary               (maybeToRightM)
 import           Control.Applicative     (Applicative)
 import           Control.Monad.Except    (Except, MonadError (throwError),
                                           liftEither)
+import           Control.Monad.State     (MonadState, StateT, evalStateT)
 import           Data.Either.Combinators (maybeToRight)
 import           Data.Map                (Map)
 import qualified Data.Map                as Map
+import           Data.Maybe              (maybe)
 import           Grammar.Abs
+import           Grammar.ErrM            (Err)
 import           Grammar.Print           (printTree)
 
-interpret :: Program -> Except String Integer
-interpret (Program e) =
-  eval mempty e >>= \case
-    VClosure {} -> throwError "main evaluated to a function"
-    VInt i      -> pure i
+interpret :: Program -> Err Integer
+interpret (Program scs) = do
+  main <- findMain scs
+  eval (initCxt scs) main >>=
+    \case
+      VClosure {} -> throwError "main evaluated to a function"
+      VInt i      -> pure i
 
 
+initCxt :: [Bind] -> Cxt
+initCxt scs =
+  Cxt { env = mempty
+      , sig = foldr insert mempty $ map expandLambdas scs
+      }
+  where insert (Bind name _ rhs) = Map.insert name rhs
+
+expandLambdas :: Bind -> Bind
+expandLambdas (Bind name parms rhs) = Bind name [] $ foldr EAbs rhs parms
+
+
+findMain :: [Bind] -> Err Exp
+findMain []       = throwError "No main!"
+findMain (sc:scs) = case sc of
+                      Bind "main" _ rhs -> pure rhs
+                      _                 -> findMain scs
+
 data Val = VInt Integer
-         | VClosure Cxt Ident Exp
+         | VClosure Env Ident Exp
+           deriving (Show, Eq)
 
-type Cxt = Map Ident Val
+type Env = Map Ident Val
+type Sig = Map Ident Exp
 
-eval :: Cxt -> Exp -> Except String Val
+data Cxt = Cxt
+  { env :: Map Ident Val
+  , sig :: Map Ident Exp
+  } deriving (Show, Eq)
+
+eval :: Cxt -> Exp -> Err Val
 eval cxt = \case
 
-
   --  ------------ x ∈ γ
   --  γ ⊢ x ⇓ γ(x)
 
-  EId x     ->
-    maybeToRightM
-      ("Unbound variable:" ++ printTree x)
-      $ Map.lookup x cxt
+  EId x     -> do
+    case Map.lookup x cxt.env of
+      Just e -> pure e
+      Nothing ->
+        case Map.lookup x cxt.sig of
+          Just e  -> eval (emptyEnv cxt) e
+          Nothing -> throwError ("Unbound variable: " ++ printTree x)
 
   --  ---------
   --  γ ⊢ i ⇓ i
@@ -50,13 +84,15 @@ eval cxt = \case
       VInt _ -> throwError "Not a function"
       VClosure delta x f -> do
         v <- eval cxt e1
-        eval (Map.insert x v delta) f
+        let cxt' = putEnv (Map.insert x v delta) cxt
+        eval cxt' f
+
 
   --
   --  -----------------------------
   --  γ ⊢ λx. f ⇓ let γ in λx. f
 
-  EAbs x e  -> pure $ VClosure cxt x e
+  EAbs par e  -> pure $ VClosure cxt.env par e
 
 
   --  γ ⊢ e  ⇓ v
@@ -71,8 +107,11 @@ eval cxt = \case
       (VInt i, VInt i1) -> pure $ VInt (i + i1)
       _                 -> throwError "Can't add a function"
 
+  ELet _ _ -> throwError "ELet pattern match should never occur!"
 
 
-maybeToRightM :: MonadError l m => l -> Maybe r -> m r
-maybeToRightM err = liftEither . maybeToRight err
+emptyEnv :: Cxt -> Cxt
+emptyEnv cxt = cxt { env = mempty }
 
+putEnv :: Env -> Cxt -> Cxt
+putEnv env cxt = cxt { env = env }