✨ A5

a5/a5-handout/a5.cabal

@@ -0,0 +1,41 @@
+cabal-version:      3.0
+name:               a5
+version:            1.0.0.0
+build-type:         Simple
+
+common common
+    default-language: Haskell2010
+    ghc-options: -Wall -Wno-orphans
+
+library
+    import: common
+    hs-source-dirs: src
+    build-depends:
+        base
+      , megaparsec
+      , QuickCheck
+    exposed-modules:
+        APL.AST
+        APL.Parser
+        APL.Error
+        APL.Eval
+        APL.Check
+        APL.Tests
+
+executable apl
+    import: common
+    main-is: apl.hs
+    build-depends:
+        base
+      , a5
+
+test-suite a5-test
+    import: common
+    type: exitcode-stdio-1.0
+    main-is: runtests.hs
+    build-depends:
+        base
+      , tasty
+      , tasty-quickcheck
+      , a5
+

a5/a5-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 $ show err
+          Right v -> hPutStrLn stdout $ stringVal v
+    _ -> do
+      prog <- getProgName
+      failure $ "Usage: " ++ prog ++ " FILE"
+  pure ()
+  where
+    failure e = do
+      hPutStrLn stderr $ show e
+      exitWith $ ExitFailure 1

a5/a5-handout/runtests.hs

@@ -0,0 +1,6 @@
+import qualified APL.Tests
+import Test.Tasty (defaultMain)
+import Test.Tasty.QuickCheck (testProperties)
+
+main :: IO ()
+main = defaultMain (testProperties "APL properties" APL.Tests.properties)

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

@@ -0,0 +1,82 @@
+module APL.AST
+  ( VName
+  , Exp (..)
+  , printExp
+  , subExp
+  )
+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
+  deriving (Eq, Show)
+
+parens :: String -> String
+parens x = "(" ++ x ++ ")"
+
+printBinOp :: String -> Exp -> Exp -> String
+printBinOp op x y = parens $ printExp x ++ " " ++ op ++ " " ++ printExp y
+
+printExp :: Exp -> String
+printExp (CstInt x) = show x
+printExp (CstBool b) = if b then "true" else "false"
+printExp (Add x y) = printBinOp "+" x y
+printExp (Sub x y) = printBinOp "-" x y
+printExp (Mul x y) = printBinOp "*" x y
+printExp (Div x y) = printBinOp "/" x y
+printExp (Pow x y) = printBinOp "**" x y
+printExp (Eql x y) = printBinOp "==" x y
+printExp (If x y z) =
+  parens $
+    "if "
+      ++ printExp x
+      ++ " then "
+      ++ printExp y
+      ++ " else "
+      ++ printExp z
+printExp (Var v) = v
+printExp (Let v e1 e2) =
+  parens $
+    "let "
+      ++ v
+      ++ " = "
+      ++ printExp e1
+      ++ " in "
+      ++ printExp e2
+printExp (Lambda v body) =
+  parens $ "\\" ++ v ++ " -> " ++ printExp body
+printExp (Apply x y) =
+  printExp x ++ " " ++ printExp y
+printExp (TryCatch x y) =
+  "try " ++ printExp x ++ " catch " ++ printExp y
+
+subExp :: Exp -> [Exp]
+subExp e = e : case e of
+  CstInt _ -> []
+  CstBool _ -> []
+  Add e1 e2 -> subExp e1 ++ subExp e2
+  Sub e1 e2 -> subExp e1 ++ subExp e2
+  Mul e1 e2 -> subExp e1 ++ subExp e2
+  Div e1 e2 -> subExp e1 ++ subExp e2
+  Pow e1 e2 -> subExp e1 ++ subExp e2
+  Eql e1 e2 -> subExp e1 ++ subExp e2
+  If e0 e1 e2 -> subExp e0 ++ subExp e1 ++ subExp e2
+  Var _ -> []
+  Let _ e1 e2 -> subExp e1 ++ subExp e2
+  Lambda _ body -> subExp body
+  Apply e1 e2 -> subExp e1 ++ subExp e2
+  TryCatch e1 e2 -> subExp e1 ++ subExp e2

a5/a5-handout/src/APL/Check.hs

@@ -0,0 +1,92 @@
+module APL.Check (checkExp, Error) where
+
+import APL.AST (Exp (..), VName)
+import APL.Error (Error (..))
+import Control.Monad (ap, liftM, unless)
+import Data.List (union)
+
+type Vars = [VName]
+
+newtype CheckM a = CheckM {runCheckM :: Vars -> (a, [Error])}
+
+instance Functor CheckM where
+  fmap = liftM
+
+instance Applicative CheckM where
+  (<*>) = ap
+  pure x = CheckM $ \_ -> (x, [])
+
+instance Monad CheckM where
+  CheckM x >>= f = CheckM $ \vars ->
+    let (y, errs1) = x vars
+        (z, errs2) = runCheckM (f y) vars
+    in (z, union errs1 errs2)
+
+askVars :: CheckM Vars
+askVars = CheckM $ \vars -> (vars, [])
+
+localVars :: (Vars -> Vars) -> CheckM a -> CheckM a
+localVars f m = CheckM $ \vars ->
+  runCheckM m (f vars)
+
+failure :: Error -> CheckM ()
+failure err = CheckM $ \_ -> ((), [err])
+
+maskErrors :: CheckM a -> CheckM a
+maskErrors m = CheckM $ \vars ->
+  let (x, _) = runCheckM m vars in (x, [])
+
+check :: Exp -> CheckM ()
+check (CstInt _) = pure ()
+check (CstBool _) = pure ()
+check (Var v) = do
+  vars <- askVars
+  unless (v `elem` vars) $
+    failure $
+      UnknownVariable v
+check (Add x y) = do
+  failure NonInteger
+  check x
+  check y
+check (Sub x y) = do
+  failure NonInteger
+  check x
+  check y
+check (Mul x y) = do
+  failure NonInteger
+  check x
+  check y
+check (Div x y) = do
+  failure NonInteger
+  failure DivisionByZero
+  check x
+  check y
+check (Pow x y) = do
+  failure NonInteger
+  failure NegativeExponent
+  check x
+  check y
+check (Eql x y) = do
+  failure InvalidEqual
+  check x
+  check y
+check (If x y z) = do
+  failure NonBoolean
+  check x
+  check y
+  check z
+check (Let v e1 e2) = do
+  check e1
+  localVars (v :) $ check e2
+check (Lambda v e) = do
+  localVars (v :) $ check e
+check (Apply x y) = do
+  failure NonFunction
+  check x
+  check y
+check (TryCatch x y) = do
+  maskErrors $ check x
+  check y
+
+checkExp :: Exp -> [Error]
+checkExp e = snd $ runCheckM (check e) []

a5/a5-handout/src/APL/Error.hs

@@ -0,0 +1,35 @@
+module APL.Error
+  ( Error(..)
+  , isVariableError
+  , isDomainError
+  , isTypeError
+  )
+where
+
+import APL.AST (VName)
+
+data Error
+  = NonInteger
+  | UnknownVariable VName
+  | DivisionByZero
+  | NegativeExponent
+  | InvalidEqual
+  | NonBoolean
+  | NonFunction
+  deriving (Show, Eq)
+
+isVariableError :: Error -> Bool
+isVariableError (UnknownVariable _) = True
+isVariableError _ = False
+
+isDomainError :: Error -> Bool
+isDomainError DivisionByZero = True
+isDomainError NegativeExponent = True
+isDomainError _ = False
+
+isTypeError :: Error -> Bool
+isTypeError NonInteger = True
+isTypeError InvalidEqual = True
+isTypeError NonBoolean = True
+isTypeError NonFunction = True
+isTypeError _ = False

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

@@ -0,0 +1,128 @@
+module APL.Eval
+  ( Val (..),
+    Env,
+    eval,
+    runEval,
+  )
+where
+
+import APL.AST (Exp (..), VName)
+import APL.Error (Error (..))
+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
+
+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 :: Error -> 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 NonInteger
+
+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 $ UnknownVariable 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 DivisionByZero
+    checkedDiv x y = pure $ x `div` y
+eval (Pow e1 e2) = evalIntBinOp checkedPow e1 e2
+  where
+    checkedPow x y =
+      if y < 0
+        then failure NegativeExponent
+        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 InvalidEqual
+eval (If cond e1 e2) = do
+  cond' <- eval cond
+  case cond' of
+    ValBool True -> eval e1
+    ValBool False -> eval e2
+    _ -> failure NonBoolean
+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 NonFunction
+eval (TryCatch e1 e2) =
+  eval e1 `catch` eval e2

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

@@ -0,0 +1,168 @@
+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"
+  ]
+
+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 ")"
+    ]
+
+pFExp :: Parser Exp
+pFExp = chain =<< pAtom
+  where
+    chain x =
+      choice
+        [ do
+            y <- pAtom
+            chain $ Apply x y,
+          pure x
+        ]
+
+pLExp :: Parser Exp
+pLExp =
+  choice
+    [ If
+        <$> (lKeyword "if" *> pExp)
+        <*> (lKeyword "then" *> pExp)
+        <*> (lKeyword "else" *> pExp),
+      Lambda
+        <$> (lString "\\" *> lVName)
+        <*> (lString "->" *> pExp),
+      TryCatch
+        <$> (lKeyword "try" *> pExp)
+        <*> (lKeyword "catch" *> pExp),
+      Let
+        <$> (lKeyword "let" *> lVName)
+        <*> (lString "=" *> pExp)
+        <*> (lKeyword "in" *> pExp),
+      pFExp
+    ]
+
+pExp4 :: Parser Exp
+pExp4 = pLExp >>= chain
+  where
+    chain x =
+      choice
+        [ do
+            lString "**"
+            y <- pLExp
+            Pow x <$> chain y,
+          pure x
+        ]
+
+pExp3 :: Parser Exp
+pExp3 = pExp4 >>= chain
+  where
+    chain x =
+      choice
+        [ do
+            lString "*"
+            y <- pExp4
+            chain $ Mul x y,
+          do
+            lString "/"
+            y <- pExp4
+            chain $ Div x y,
+          pure x
+        ]
+
+pExp2 :: Parser Exp
+pExp2 = pExp3 >>= chain
+  where
+    chain x =
+      choice
+        [ do
+            lString "+"
+            y <- pExp3
+            chain $ Add x y,
+          do
+            lString "-"
+            y <- pExp3
+            chain $ Sub x y,
+          pure x
+        ]
+
+pExp1 :: Parser Exp
+pExp1 = pExp2 >>= chain
+  where
+    chain x =
+      choice
+        [ do
+            lString "=="
+            y <- pExp2
+            chain $ Eql x y,
+          pure x
+        ]
+
+pExp :: Parser Exp
+pExp = pExp1
+
+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

a5/a5-handout/src/APL/Tests.hs

@@ -0,0 +1,92 @@
+module APL.Tests
+  ( properties
+  )
+where
+
+import APL.AST (Exp (..), subExp)
+import APL.Error (isVariableError, isDomainError, isTypeError)
+import APL.Check (checkExp)
+import Test.QuickCheck
+  ( Property
+  , Gen
+  , Arbitrary (arbitrary, shrink)
+  , property
+  , cover
+  , checkCoverage
+  , oneof
+  , sized
+  )
+
+instance Arbitrary Exp where
+  arbitrary = sized genExp
+
+  shrink (Add e1 e2) =
+    e1 : e2 : [Add e1' e2 | e1' <- shrink e1] ++ [Add e1 e2' | e2' <- shrink e2]
+  shrink (Sub e1 e2) =
+    e1 : e2 : [Sub e1' e2 | e1' <- shrink e1] ++ [Sub e1 e2' | e2' <- shrink e2]
+  shrink (Mul e1 e2) =
+    e1 : e2 : [Mul e1' e2 | e1' <- shrink e1] ++ [Mul e1 e2' | e2' <- shrink e2]
+  shrink (Div e1 e2) =
+    e1 : e2 : [Div e1' e2 | e1' <- shrink e1] ++ [Div e1 e2' | e2' <- shrink e2]
+  shrink (Pow e1 e2) =
+    e1 : e2 : [Pow e1' e2 | e1' <- shrink e1] ++ [Pow e1 e2' | e2' <- shrink e2]
+  shrink (Eql e1 e2) =
+    e1 : e2 : [Eql e1' e2 | e1' <- shrink e1] ++ [Eql e1 e2' | e2' <- shrink e2]
+  shrink (If cond e1 e2) =
+    e1 : e2 : [If cond' e1 e2 | cond' <- shrink cond] ++ [If cond e1' e2 | e1' <- shrink e1] ++ [If cond e1 e2' | e2' <- shrink e2]
+  shrink (Let x e1 e2) =
+    e1 : [Let x e1' e2 | e1' <- shrink e1] ++ [Let x e1 e2' | e2' <- shrink e2]
+  shrink (Lambda x e) =
+    [Lambda x e' | e' <- shrink e]
+  shrink (Apply e1 e2) =
+    e1 : e2 : [Apply e1' e2 | e1' <- shrink e1] ++ [Apply e1 e2' | e2' <- shrink e2]
+  shrink (TryCatch e1 e2) =
+    e1 : e2 : [TryCatch e1' e2 | e1' <- shrink e1] ++ [TryCatch e1 e2' | e2' <- shrink e2]
+  shrink _ = []
+
+genExp :: Int -> Gen Exp
+genExp 0 = oneof [CstInt <$> arbitrary, CstBool <$> arbitrary]
+genExp size =
+  oneof
+    [ CstInt <$> arbitrary
+    , CstBool <$> arbitrary
+    , Add <$> genExp halfSize <*> genExp halfSize
+    , Sub <$> genExp halfSize <*> genExp halfSize
+    , Mul <$> genExp halfSize <*> genExp halfSize
+    , Div <$> genExp halfSize <*> genExp halfSize
+    , Pow <$> genExp halfSize <*> genExp halfSize
+    , Eql <$> genExp halfSize <*> genExp halfSize
+    , If <$> genExp thirdSize <*> genExp thirdSize <*> genExp thirdSize
+    , Var <$> arbitrary
+    , Let <$> arbitrary <*> genExp halfSize <*> genExp halfSize
+    , Lambda <$> arbitrary <*> genExp (size - 1)
+    , Apply <$> genExp halfSize <*> genExp halfSize 
+    , TryCatch <$> genExp halfSize <*> genExp halfSize
+    ]
+  where
+    halfSize = size `div` 2
+    thirdSize = size `div` 3
+
+expCoverage :: Exp -> Property
+expCoverage e = checkCoverage
+  . cover 20 (any isDomainError (checkExp e)) "domain error"
+  . cover 20 (not $ any isDomainError (checkExp e)) "no domain error"
+  . cover 20 (any isTypeError (checkExp e)) "type error"
+  . cover 20 (not $ any isTypeError (checkExp e)) "no type error"
+  . cover 5 (any isVariableError (checkExp e)) "variable error"
+  . cover 70 (not $ any isVariableError (checkExp e)) "no variable error"
+  . cover 50 (or [2 <= n && n <= 4 | Var v <- subExp e, let n = length v]) "non-trivial variable"
+  $ ()
+
+parsePrinted :: Exp -> Bool
+parsePrinted _ = undefined
+
+onlyCheckedErrors :: Exp -> Bool
+onlyCheckedErrors _ = undefined
+
+properties :: [(String, Property)]
+properties =
+  [ ("expCoverage", property expCoverage)
+  , ("onlyCheckedErrors", property onlyCheckedErrors)
+  , ("parsePrinted", property parsePrinted)
+  ]