💕 Adding assignment 3

a3/a3-handout/a3.cabal

@@ -0,0 +1,39 @@
+cabal-version:      3.0
+name:               a3
+version:            1.0.0.0
+build-type:         Simple
+
+common common
+    default-language: Haskell2010
+    ghc-options: -Wall
+
+library
+    import: common
+    hs-source-dirs: src
+    build-depends:
+        base
+      , tasty
+      , tasty-hunit
+      , megaparsec
+    exposed-modules:
+        APL.AST
+        APL.Eval
+        APL.Parser
+        APL.Parser_Tests
+
+executable apl
+    import: common
+    main-is: apl.hs
+    build-depends:
+        base
+      , a3
+
+test-suite a3-test
+    import: common
+    type: exitcode-stdio-1.0
+    main-is: runtests.hs
+    build-depends:
+        base
+      , tasty
+      , a3
+

a3/a3-handout/apl.hs

@@ -0,0 +1,35 @@
+module Main (main) where
+
+import APL.Eval (Val (..), eval, runEval)
+import APL.Parser (parseAPL)
+import System.Environment
+  ( getArgs,
+    getProgName,
+  )
+import System.Exit (ExitCode (..), exitWith)
+import System.IO (hPutStrLn, stderr, stdout)
+
+stringVal :: Val -> String
+stringVal (ValBool b) = show b
+stringVal (ValInt x) = show x
+stringVal ValFun {} = "#<fun>"
+
+main :: IO ()
+main = do
+  args <- getArgs
+  case args of
+    [fname] -> do
+      s <- readFile fname
+      case parseAPL fname s of
+        Left err -> hPutStrLn stderr err
+        Right e -> case runEval (eval e) of
+          Left err -> hPutStrLn stderr err
+          Right v -> hPutStrLn stdout $ stringVal v
+    _ -> do
+      prog <- getProgName
+      failure $ "Usage: " ++ prog ++ " FILE"
+  pure ()
+  where
+    failure s = do
+      hPutStrLn stderr s
+      exitWith $ ExitFailure 1

a3/a3-handout/runtests.hs

@@ -0,0 +1,5 @@
+import qualified APL.Parser_Tests
+import Test.Tasty (defaultMain)
+
+main :: IO ()
+main = defaultMain APL.Parser_Tests.tests

a3/a3-handout/src/APL/AST.hs

@@ -0,0 +1,27 @@
+module APL.AST
+  ( VName,
+    Exp (..),
+  )
+where
+
+type VName = String
+
+data Exp
+  = CstInt Integer
+  | CstBool Bool
+  | Add Exp Exp
+  | Sub Exp Exp
+  | Mul Exp Exp
+  | Div Exp Exp
+  | Pow Exp Exp
+  | Eql Exp Exp
+  | If Exp Exp Exp
+  | Var VName
+  | Let VName Exp Exp
+  | Lambda VName Exp
+  | Apply Exp Exp
+  | TryCatch Exp Exp
+  | Print String Exp
+  | KvPut Exp Exp
+  | KvGet Exp
+  deriving (Eq, Show)

a3/a3-handout/src/APL/Eval.hs

@@ -0,0 +1,132 @@
+module APL.Eval
+  ( Val (..),
+    Env,
+    eval,
+    runEval,
+    Error,
+  )
+where
+
+import APL.AST (Exp (..), VName)
+import Control.Monad (ap, liftM)
+
+data Val
+  = ValInt Integer
+  | ValBool Bool
+  | ValFun Env VName Exp
+  deriving (Eq, Show)
+
+type Env = [(VName, Val)]
+
+envEmpty :: Env
+envEmpty = []
+
+envExtend :: VName -> Val -> Env -> Env
+envExtend v val env = (v, val) : env
+
+envLookup :: VName -> Env -> Maybe Val
+envLookup v env = lookup v env
+
+type Error = String
+
+newtype EvalM a = EvalM (Env -> Either Error a)
+
+instance Functor EvalM where
+  fmap = liftM
+
+instance Applicative EvalM where
+  pure x = EvalM $ \_env -> Right x
+  (<*>) = ap
+
+instance Monad EvalM where
+  EvalM x >>= f = EvalM $ \env ->
+    case x env of
+      Left err -> Left err
+      Right x' ->
+        let EvalM y = f x'
+         in y env
+
+askEnv :: EvalM Env
+askEnv = EvalM $ \env -> Right env
+
+localEnv :: (Env -> Env) -> EvalM a -> EvalM a
+localEnv f (EvalM m) = EvalM $ \env -> m (f env)
+
+failure :: String -> EvalM a
+failure s = EvalM $ \_env -> Left s
+
+catch :: EvalM a -> EvalM a -> EvalM a
+catch (EvalM m1) (EvalM m2) = EvalM $ \env ->
+  case m1 env of
+    Left _ -> m2 env
+    Right x -> Right x
+
+runEval :: EvalM a -> Either Error a
+runEval (EvalM m) = m envEmpty
+
+evalIntBinOp :: (Integer -> Integer -> EvalM Integer) -> Exp -> Exp -> EvalM Val
+evalIntBinOp f e1 e2 = do
+  v1 <- eval e1
+  v2 <- eval e2
+  case (v1, v2) of
+    (ValInt x, ValInt y) -> ValInt <$> f x y
+    (_, _) -> failure "Non-integer operand"
+
+evalIntBinOp' :: (Integer -> Integer -> Integer) -> Exp -> Exp -> EvalM Val
+evalIntBinOp' f e1 e2 =
+  evalIntBinOp f' e1 e2
+  where
+    f' x y = pure $ f x y
+
+eval :: Exp -> EvalM Val
+eval (CstInt x) = pure $ ValInt x
+eval (CstBool b) = pure $ ValBool b
+eval (Var v) = do
+  env <- askEnv
+  case envLookup v env of
+    Just x -> pure x
+    Nothing -> failure $ "Unknown variable: " ++ v
+eval (Add e1 e2) = evalIntBinOp' (+) e1 e2
+eval (Sub e1 e2) = evalIntBinOp' (-) e1 e2
+eval (Mul e1 e2) = evalIntBinOp' (*) e1 e2
+eval (Div e1 e2) = evalIntBinOp checkedDiv e1 e2
+  where
+    checkedDiv _ 0 = failure "Division by zero"
+    checkedDiv x y = pure $ x `div` y
+eval (Pow e1 e2) = evalIntBinOp checkedPow e1 e2
+  where
+    checkedPow x y =
+      if y < 0
+        then failure "Negative exponent"
+        else pure $ x ^ y
+eval (Eql e1 e2) = do
+  v1 <- eval e1
+  v2 <- eval e2
+  case (v1, v2) of
+    (ValInt x, ValInt y) -> pure $ ValBool $ x == y
+    (ValBool x, ValBool y) -> pure $ ValBool $ x == y
+    (_, _) -> failure "Invalid operands to equality"
+eval (If cond e1 e2) = do
+  cond' <- eval cond
+  case cond' of
+    ValBool True -> eval e1
+    ValBool False -> eval e2
+    _ -> failure "Non-boolean conditional."
+eval (Let var e1 e2) = do
+  v1 <- eval e1
+  localEnv (envExtend var v1) $ eval e2
+eval (Lambda var body) = do
+  env <- askEnv
+  pure $ ValFun env var body
+eval (Apply e1 e2) = do
+  v1 <- eval e1
+  v2 <- eval e2
+  case (v1, v2) of
+    (ValFun f_env var body, arg) ->
+      localEnv (const $ envExtend var arg f_env) $ eval body
+    (_, _) ->
+      failure "Cannot apply non-function"
+eval (TryCatch e1 e2) =
+  eval e1 `catch` eval e2
+eval e =
+  error $ "Evaluation of this expression not implemented:\n" ++ show e

a3/a3-handout/src/APL/Parser.hs

@@ -0,0 +1,126 @@
+module APL.Parser (parseAPL) where
+
+import APL.AST (Exp (..), VName)
+import Control.Monad (void)
+import Data.Char (isAlpha, isAlphaNum, isDigit)
+import Data.Void (Void)
+import Text.Megaparsec
+  ( Parsec,
+    choice,
+    chunk,
+    eof,
+    errorBundlePretty,
+    many,
+    notFollowedBy,
+    parse,
+    satisfy,
+    some,
+    try,
+  )
+import Text.Megaparsec.Char (space)
+
+type Parser = Parsec Void String
+
+lexeme :: Parser a -> Parser a
+lexeme p = p <* space
+
+keywords :: [String]
+keywords =
+  [ "if",
+    "then",
+    "else",
+    "true",
+    "false",
+    "let",
+    "in",
+    "try",
+    "catch",
+    "print",
+    "put",
+    "get"
+  ]
+
+lVName :: Parser VName
+lVName = lexeme $ try $ do
+  c <- satisfy isAlpha
+  cs <- many $ satisfy isAlphaNum
+  let v = c : cs
+  if v `elem` keywords
+    then fail "Unexpected keyword"
+    else pure v
+
+lInteger :: Parser Integer
+lInteger =
+  lexeme $ read <$> some (satisfy isDigit) <* notFollowedBy (satisfy isAlphaNum)
+
+lString :: String -> Parser ()
+lString s = lexeme $ void $ chunk s
+
+lKeyword :: String -> Parser ()
+lKeyword s = lexeme $ void $ try $ chunk s <* notFollowedBy (satisfy isAlphaNum)
+
+lBool :: Parser Bool
+lBool =
+  lexeme . try . choice $
+    [ const True <$> lKeyword "true",
+      const False <$> lKeyword "false"
+    ]
+
+pAtom :: Parser Exp
+pAtom =
+  choice
+    [ CstInt <$> lInteger,
+      CstBool <$> lBool,
+      Var <$> lVName,
+      lString "(" *> pExp <* lString ")"
+    ]
+
+pLExp :: Parser Exp
+pLExp =
+  choice
+    [ If
+        <$> (lKeyword "if" *> pExp)
+        <*> (lKeyword "then" *> pExp)
+        <*> (lKeyword "else" *> pExp),
+      pAtom
+    ]
+
+pExp1 :: Parser Exp
+pExp1 = pLExp >>= chain
+  where
+    chain x =
+      choice
+        [ do
+            lString "*"
+            y <- pLExp
+            chain $ Mul x y,
+          do
+            lString "/"
+            y <- pLExp
+            chain $ Div x y,
+          pure x
+        ]
+
+pExp0 :: Parser Exp
+pExp0 = pExp1 >>= chain
+  where
+    chain x =
+      choice
+        [ do
+            lString "+"
+            y <- pExp1
+            chain $ Add x y,
+          do
+            lString "-"
+            y <- pExp1
+            chain $ Sub x y,
+          pure x
+        ]
+
+pExp :: Parser Exp
+pExp = pExp0
+
+parseAPL :: FilePath -> String -> Either String Exp
+parseAPL fname s = case parse (space *> pExp <* eof) fname s of
+  Left err -> Left $ errorBundlePretty err
+  Right x -> Right x

a3/a3-handout/src/APL/Parser_Tests.hs

@@ -0,0 +1,68 @@
+module APL.Parser_Tests (tests) where
+
+import APL.AST (Exp (..))
+import APL.Parser (parseAPL)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))
+
+parserTest :: String -> Exp -> TestTree
+parserTest s e =
+  testCase s $
+    case parseAPL "input" s of
+      Left err -> assertFailure err
+      Right e' -> e' @?= e
+
+parserTestFail :: String -> TestTree
+parserTestFail s =
+  testCase s $
+    case parseAPL "input" s of
+      Left _ -> pure ()
+      Right e ->
+        assertFailure $
+          "Expected parse error but received this AST:\n" ++ show e
+
+tests :: TestTree
+tests =
+  testGroup
+    "Parsing"
+    [ testGroup
+        "Constants"
+        [ parserTest "123" $ CstInt 123,
+          parserTest " 123" $ CstInt 123,
+          parserTest "123 " $ CstInt 123,
+          parserTestFail "123f",
+          parserTest "true" $ CstBool True,
+          parserTest "false" $ CstBool False
+        ],
+      testGroup
+        "Basic operators"
+        [ parserTest "x+y" $ Add (Var "x") (Var "y"),
+          parserTest "x-y" $ Sub (Var "x") (Var "y"),
+          parserTest "x*y" $ Mul (Var "x") (Var "y"),
+          parserTest "x/y" $ Div (Var "x") (Var "y")
+        ],
+      testGroup
+        "Operator priority"
+        [ parserTest "x+y+z" $ Add (Add (Var "x") (Var "y")) (Var "z"),
+          parserTest "x+y-z" $ Sub (Add (Var "x") (Var "y")) (Var "z"),
+          parserTest "x+y*z" $ Add (Var "x") (Mul (Var "y") (Var "z")),
+          parserTest "x*y*z" $ Mul (Mul (Var "x") (Var "y")) (Var "z"),
+          parserTest "x/y/z" $ Div (Div (Var "x") (Var "y")) (Var "z")
+        ],
+      testGroup
+        "Conditional expressions"
+        [ parserTest "if x then y else z" $ If (Var "x") (Var "y") (Var "z"),
+          parserTest "if x then y else if x then y else z" $
+            If (Var "x") (Var "y") $
+              If (Var "x") (Var "y") (Var "z"),
+          parserTest "if x then (if x then y else z) else z" $
+            If (Var "x") (If (Var "x") (Var "y") (Var "z")) (Var "z"),
+          parserTest "1 + if x then y else z" $
+            Add (CstInt 1) (If (Var "x") (Var "y") (Var "z"))
+        ],
+      testGroup
+        "Lexing edge cases"
+        [ parserTest "2 " $ CstInt 2,
+          parserTest " 2" $ CstInt 2
+        ]
+    ]