From d67eddcf0fb8a542f1b644a2b80c5fe0fd47efe2 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Sat, 11 Feb 2023 11:04:39 +0100 Subject: [PATCH] Fix interpreter --- Makefile | 5 +++ language.cabal | 3 +- sample-programs/basic-9 | 4 +++ src/Interpreter.hs | 75 +++++++++++++++++++++++++++++++---------- src/Main.hs | 51 ++++++++++++++++++++-------- 5 files changed, 105 insertions(+), 33 deletions(-) create mode 100644 sample-programs/basic-9 diff --git a/Makefile b/Makefile index 6e8a54d..d9098d1 100644 --- a/Makefile +++ b/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 diff --git a/language.cabal b/language.cabal index 52b2577..0577abe 100644 --- a/language.cabal +++ b/language.cabal @@ -30,9 +30,10 @@ executable language Grammar.Par Grammar.Print Grammar.Skel + Grammar.ErrM LambdaLifter Auxiliary - -- Interpreter + Interpreter hs-source-dirs: src diff --git a/sample-programs/basic-9 b/sample-programs/basic-9 new file mode 100644 index 0000000..ba9ebdc --- /dev/null +++ b/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 diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 378c95b..3503a7c 100644 --- a/src/Interpreter.hs +++ b/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 } diff --git a/src/Main.hs b/src/Main.hs index ba6edf2..0602f6e 100644 --- a/src/Main.hs +++ b/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 +