m-chrzan.xyz
aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.gitignore4
-rw-r--r--Abs.hs27
-rw-r--r--Eval.hs144
-rw-r--r--Makefile15
-rw-r--r--README.md0
-rw-r--r--Schmim.hs59
-rw-r--r--Typecheck.hs202
-rw-r--r--schmim.bnfc51
8 files changed, 502 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..a6c8d5c
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,4 @@
+*.o
+*.hi
+interpreter
+Parser/*
diff --git a/Abs.hs b/Abs.hs
new file mode 100644
index 0000000..cfdd854
--- /dev/null
+++ b/Abs.hs
@@ -0,0 +1,27 @@
+module Abs where
+
+import Parser.AbsSchmim
+import Data.Map.Lazy
+
+type Env = Map Ident Val
+
+data Val
+ = VNum Integer
+ | VAbs Ident Type Env Exp
+ | VTr
+ | VFl
+ | VVrnt Ident Val Type
+ | VTpl [Val]
+ | VNil Type
+ | VCons Val Val
+ deriving (Eq, Ord, Read)
+
+instance Show Val where
+ show (VNum n) = show n
+ show (VAbs x t _ _) = "#(lambda " ++ (show x) ++ " : " ++ (show t) ++ ")"
+ show (VTr) = "true"
+ show (VFl) = "false"
+ show (VVrnt l v _) = "<" ++ (show l) ++ " " ++ (show v) ++ ">"
+ show (VTpl vs) = "{" ++ (show vs) ++ "}"
+ show (VNil t) = "nil"
+ show (VCons v1 v2) = "(cons " ++ (show v1) ++ " " ++ (show v2) ++ ")"
diff --git a/Eval.hs b/Eval.hs
new file mode 100644
index 0000000..c4f6cf7
--- /dev/null
+++ b/Eval.hs
@@ -0,0 +1,144 @@
+module Eval where
+
+import Abs
+import Prelude hiding (lookup)
+import Parser.AbsSchmim
+import Control.Monad.Reader
+import Data.Map.Lazy
+import Typecheck
+
+type Interpreter a = ReaderT Env (Either String) a
+
+eval :: Exp -> Interpreter Val
+eval (EAdd e1 e2) = do
+ (VNum v1) <- eval e1
+ (VNum v2) <- eval e2
+ return (VNum $ v1 + v2)
+eval (EMul e1 e2) = do
+ (VNum v1) <- eval e1
+ (VNum v2) <- eval e2
+ return (VNum $ v1 * v2)
+eval (ESub e1 e2) = do
+ (VNum v1) <- eval e1
+ (VNum v2) <- eval e2
+ return (VNum $ v1 - v2)
+eval (EDiv e1 e2) = do
+ (VNum v1) <- eval e1
+ (VNum v2) <- eval e2
+ if v2 == 0
+ then lift $ Left "division by 0"
+ else return (VNum $ v1 `div` v2)
+eval (EVar x) = do
+ (Just v) <- asks $ lookup x
+ return v
+eval (ENum n) = return (VNum n)
+eval (EAbs x t e) = do
+ env <- ask
+ return $ VAbs x t env e
+eval (EApp e1 []) = do
+ eval e1
+eval (EApp e1 [e2]) = do
+ (VAbs x t env e) <- eval e1
+ v <- eval e2
+ local (\_ -> insert x v env) $ eval e
+eval (EApp e1 (e2:es)) = do
+ eval (EApp (EApp e1 [e2]) es)
+eval ETr = return VTr
+eval EFl = return VFl
+eval (EEq e1 e2) = do
+ (VNum v1) <- eval e1
+ (VNum v2) <- eval e2
+ return $ if v1 == v2 then VTr else VFl
+eval (ELeq e1 e2) = do
+ (VNum v1) <- eval e1
+ (VNum v2) <- eval e2
+ return $ if v1 <= v2 then VTr else VFl
+eval (EGeq e1 e2) = do
+ (VNum v1) <- eval e1
+ (VNum v2) <- eval e2
+ return $ if v1 >= v2 then VTr else VFl
+eval (ELess e1 e2) = do
+ (VNum v1) <- eval e1
+ (VNum v2) <- eval e2
+ return $ if v1 < v2 then VTr else VFl
+eval (EGrt e1 e2) = do
+ (VNum v1) <- eval e1
+ (VNum v2) <- eval e2
+ return $ if v1 > v2 then VTr else VFl
+eval (EAnd e1 e2) = do
+ v1 <- eval e1
+ v2 <- eval e2
+ return $ case (v1, v2) of
+ (VTr, VTr) -> VTr
+ _ -> VFl
+eval (EOr e1 e2) = do
+ v1 <- eval e1
+ v2 <- eval e2
+ return $ case (v1, v2) of
+ (VFl, VFl) -> VFl
+ _ -> VTr
+eval (EIfte e1 e2 e3) = do
+ v1 <- eval e1
+ let e = case v1 of
+ VTr -> e2
+ VFl -> e3
+ eval e
+eval (EVrnt l e t) = do
+ v <- eval e
+ return $ VVrnt l v t
+eval (ETpl es) = do
+ vs <- forM es eval
+ return $ VTpl vs
+eval (EProj e i) = do
+ (VTpl vs) <- eval e
+ return $ vs !! (fromIntegral (i - 1))
+eval (EMtch e ms) = do
+ (VVrnt l v t) <- eval e
+ let (Matching _ x e') = lookupLabel l ms
+ local (insert x v) $ eval e'
+ where
+ lookupLabel l (m@(Matching l' x e):ms)
+ | l == l' = m
+ | otherwise = lookupLabel l ms
+eval (ENil t) = return $ VNil t
+eval (ECons e1 e2) = do
+ v1 <- eval e1
+ v2 <- eval e2
+ return (VCons v1 v2)
+eval (EHead e) = do
+ v <- eval e
+ case v of
+ (VNil _) -> lift $ Left "head of empty list"
+ (VCons v _) -> return v
+eval (ETail e) = do
+ v <- eval e
+ case v of
+ (VNil _) -> lift $ Left "tail of empty list"
+ (VCons _ v) -> return v
+eval (EIsnil e) = do
+ v <- eval e
+ return $ case v of
+ (VNil _) -> VTr
+ _ -> VFl
+eval (EFix (EAbs x t e)) = do
+ env <- ask
+ let env' = insert x (forcedEval (EFix (EAbs x t e)) env') env
+ local (\_ -> env') $ eval e
+ where
+ forcedEval e env = case runReaderT (eval e) env of
+ Right v -> v
+eval (ELet x ps e1 e2) = do
+ eval (EApp (EAbs x t e2) [e1'])
+ where
+ (e1', t) = Prelude.foldr (\(Param x t') (e, t) -> ((EAbs x t' e), TFun t' t)) (e1, placeholderType) ps
+eval (ELetrec x _ ps e1 e2) = do
+ eval (EApp (EAbs x t e2) [(EFix (EAbs x t e1'))])
+ where
+ (e1', t) = Prelude.foldr (\(Param x t') (e, t) -> ((EAbs x t' e), TFun t' t)) (e1, placeholderType) ps
+
+placeholderType = TInt
+
+interp :: Exp -> Either String Val
+interp e = case runReaderT (typeof e) empty of
+ (Just t) -> runReaderT (eval e) empty
+ Nothing -> Left "badly typed expression"
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..b32ae73
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,15 @@
+all: bnfc parser interpreter
+ # ghc -dynamic --make Parser/TestSchmim.hs -o Parser/TestSchmim
+
+bnfc:
+ bnfc -haskell -p Parser schmim.bnfc
+
+parser: bnfc
+ happy -gca Parser/ParSchmim.y
+ alex -g Parser/LexSchmim.x
+
+interpreter: parser bnfc
+ ghc -dynamic Schmim.hs -o interpreter
+
+clean:
+ -rm -f Parser/*.log Parser/*.aux Parser/*.hi Parser/*.o Parser/*.dvi *.o *.hi interpreter
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/README.md
diff --git a/Schmim.hs b/Schmim.hs
new file mode 100644
index 0000000..3c0bc79
--- /dev/null
+++ b/Schmim.hs
@@ -0,0 +1,59 @@
+module Main where
+
+import System.IO ( stdin, hGetContents )
+import System.Environment ( getArgs, getProgName )
+import System.Exit ( exitFailure, exitSuccess )
+
+import Parser.LexSchmim
+import Parser.ParSchmim
+import Parser.SkelSchmim
+import Parser.PrintSchmim
+import Parser.AbsSchmim
+
+import Eval
+
+import Parser.ErrM
+
+type ParseFun a = [Token] -> Err a
+
+myLLexer = myLexer
+
+type Verbosity = Int
+
+putStrV :: Verbosity -> String -> IO ()
+putStrV v s = if v > 1 then putStrLn s else return ()
+
+runFile :: Verbosity -> ParseFun Exp -> FilePath -> IO ()
+runFile v p f = readFile f >>= run v p
+
+run :: Verbosity -> ParseFun Exp -> String -> IO ()
+run v p s = let ts = myLLexer s in case p ts of
+ Bad s -> do putStrLn "\nParse Failed...\n"
+ exitFailure
+ Ok tree -> do let res = interp tree
+ case res of
+ (Left err) -> do putStrLn $ "Error: " ++ err
+ exitFailure
+ (Right v) -> print v
+
+ exitSuccess
+
+usage :: IO ()
+usage = do
+ putStrLn $ unlines
+ [ "usage: Call with one of the following argument combinations:"
+ , " --help Display this help message."
+ , " (no arguments) Parse stdin verbosely."
+ , " (files) Parse content of files verbosely."
+ , " -s (files) Silent mode. Parse content of files silently."
+ ]
+ exitFailure
+
+main :: IO ()
+main = do
+ args <- getArgs
+ case args of
+ ["--help"] -> usage
+ [] -> hGetContents stdin >>= run 2 pExp
+ "-s":fs -> mapM_ (runFile 0 pExp) fs
+ fs -> mapM_ (runFile 2 pExp) fs
diff --git a/Typecheck.hs b/Typecheck.hs
new file mode 100644
index 0000000..6c62909
--- /dev/null
+++ b/Typecheck.hs
@@ -0,0 +1,202 @@
+module Typecheck where
+
+import Prelude hiding (lookup)
+import Parser.AbsSchmim
+import Data.Map.Lazy
+import Control.Monad.Reader
+
+type Context = Map Ident Type
+type Typechecker a = ReaderT Context Maybe a
+
+assert :: MonadPlus m => Bool -> m ()
+assert True = return ()
+assert False = mzero
+
+typeof :: Exp -> Typechecker Type
+typeof ETr = return TBool
+typeof EFl = return TBool
+typeof (ENum _) = return TInt
+typeof (EVar x) = do
+ mt <- asks $ lookup x
+ case mt of
+ (Just t) -> return t
+ Nothing -> lift Nothing
+typeof (EAdd e1 e2) = do
+ t1 <- typeof e1
+ t2 <- typeof e2
+ assert (t1 == TInt)
+ assert (t2 == TInt)
+ return TInt
+typeof (ESub e1 e2) = do
+ t1 <- typeof e1
+ t2 <- typeof e2
+ assert (t1 == TInt)
+ assert (t2 == TInt)
+ return TInt
+typeof (EMul e1 e2) = do
+ t1 <- typeof e1
+ t2 <- typeof e2
+ assert (t1 == TInt)
+ assert (t2 == TInt)
+ return TInt
+typeof (EDiv e1 e2) = do
+ t1 <- typeof e1
+ t2 <- typeof e2
+ assert (t1 == TInt)
+ assert (t2 == TInt)
+ return TInt
+typeof (EAnd e1 e2) = do
+ t1 <- typeof e1
+ t2 <- typeof e2
+ assert (t1 == TBool)
+ assert (t2 == TBool)
+ return TBool
+typeof (EOr e1 e2) = do
+ t1 <- typeof e1
+ t2 <- typeof e2
+ assert (t1 == TBool)
+ assert (t2 == TBool)
+ return TBool
+typeof (ENot e) = do
+ t <- typeof e
+ assert (t == TBool)
+ return TBool
+typeof (EEq e1 e2) = do
+ t1 <- typeof e1
+ t2 <- typeof e2
+ assert (t1 == TInt)
+ assert (t2 == TInt)
+ return TBool
+typeof (ELeq e1 e2) = do
+ t1 <- typeof e1
+ t2 <- typeof e2
+ assert (t1 == TInt)
+ assert (t2 == TInt)
+ return TBool
+typeof (EGeq e1 e2) = do
+ t1 <- typeof e1
+ t2 <- typeof e2
+ assert (t1 == TInt)
+ assert (t2 == TInt)
+ return TBool
+typeof (ELess e1 e2) = do
+ t1 <- typeof e1
+ t2 <- typeof e2
+ assert (t1 == TInt)
+ assert (t2 == TInt)
+ return TBool
+typeof (EGrt e1 e2) = do
+ t1 <- typeof e1
+ t2 <- typeof e2
+ assert (t1 == TInt)
+ assert (t2 == TInt)
+ return TBool
+typeof (EIfte e1 e2 e3) = do
+ t1 <- typeof e1
+ t2 <- typeof e2
+ t3 <- typeof e3
+ assert (t1 == TBool)
+ assert (t2 == t3)
+ return t2
+typeof (EAbs x t e) = do
+ t' <- local (insert x t) $ typeof e
+ return $ TFun t t'
+typeof (EApp e []) = typeof e
+typeof (EApp e1 [e2]) = do
+ t1 <- typeof e1
+ t2 <- typeof e2
+ case t1 of
+ (TFun t t')
+ | t == t2 -> return t'
+ _ -> lift Nothing
+typeof (EApp e1 es) = do
+ t1 <- typeof e1
+ ts <- forM es typeof
+ applyTypes t1 ts
+ where
+ applyTypes t [] = return t
+ applyTypes (TFun t t') (t1:ts) = do
+ assert $ t == t1
+ applyTypes t' ts
+typeof (EVrnt l e t@(TVrnt ls)) = do
+ t1 <- typeof e
+ (Labeled l' t2) <- lift $ lookupLabel l ls
+ assert $ t1 == t2
+ return t
+ where
+ lookupLabel l [] = Nothing
+ lookupLabel l (lbl@(Labeled l1 t):ls)
+ | l == l1 = Just lbl
+ | otherwise = lookupLabel l ls
+typeof (EVrnt l e _) = lift Nothing
+typeof (ETpl es) = do
+ ts <- forM es typeof
+ return $ TTpl ts
+typeof (EProj e n) = do
+ t <- typeof e
+ case t of
+ (TTpl ts)
+ | length ts >= fromIntegral n -> return $ ts !! (fromIntegral (n - 1))
+ _ -> lift Nothing
+typeof (EMtch e ms) = do
+ t <- typeof e
+ case t of
+ (TVrnt ls) -> do
+ assert $ (length ms == length ls)
+ ts <- forM (zip ms ls) getMatchingType
+ assert $ allSame ts
+ return $ head ts
+ _ -> lift Nothing
+ where
+ getMatchingType (Matching l1 x e, Labeled l2 t) = do
+ assert $ l1 == l2
+ local (insert x t) $ typeof e
+ allSame [] = True
+ allSame [_] = True
+ allSame (x:y:zs)
+ | x == y = allSame (y:zs)
+ | otherwise = False
+typeof (ENil t) = do
+ case t of
+ (TList _) -> return t
+ _ -> lift Nothing
+typeof (ECons e1 e2) = do
+ t1 <- typeof e1
+ t2 <- typeof e2
+ case t2 of
+ (TList t) -> do
+ assert $ t == t1
+ return t2
+ _ -> lift Nothing
+typeof (EHead e) = do
+ t <- typeof e
+ case t of
+ (TList t') -> return t'
+ _ -> lift Nothing
+typeof (ETail e) = do
+ t <- typeof e
+ case t of
+ (TList _) -> return t
+ _ -> lift Nothing
+typeof (EIsnil e) = do
+ t <- typeof e
+ case t of
+ (TList _) -> return TBool
+ _ -> lift Nothing
+typeof (ELet f ps e1 e2) = do
+ t1 <- local (insertAll ps) $ typeof e1
+ local (insert f (prependParamTypes t1 ps)) $ typeof e2
+ where
+ insertAll [] env = env
+ insertAll ((Param x t):ps) env = insertAll ps $ insert x t env
+ prependParamTypes t ps = Prelude.foldr (\(Param _ t2) t1 -> TFun t2 t1) t ps
+typeof (EFix f) = do
+ t <- typeof f
+ case t of
+ (TFun t1 t2)
+ | t1 == t2 -> return t1
+ _ -> lift Nothing
+typeof (ELetrec f t ps e1 e2) = do
+ typeof (EApp (EAbs f t e2) [(EFix (EAbs f t e1'))])
+ where
+ e1' = Prelude.foldr (\(Param x t') e -> (EAbs x t' e)) e1 ps
diff --git a/schmim.bnfc b/schmim.bnfc
new file mode 100644
index 0000000..6fe294a
--- /dev/null
+++ b/schmim.bnfc
@@ -0,0 +1,51 @@
+ENum. Exp ::= Integer;
+EVar. Exp ::= Ident;
+EAbs. Exp ::= "(" "lambda" Ident ":" Type Exp ")";
+EApp. Exp ::= "("Exp [Exp]")";
+ETr. Exp ::= "true";
+EFl. Exp ::= "false";
+EAdd. Exp ::= "(" "+" Exp Exp")";
+ESub. Exp ::= "(" "-" Exp Exp")";
+EMul. Exp ::= "(" "*" Exp Exp")";
+EDiv. Exp ::= "(" "/" Exp Exp")";
+EEq. Exp ::= "(" "=" Exp Exp")";
+ELeq. Exp ::= "(" "<=" Exp Exp")";
+EGeq. Exp ::= "(" ">=" Exp Exp")";
+ELess. Exp ::= "(" "<" Exp Exp")";
+EGrt. Exp ::= "(" ">" Exp Exp")";
+EAnd. Exp ::= "(" "and" Exp Exp")";
+EOr. Exp ::= "(" "or" Exp Exp")";
+ENot. Exp ::= "(" "not" Exp")";
+EIfte. Exp ::= "(" "if" Exp Exp Exp")";
+ELet. Exp ::= "(" "let" "("Ident [Param]")" Exp Exp")";
+ELetrec. Exp ::= "(" "letrec" "("Ident ":" Type [Param]")" Exp Exp")";
+EVrnt. Exp ::= "<" Ident Exp ">" ":" Type;
+EMtch. Exp ::= "(" "match" Exp [Matching]")";
+ETpl. Exp ::= "{" [Exp] "}";
+EProj. Exp ::= Exp "." Integer;
+ENil. Exp ::= "nil" ":" Type;
+EIsnil. Exp ::= "(" "isnil" Exp")";
+ECons. Exp ::= "(" "cons" Exp Exp")";
+EHead. Exp ::= "(" "head" Exp")";
+ETail. Exp ::= "(" "tail" Exp")";
+EFix. Exp ::= "(" "fix" Exp")";
+separator Exp "";
+
+Param. Param ::= Ident ":" Type;
+separator Param "";
+Matching. Matching ::= "(<" Ident Ident ">" Exp ")";
+separator Matching "";
+
+_. Type ::= "(" Type ")";
+TBool. Type ::= "Bool";
+TInt. Type ::= "Int";
+TFun. Type ::= Type "->" Type;
+TVrnt. Type ::= "<" [Labeled] ">";
+TTpl. Type ::= "{" [Type] "}";
+TList. Type ::= "[" Type "]";
+separator Type "";
+
+Labeled. Labeled ::= Ident ":" Type;
+separator Labeled "";
+
+comment ";";
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-23 08:09:42 +0000