Fix interpreter

Makefile

@@ -28,5 +28,10 @@ test :
 	./language ./sample-programs/basic-3
 	./language ./sample-programs/basic-4
 	./language ./sample-programs/basic-5
+	./language ./sample-programs/basic-5
+	./language ./sample-programs/basic-6
+	./language ./sample-programs/basic-7
+	./language ./sample-programs/basic-8
+	./language ./sample-programs/basic-9
 
 # EOF

language.cabal

@@ -30,9 +30,10 @@ executable language
       Grammar.Par
       Grammar.Print
       Grammar.Skel
+      Grammar.ErrM
       LambdaLifter
       Auxiliary
-      -- Interpreter
+      Interpreter
 
     hs-source-dirs:   src
 

sample-programs/basic-9

@@ -0,0 +1,4 @@
+
+
+
+main = (\f.\x.\y. f x + f y) (\x. x+x) ((\x. x+1) ((\x. x+3) 2)) 4

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 }

src/Main.hs

@@ -1,8 +1,10 @@
 {-# LANGUAGE LambdaCase #-}
 module Main where
 
+import           Grammar.ErrM       (Err)
 import           Grammar.Par        (myLexer, pProgram)
 import           Grammar.Print      (printTree)
+import           Interpreter        (interpret)
 import           LambdaLifter       (abstract, freeVars, lambdaLift)
 import           System.Environment (getArgs)
 import           System.Exit        (exitFailure, exitSuccess)
@@ -10,20 +12,41 @@ import           System.Exit        (exitFailure, exitSuccess)
 main :: IO ()
 main = getArgs >>= \case
   []    -> print "Required file path missing"
-  (x:_) -> do
-    file <- readFile x
-    case pProgram (myLexer file) of
-      Left err -> do
-       putStrLn "SYNTAX ERROR"
-       putStrLn err
-       exitFailure
-      Right prg -> do
-        putStrLn "-- Parse"
-        putStrLn $ printTree prg
-        putStrLn "\n-- Lambda lifter"
-        putStrLn . printTree $ lambdaLift prg
-        putStrLn ""
-        exitSuccess
+  (s:_) -> main' s
+
+main' :: String -> IO ()
+main' s = do
+  file   <- readFile s
+
+  putStrLn "\n-- parse"
+  parsed    <- fromSyntaxErr . pProgram $ myLexer file
+  putStrLn $ printTree parsed
+
+  putStrLn "\n-- Lambda Lifter"
+  let lifted = lambdaLift parsed
+  putStrLn $ printTree lifted
+
+  interpred <- fromInterpreterErr $ interpret lifted
+  putStrLn "\n-- interpret"
+  print interpred
+
+  exitSuccess
 
 
+fromSyntaxErr :: Err a -> IO a
+fromSyntaxErr = either
+  (\err -> do
+    putStrLn "\nSYNTAX ERROR"
+    putStrLn err
+    exitFailure)
+ pure
+
+fromInterpreterErr :: Err a -> IO a
+fromInterpreterErr = either
+  (\err -> do
+    putStrLn "\nINTERPRETER ERROR"
+    putStrLn err
+    exitFailure)
+ pure
+