🤐 Zip

.gitignore

@@ -0,0 +1,2 @@
+*/dist-newstyle
+*/db.txt

a3/.gitignore

@@ -0,0 +1 @@
+dist-newstyle

a3/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/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/runtests.hs

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

a3/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/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/src/APL/Parser.hs

@@ -0,0 +1,185 @@
+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
+
+lStringLit :: Parser String
+lStringLit =
+  lexeme $ many (satisfy (/= '"'))
+
+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"
+    ]
+
+pStringLit :: Parser String
+pStringLit =
+  lString "\"" *> lStringLit <* lString "\""
+
+pAtom :: Parser Exp
+pAtom =
+  choice
+    [ CstInt <$> lInteger,
+      CstBool <$> lBool,
+      Var <$> lVName,
+      lString "(" *> pExp <* lString ")"
+    ]
+
+pFExp :: Parser Exp
+pFExp = pAtom >>= chain
+  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
+    ]
+
+pExp3 :: Parser Exp
+pExp3 =
+  choice
+    [
+      Print
+        <$> (lKeyword "print" *> pStringLit)
+        <*> pAtom,
+      KvGet <$> (lKeyword "get" *> pAtom),
+      KvPut <$> (lKeyword "put" *> pAtom)
+            <*> pAtom,
+      pLExp
+    ]
+
+pExp2 :: Parser Exp
+pExp2 = pExp3 >>= chain
+  where
+    chain x =
+      choice
+        [ do
+            lString "**"
+            y <- pExp2
+            chain $ Pow x y,
+          pure x
+        ]
+
+pExp1 :: Parser Exp
+pExp1 = pExp2 >>= 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,
+          do
+            lString "=="
+            y <- pExp1
+            chain $ Eql 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/src/APL/Parser_Tests.hs

@@ -0,0 +1,116 @@
+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
+        ],
+      testGroup
+        "FExp"
+        [ parserTest "x y" $ Apply (Var "x") (Var "y"),
+          parserTest "x y z" $ Apply (Apply (Var "x") (Var "y")) (Var "z"),
+          parserTest "x y z+5" $ Add (Apply (Apply (Var "x") (Var "y")) (Var "z")) (CstInt 5),
+          parserTest "x (y z)" $ Apply (Var "x") (Apply (Var "y") (Var "z"))
+        ],
+      testGroup
+        "Eql"
+        [ parserTest "x == y" $ Eql (Var "x") (Var "y"),
+          parserTest "x == y == z" $ Eql (Eql (Var "x") (Var "y")) (Var "z"),
+          parserTest "x + y == z * x" $ Eql (Add (Var "x") (Var "y")) (Mul (Var "z") (Var "x"))
+        ],
+      testGroup
+        "Pow"
+        [ parserTest "x ** y" $ Pow (Var "x") (Var "y"),
+          parserTest "x ** y ** z" $ Pow (Var "x") (Pow (Var "y") (Var "z")),
+          parserTest "x + y ** z * x" $  Add (Var "x") (Mul (Pow (Var "y") (Var "z")) (Var "x"))
+        ],
+      testGroup
+        "Print"
+        [ parserTest "print \"test\" x" $ Print "test" (Var "x"),
+          parserTest "print \"7\" x" $ Print "7" (Var "x"),
+          parserTest "print \"cool_print\" x" $ Print "cool_print" (Var "x"),
+          parserTest "print \"\" x" $ Print "" (Var "x")
+        ],
+      testGroup
+        "Get"
+        [ parserTest "get x" $ KvGet (Var "x"),
+          parserTest "get 1" $ KvGet (CstInt 1)
+        ],
+      testGroup
+        "Put"
+        [ parserTest "put x y" $ KvPut (Var "x") (Var "y")
+        ],
+      testGroup
+        "Lambda"
+        [ parserTest "\\x->y" $ Lambda "x" (Var "y"),
+          parserTest "\\x->y+z+5" $ Lambda "x" (Add (Add (Var "y") (Var "z")) (CstInt 5))
+        ],
+      testGroup
+        "TryCatch"
+        [ parserTest "try x catch y" $ TryCatch (Var "x") (Var "y")
+        ],
+      testGroup
+        "Let"
+        [ parserTest "let x=5 in y" $ Let "x" (CstInt 5) (Var "y")
+        ]
+    ]

a4/a4.cabal

@@ -0,0 +1,35 @@
+cabal-version:      3.0
+name:               a4
+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
+      , process
+      , directory
+    exposed-modules:
+        APL.AST
+        APL.Eval
+        APL.InterpPure
+        APL.InterpIO
+        APL.Interp_Tests
+        APL.Monad
+        APL.Util
+
+test-suite a4-test
+    import: common
+    type: exitcode-stdio-1.0
+    main-is: runtests.hs
+    build-depends:
+        base
+      , tasty
+      , a4

a4/runtests.hs

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

a4/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)

a4/src/APL/Eval.hs

@@ -0,0 +1,93 @@
+module APL.Eval
+  ( eval,
+  )
+where
+
+import APL.AST (Exp (..))
+import APL.Monad
+
+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
+
+-- Replaced their eval with ours as instructed NOTE
+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 (Print s e1) = do
+  v1 <- eval e1
+  case v1 of
+    (ValInt i) -> do
+      evalPrint (s++": "++(show i))
+      pure $ v1
+    (ValBool b) -> do
+      evalPrint (s++": "++(show b))
+      pure $ v1
+    (ValFun _ _ _) -> do
+      evalPrint (s++": #<fun>")
+      pure $ v1
+eval (KvPut e1 e2) = do
+  v1 <- eval e1
+  v2 <- eval e2
+  evalKvPut v1 v2
+  pure $ v2
+eval (KvGet e) = do
+  v <- eval e
+  evalKvGet v

a4/src/APL/InterpIO.hs

@@ -0,0 +1,112 @@
+module APL.InterpIO (runEvalIO) where
+
+import APL.Monad
+import APL.Util
+import System.Directory (removeFile)
+import System.IO (hFlush, readFile', stdout)
+
+-- Converts a string into a value. Only 'ValInt's and 'ValBool' are supported.
+readVal :: String -> Maybe Val
+readVal = unserialize
+
+-- 'prompt s' prints 's' to the console and then reads a line from stdin.
+prompt :: String -> IO String
+prompt s = do
+  putStr s
+  hFlush stdout
+  getLine
+
+-- 'writeDB dbFile s' writes the 'State' 's' to the file 'db'.
+writeDB :: FilePath -> State -> IO ()
+writeDB db s =
+  writeFile db $ serialize s
+
+-- 'readDB db' reads the database stored in 'db'.
+readDB :: FilePath -> IO (Either Error State)
+readDB db = do
+  ms <- readFile' db
+  case unserialize ms of
+    Just s -> pure $ pure s
+    Nothing -> pure $ Left "Invalid DB."
+
+-- 'copyDB db1 db2' copies 'db1' to 'db2'.
+copyDB :: FilePath -> FilePath -> IO ()
+copyDB db db' = do
+  s <- readFile' db
+  writeFile db' s
+
+-- Removes all key-value pairs from the database file.
+clearDB :: IO ()
+clearDB = writeFile dbFile ""
+
+-- The name of the database file.
+dbFile :: FilePath
+dbFile = "db.txt"
+
+-- Creates a fresh temporary database, passes it to a function returning an
+-- IO-computation, executes the computation, deletes the temporary database, and
+-- finally returns the result of the computation. The temporary database file is
+-- guaranteed fresh and won't have a name conflict with any other files.
+withTempDB :: (FilePath -> IO a) -> IO a
+withTempDB m = do
+  tempDB <- newTempDB -- Create a new temp database file.
+  res <- m tempDB -- Run the computation with the new file.
+  removeFile tempDB -- Delete the temp database file.
+  pure res -- Return the result of the computation.
+
+runEvalIO :: EvalM a -> IO (Either Error a)
+runEvalIO evalm = do
+  clearDB
+  runEvalIO' envEmpty dbFile evalm
+  where
+    runEvalIO' :: Env -> FilePath -> EvalM a -> IO (Either Error a)
+    runEvalIO' _ _ (Pure x) = pure $ pure x
+    runEvalIO' r db (Free (ReadOp k)) = runEvalIO' r db $ k r
+    runEvalIO' r db (Free (StateGetOp k)) = do
+      result <- readDB db
+      case result of
+        Right s -> runEvalIO' r db $ k s
+        Left e -> pure $ Left e
+    runEvalIO' r db (Free (StatePutOp s m)) = do
+      writeDB db s
+      runEvalIO' r db m
+    runEvalIO' r db (Free (PrintOp p m)) = do
+      putStrLn p
+      runEvalIO' r db m
+    runEvalIO' r db (Free (KvGetOp key k)) = do
+      result <- readDB db
+      case result of
+        Right s -> case (lookup key s) of
+          Just val -> runEvalIO' r db $ k val
+          Nothing ->  do
+            input <- prompt $ "Invalid key: "++(show key)++". Enter a replacement: "
+            let val = readVal input
+            case val of
+              Just v -> runEvalIO' r db $ (Free (KvGetOp v k))
+              Nothing -> pure $ Left $ "Invalid key: "++input
+        Left e -> pure $ Left e
+    runEvalIO' r db (Free (KvPutOp key val m)) = do
+      result <- readDB db
+      case result of
+        Right dbState -> do
+          let dbState' = (key,val):dbState
+          writeDB db dbState'
+          runEvalIO' r db m
+        Left e -> pure $ Left e
+    runEvalIO' r db (Free (TryCatchOp m l)) = do
+      result <- runEvalIO' r db m
+      case result of
+        Right x -> pure $ Right x
+        Left _ -> runEvalIO' r db l
+    runEvalIO' r db (Free (TransactionOp l m)) = do
+      withTempDB transactionDB
+      runEvalIO' r db m
+      where
+        transactionDB :: (FilePath -> IO ())
+        transactionDB db' = do
+          copyDB db db'
+          resl <- runEvalIO' r db (do l)
+          case resl of
+            Right _ -> pure ()
+            Left _ -> copyDB db' db
+    runEvalIO' _ _ (Free (ErrorOp e)) = pure $ Left e

a4/src/APL/InterpPure.hs

@@ -0,0 +1,35 @@
+module APL.InterpPure (runEval) where
+
+import APL.Monad
+
+runEval :: EvalM a -> ([String], Either Error a)
+runEval = runEval' envEmpty stateInitial
+  where
+    runEval' :: Env -> State -> EvalM a -> ([String], Either Error a)
+    runEval' _ _ (Pure x) = ([], pure x)
+    runEval' r s (Free (ReadOp k)) = runEval' r s $ k r
+    runEval' r s (Free (StateGetOp k)) = runEval' r s $ k s
+    runEval' r _ (Free (StatePutOp s' m)) = runEval' r s' m
+    runEval' r s (Free (PrintOp p m)) =
+      let (ps, res) = runEval' r s m
+       in (p : ps, res)
+    runEval' r s (Free (TryCatchOp m l)) =
+      case (runEval' r s m) of
+        (_, Left _) -> runEval' r s l
+        a -> a
+    runEval' r s (Free (KvGetOp key k)) =
+      case (lookup key s) of
+        Just val -> runEval' r s $ k val
+        Nothing -> ([], Left ("Cannot find key: "++(show key)))
+    runEval' r s (Free (KvPutOp key val m)) =
+      runEval' r ((key,val):s) m
+    runEval' r s (Free (TransactionOp l m)) =
+      let (p, resl) = runEval' r s (do l >> getState)
+      in case resl of
+        Right s' ->
+          let (ps, resm) = runEval' r s' m
+          in (p ++ ps, resm)
+        Left _ ->
+          let (ps, resm) = runEval' r s m
+          in (p ++ ps, resm)
+    runEval' _ _ (Free (ErrorOp e)) = ([], Left e)

a4/src/APL/Interp_Tests.hs

@@ -0,0 +1,273 @@
+module APL.Interp_Tests (tests) where
+
+import APL.AST (Exp (..))
+import APL.Eval (eval)
+import APL.InterpIO (runEvalIO)
+import APL.InterpPure (runEval)
+import APL.Monad
+import APL.Util (captureIO)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (testCase, (@?=))
+
+eval' :: Exp -> ([String], Either Error Val)
+eval' = runEval . eval
+
+evalIO' :: Exp -> IO (Either Error Val)
+evalIO' = runEvalIO . eval
+
+tests :: TestTree
+tests = testGroup "Free monad interpreters" [pureTests, ioTests]
+
+pureTests :: TestTree
+pureTests =
+  testGroup
+    "Pure interpreter"
+    [ testCase "localEnv" $
+        runEval
+          ( localEnv (const [("x", ValInt 1)]) $
+              askEnv
+          )
+          @?= ([], Right [("x", ValInt 1)]),
+      --
+      testCase "Let" $
+        eval' (Let "x" (Add (CstInt 2) (CstInt 3)) (Var "x"))
+          @?= ([], Right (ValInt 5)),
+      --
+      testCase "Let (shadowing)" $
+        eval'
+          ( Let
+              "x"
+              (Add (CstInt 2) (CstInt 3))
+              (Let "x" (CstBool True) (Var "x"))
+          )
+          @?= ([], Right (ValBool True)),
+      --
+      testCase "State" $
+        runEval
+          ( do
+              putState [(ValInt 0, ValInt 1)]
+              modifyState $ map (\(key, _) -> (key, ValInt 5))
+              getState
+          )
+          @?= ([], Right [(ValInt 0, ValInt 5)]),
+      --
+      testCase "Print" $
+        runEval (evalPrint "test")
+          @?= (["test"], Right ()),
+      --
+      testCase "Error" $
+        runEval
+          ( do
+              _ <- failure "Oh no!"
+              evalPrint "test"
+          )
+          @?= ([], Left "Oh no!"),
+      --
+      testCase "Div0" $
+        eval' (Div (CstInt 7) (CstInt 0))
+          @?= ([], Left "Division by zero"),
+      --
+      testCase "TryCatch try1" $
+        eval' (TryCatch (CstInt 1) (CstInt 2))
+          @?= ([], Right (ValInt 1)),
+      --
+      testCase "TryCatch try2" $
+        eval' (TryCatch (CstInt 1) (Div (CstInt 1) (CstInt 0)))
+          @?= ([], Right (ValInt 1)),
+      --
+      testCase "TryCatch catch1" $
+        eval' (TryCatch (Div (CstInt 1) (CstInt 0)) (CstInt 1))
+          @?= ([], Right (ValInt 1)),
+      --
+      testCase "TryCatch catch2" $
+        eval' (TryCatch (Div (CstInt 1) (CstInt 0)) (Div (CstInt 1) (CstInt 0)))
+          @?= ([], Left "Division by zero"),
+      --
+      testCase "KvPutOp" $
+        eval' (KvPut (CstInt 1) (CstInt 2))
+          @?= ([], Right (ValInt 2)),
+      --
+      testCase "KvGetOp" $
+        eval' (Let "_" (KvPut (CstInt 1) (CstInt 2)) (KvGet (CstInt 1)))
+          @?= ([], Right (ValInt 2)),
+      --
+      testCase "KvGetOp shadowing" $
+        eval' (Let "_" (KvPut (CstInt 1) (CstInt 2)) (Let "_" (KvPut (CstInt 1) (CstInt 3)) (KvGet (CstInt 1))))
+          @?= ([], Right (ValInt 3)),
+      --
+      testCase "KvGetOp fail" $
+        eval' (KvGet (CstInt 1))
+          @?= ([], Left "Cannot find key: ValInt 1"),
+      --
+      testCase "TransactionOp 1" $
+        let goodPut = (evalKvPut (ValInt 0) (ValInt 1)) in
+        runEval (transaction goodPut)
+          @?= ([], Right ()),
+      --
+      testCase "TransactionOp 2" $
+        let goodPut = evalKvPut (ValInt 0) (ValInt 1) in
+        let get0 = eval (KvGet (CstInt 0)) in
+        runEval (transaction goodPut >> get0)
+          @?= ([], Right (ValInt 1)),
+      --
+      testCase "TransactionOp 3" $
+        let oPut = (evalKvPut (ValInt 1) (ValInt 2)) in
+        let okayPut = ((evalKvGet (ValInt 1) >> evalKvPut (ValInt 0) (ValInt 1))) in
+        let get0 = eval (KvGet (CstInt 0)) in
+        runEval (oPut >> (transaction okayPut) >> get0)
+          @?= ([], Right (ValInt 1)),
+      --
+      testCase "TransactionOp Fail" $
+        let badPut = (evalKvPut (ValInt 0) (ValInt 1)) >> (failure "die") in
+        let get0 = eval (KvGet (CstInt 0)) in
+        runEval (transaction badPut >> get0)
+          @?= ([], Left "Cannot find key: ValInt 0"),
+      --
+      testCase "TransactionOp Propagation" $
+        let badPut = (evalKvPut (ValInt 0) (ValInt 1)) >> (failure "die") in
+        runEval (transaction badPut)
+          @?= ([], Right ()),
+      --
+      testCase "TransactionOp Printing" $
+        runEval (transaction (evalPrint "weee" >> failure "oh shit"))
+          @?= (["weee"], Right ()),
+      --
+      testCase "TransactionOp Nested" $
+        let badPut = (evalKvPut (ValInt 0) (ValInt 1)) >> (failure "die") in
+        let goodPut = evalKvPut (ValInt 0) (ValInt 1) in
+        let get0 = eval (KvGet (CstInt 0)) in
+        runEval (transaction (goodPut >> transaction badPut) >> get0)
+          @?= ([], Right (ValInt 1))
+    ]
+
+ioTests :: TestTree
+ioTests =
+  testGroup
+    "IO interpreter"
+    [ testCase "print" $ do
+        let s1 = "Lalalalala"
+            s2 = "Weeeeeeeee"
+        (out, res) <-
+          captureIO [] $
+            runEvalIO $ do
+              evalPrint s1
+              evalPrint s2
+        (out, res) @?= ([s1, s2], Right ()),
+      ---
+      testCase "print 2" $ do
+          (out, res) <-
+            captureIO [] $
+              evalIO' $
+                Print "This is also 1" $
+                  Print "This is 1" $
+                    CstInt 1
+          (out, res) @?= (["This is 1: 1", "This is also 1: 1"], Right $ ValInt 1),
+      ---
+      testCase "State" $ do
+        r <- runEvalIO $ do
+          putState [(ValInt 0, ValInt 1)]
+          modifyState $ map (\(key, _) -> (key, ValInt 5))
+          getState
+
+        r @?= Right [(ValInt 0, ValInt 5)],
+      ---
+      testCase "TryCatch try1" $ do
+        r <- evalIO' (TryCatch (CstInt 1) (CstInt 2))
+        r @?= Right (ValInt 1),
+      ---
+      testCase "TryCatch try2" $ do
+        r <- evalIO' (TryCatch (CstInt 1) (Div (CstInt 1) (CstInt 0)))
+        r @?= Right (ValInt 1),
+      ---
+      testCase "TryCatch catch1" $ do
+        r <- evalIO' (TryCatch (Div (CstInt 1) (CstInt 0)) (CstInt 1))
+        r @?= Right (ValInt 1),
+      ---
+      testCase "TryCatch catch2" $ do
+        r <- evalIO' (TryCatch (Div (CstInt 1) (CstInt 0)) (Div (CstInt 1) (CstInt 0)))
+        r @?= Left "Division by zero",
+      ---
+      testCase "KvPutOp" $ do
+        r <- evalIO' (KvPut (CstInt 1) (CstInt 2))
+        r @?= Right (ValInt 2),
+      --
+      testCase "KvGetOp" $ do
+        r <- evalIO' (Let "_" (KvPut (CstInt 1) (CstInt 2)) (KvGet (CstInt 1)))
+        r @?= Right (ValInt 2),
+      --
+      testCase "KvGetOp Bool" $ do
+        r <- evalIO' (Let "_" (KvPut (CstBool True) (CstBool False)) (KvGet (CstBool True)))
+        r @?= Right (ValBool False),
+      --
+      testCase "KvGetOp shadowing" $ do
+        r <- evalIO' (Let "_" (KvPut (CstInt 1) (CstInt 2)) (Let "_" (KvPut (CstInt 1) (CstInt 3)) (KvGet (CstInt 1))))
+        r @?= Right (ValInt 3),
+      --
+      testCase "KvGetOp fail" $ do
+        (_, r) <-
+          captureIO [":)"] $
+            evalIO' (KvGet (CstInt 1))
+        r @?= Left "Invalid key: :)",
+      --
+      testCase "KvGetOp invalid int" $ do
+        (_, r) <-
+          captureIO ["ValInt 1"] $
+            evalIO' (Let "_" (KvPut (CstInt 1) (CstInt 2)) (KvGet (CstInt 3)))
+        r @?= Right (ValInt 2),
+      --
+      testCase "KvGetOp invalid bool" $ do
+        (_, r) <-
+          captureIO ["ValBool True"] $
+            evalIO' (Let "_" (KvPut (CstBool True) (CstInt 2)) (KvGet (CstInt 3)))
+        r @?= Right (ValInt 2),
+      --
+      testCase "KvGetOp invalid multiple" $ do
+        (_, r) <-
+          captureIO ["ValInt 1","ValInt 2","ValInt 3"] $
+            evalIO' (Let "_" (KvPut (CstInt 3) (CstInt 2)) (KvGet (CstInt 4)))
+        r @?= Right (ValInt 2),
+      --
+      testCase "TransactionOp 1" $
+        let goodPut = (evalKvPut (ValInt 0) (ValInt 1)) in do
+        r <- runEvalIO (transaction goodPut)
+        r @?= Right (),
+      --
+      testCase "TransactionOp 2" $
+        let goodPut = evalKvPut (ValInt 0) (ValInt 1) in
+        let get0 = eval (KvGet (CstInt 0)) in do
+        r <- runEvalIO (transaction goodPut >> get0)
+        r @?= Right (ValInt 1),
+      --
+      testCase "TransactionOp 3" $
+        let oPut = (evalKvPut (ValInt 1) (ValInt 2)) in
+        let okayPut = ((evalKvGet (ValInt 1) >> evalKvPut (ValInt 0) (ValInt 1))) in
+        let get0 = eval (KvGet (CstInt 0)) in do
+        r <- runEvalIO (oPut >> (transaction okayPut) >> get0)
+        r @?= Right (ValInt 1),
+      --
+      testCase "TransactionOp Fail" $
+        let badPut = (evalKvPut (ValInt 0) (ValInt 1)) >> (failure "die") in
+        let get0 = eval (KvGet (CstInt 0)) in do
+        (_, r) <-
+          captureIO [":)"] $
+            runEvalIO (transaction badPut >> get0)
+        r @?= Left "Invalid key: :)",
+      -- --
+      testCase "TransactionOp Propagation" $
+        let badPut = (evalKvPut (ValInt 0) (ValInt 1)) >> (failure "die") in do
+        r <- runEvalIO (transaction badPut)
+        r @?= Right (),
+      -- --
+      testCase "TransactionOp Printing" $ do
+        (p, r) <-
+          captureIO [] $
+            runEvalIO (transaction (evalPrint "weee" >> failure "oh shit"))
+        (p, r) @?= (["weee"], Right ()),
+      -- --
+      testCase "TransactionOp Nested" $
+        let badPut = (evalKvPut (ValInt 0) (ValInt 1)) >> (failure "die") in
+        let goodPut = evalKvPut (ValInt 0) (ValInt 1) in
+        let get0 = eval (KvGet (CstInt 0)) in do
+        r <- runEvalIO (transaction (goodPut >> transaction badPut) >> get0)
+        r @?= Right (ValInt 1)
+    ]

a4/src/APL/Monad.hs

@@ -0,0 +1,137 @@
+module APL.Monad
+  ( envEmpty,
+    envExtend,
+    envLookup,
+    stateInitial,
+    askEnv,
+    modifyEffects,
+    localEnv,
+    getState,
+    putState,
+    modifyState,
+    evalPrint,
+    catch,
+    failure,
+    evalKvGet,
+    evalKvPut,
+    transaction,
+    EvalM,
+    Val (..),
+    EvalOp (..),
+    Free (..),
+    Error,
+    Env,
+    State,
+  )
+where
+
+import APL.AST (Exp (..), VName)
+import Control.Monad (ap)
+
+data Val
+  = ValInt Integer
+  | ValBool Bool
+  | ValFun Env VName Exp
+  deriving (Eq, Show)
+
+type Error = String
+
+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 State = [(Val, Val)]
+
+stateInitial :: State
+stateInitial = []
+
+data Free e a
+  = Pure a
+  | Free (e (Free e a))
+
+instance (Functor e) => Functor (Free e) where
+  fmap f (Pure x) = Pure $ f x
+  fmap f (Free g) = Free $ fmap (fmap f) g
+
+instance (Functor e) => Applicative (Free e) where
+  pure = Pure
+  (<*>) = ap
+
+instance (Functor e) => Monad (Free e) where
+  Pure x >>= f = f x
+  Free g >>= f = Free $ h <$> g
+    where
+      h x = x >>= f
+
+data EvalOp a
+  = ReadOp (Env -> a)
+  | StateGetOp (State -> a)
+  | StatePutOp State a
+  | PrintOp String a
+  | ErrorOp Error
+  | TryCatchOp a a
+  | KvGetOp Val (Val -> a)
+  | KvPutOp Val Val a
+  | TransactionOp (EvalM ()) a
+
+instance Functor EvalOp where
+  fmap f (ReadOp k) = ReadOp $ f . k
+  fmap f (StateGetOp k) = StateGetOp $ f . k
+  fmap f (StatePutOp s m) = StatePutOp s $ f m
+  fmap f (PrintOp p m) = PrintOp p $ f m
+  fmap _ (ErrorOp e) = ErrorOp e
+  fmap f (TryCatchOp m1 m2) = TryCatchOp (f m1) (f m2)
+  fmap f (KvGetOp v k) = KvGetOp v (f . k)
+  fmap f (KvPutOp v1 v2 m) = KvPutOp v1 v2 (f m)
+  fmap f (TransactionOp l m) = TransactionOp l (f m)
+
+type EvalM a = Free EvalOp a
+
+askEnv :: EvalM Env
+askEnv = Free $ ReadOp $ \env -> pure env
+
+modifyEffects :: (Functor e, Functor h) => (e (Free e a) -> h (Free e a)) -> Free e a -> Free h a
+modifyEffects _ (Pure x) = Pure x
+modifyEffects g (Free e) = Free $ modifyEffects g <$> g e
+
+localEnv :: (Env -> Env) -> EvalM a -> EvalM a
+localEnv f = modifyEffects g
+  where
+    g (ReadOp k) = ReadOp $ k . f
+    g op = op
+
+getState :: EvalM State
+getState = Free $ StateGetOp $ \s -> pure s
+
+putState :: State -> EvalM ()
+putState s = Free $ StatePutOp s $ pure ()
+
+modifyState :: (State -> State) -> EvalM ()
+modifyState f = do
+  s <- getState
+  putState $ f s
+
+evalPrint :: String -> EvalM ()
+evalPrint p = Free $ PrintOp p $ pure ()
+
+failure :: String -> EvalM a
+failure = Free . ErrorOp
+
+catch :: EvalM a -> EvalM a -> EvalM a
+catch m1 m2 = Free $ TryCatchOp m1 m2
+
+evalKvGet :: Val -> EvalM Val
+evalKvGet v = Free $ KvGetOp v $ \w -> pure w
+
+evalKvPut :: Val -> Val -> EvalM ()
+evalKvPut v1 v2 = Free $ KvPutOp v1 v2 $ pure ()
+
+transaction :: EvalM () -> EvalM ()
+transaction v = Free $ TransactionOp v $ pure ()

a4/src/APL/Util.hs

@@ -0,0 +1,99 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+module APL.Util
+  ( Serialize (..),
+    newTempDB,
+    captureIO,
+  )
+where
+
+import APL.Monad
+import Control.Concurrent (threadDelay)
+import Control.Exception (bracket)
+import Control.Monad (guard)
+import Data.Char (isDigit)
+import Data.List (stripPrefix)
+import Data.Maybe (mapMaybe)
+import GHC.IO.Handle (hDuplicate, hDuplicateTo)
+import System.Directory (listDirectory)
+import System.IO
+import System.Process (createPipe)
+import Text.Read (readMaybe)
+
+class Serialize a where
+  serialize :: a -> String
+  unserialize :: String -> Maybe a
+
+instance Serialize Val where
+  serialize (ValInt x) = "ValInt " <> show x
+  serialize (ValBool b) = "ValBool " <> show b
+  serialize ValFun {} = error "ValFun serialization is not supported."
+
+  unserialize s =
+    case words s of
+      ["ValInt", rest]
+        | all isDigit rest -> ValInt <$> readMaybe rest
+      ["ValBool", rest] -> ValBool <$> readMaybe rest
+      _ -> Nothing
+
+instance (Serialize a, Serialize b) => Serialize (a, b) where
+  serialize (a, b) =
+    serialize a ++ "," ++ serialize b
+  unserialize s =
+    case span (/= ',') s of
+      (s_a, _ : s_b) -> (,) <$> unserialize s_a <*> unserialize s_b
+      _ -> Nothing
+
+instance Serialize [(Val, Val)] where
+  serialize kv =
+    unlines $ map serialize kv
+  unserialize =
+    mapM unserialize . lines
+
+newTempDB :: IO FilePath
+newTempDB = do
+  files <- listDirectory "."
+  let n = maximum (0 : mapMaybe match files) + 1
+      tempFile = "temp" ++ show n ++ ".txt"
+  writeFile tempFile ""
+  pure $ tempFile
+  where
+    match :: FilePath -> Maybe Int
+    match s = do
+      s' <- stripPrefix "temp" s
+      let (n_s, rest) = (takeWhile isDigit s', dropWhile isDigit s')
+      guard $ rest == ".txt"
+      readMaybe n_s
+
+captureIO :: [String] -> IO a -> IO ([String], a)
+captureIO inputs m = do
+  hFlush stdout
+  threadDelay 50000 -- Needed to make sure things are actually flushed
+  stdin' <- hDuplicate stdin
+  stdout' <- hDuplicate stdout
+
+  (inR, inW) <- createPipe
+  (outR, outW) <- createPipe
+
+  hSetBuffering inW NoBuffering
+  hSetBuffering outW NoBuffering
+
+  bracket
+    ( do
+        inR `hDuplicateTo` stdin
+        outW `hDuplicateTo` stdout
+    )
+    ( \_ -> do
+        stdin' `hDuplicateTo` stdin
+        stdout' `hDuplicateTo` stdout
+        mapM_ hClose [stdin', stdout', inR, inW, outW]
+    )
+    ( \_ -> do
+        mapM_ (hPutStrLn inW) inputs
+        hFlush inW
+
+        res <- m
+
+        output <- hGetContents outR -- hGetContents closes outR
+        pure (lines output, res)
+    )

a5/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/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/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/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) =
+  parens $ printExp x ++ " " ++ printExp y
+printExp (TryCatch x y) =
+  parens $ "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/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/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/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/src/APL/Parser.hs

@@ -0,0 +1,168 @@
+module APL.Parser (parseAPL, keywords) 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/src/APL/Tests.hs

@@ -0,0 +1,127 @@
+module APL.Tests
+  ( properties,
+    genVar
+  )
+where
+
+import APL.AST (Exp (..), subExp, VName, printExp)
+import APL.Eval (eval, runEval)
+import APL.Parser (parseAPL, keywords)
+import APL.Error (isVariableError, isDomainError, isTypeError)
+import APL.Check (checkExp)
+import Test.QuickCheck
+  ( Property
+  , Gen
+  , Arbitrary (arbitrary, shrink)
+  , property
+  , cover
+  , checkCoverage
+  , oneof
+  , sized
+  , frequency
+  , elements
+  , listOf
+  , suchThat
+  , resize
+  , withMaxSuccess
+  )
+
+genString :: Gen String
+genString = resize 4 $ listOf $ elements ['a'..'z']
+
+varTest :: String -> Bool
+varTest s = (not (s `elem` keywords)) && ((length s) > 1)
+
+genVar :: Gen String
+genVar = suchThat (genString) (varTest)
+
+genInt :: Gen Integer
+genInt = suchThat arbitrary (\i -> i >= 0)
+
+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 :: [VName] -> Int -> Gen Exp
+genExp _ 0 = oneof [CstInt <$> genInt, CstBool <$> arbitrary]
+genExp vars size =
+  frequency
+    [ (1, CstInt <$> genInt)
+    , (1, CstBool <$> arbitrary)
+    , (1, Add <$> genExp vars halfSize <*> genExp vars halfSize)
+    , (1, Sub <$> genExp vars halfSize <*> genExp vars halfSize)
+    , (1, Mul <$> genExp vars halfSize <*> genExp vars halfSize)
+    , (1, Div <$> genExp vars halfSize <*> genExp vars halfSize)
+    , (1, Pow <$> genExp vars halfSize <*> genExp vars halfSize)
+    , (1, Eql <$> genExp vars halfSize <*> genExp vars halfSize)
+    , (1, If <$> genExp vars thirdSize <*> genExp vars thirdSize <*> genExp vars thirdSize)
+    , (1, Var <$> genVar)
+    , (if (length vars) > 0 then 50 else 0, Var <$> elements vars)
+    , (25, do
+        var <- genVar
+        e1 <- genExp vars halfSize
+        e2 <- genExp (var:vars) halfSize
+        pure $ Let var e1 e2
+      )
+    , (25, do
+        var <- genVar
+        body <- genExp vars (size - 1)
+        pure $ Lambda var body
+      )
+    , (1, Apply <$> genExp vars halfSize <*> genExp vars halfSize)
+    , (1, TryCatch <$> genExp vars halfSize <*> genExp vars 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 e = case (parseAPL "input" (printExp e)) of
+  Left _ -> False
+  Right e' -> e == e'
+
+onlyCheckedErrors :: Exp -> Bool
+onlyCheckedErrors e = case runEval (eval e) of
+  Right _ -> True
+  Left err -> err `elem` (checkExp e)
+
+properties :: [(String, Property)]
+properties =
+  [ ("expCoverage", property expCoverage)
+  , ("parsePrinted", property (withMaxSuccess 10000 parsePrinted))
+  , ("onlyCheckedErrors", property (withMaxSuccess 1000000 onlyCheckedErrors))
+  ]

a6/a6.cabal

@@ -0,0 +1,30 @@
+cabal-version:      3.0
+name:               a6
+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
+      , clock
+    exposed-modules:
+        SPC
+        SPC_Tests
+        GenServer
+
+test-suite a6-tests
+    import: common
+    type: exitcode-stdio-1.0
+    main-is: runtests.hs
+    build-depends:
+        base
+      , tasty
+      , a6

a6/runtests.hs

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

a6/src/GenServer.hs

@@ -0,0 +1,45 @@
+module GenServer
+  ( Chan,
+    Server(..),
+    receive,
+    send,
+    sendTo,
+    spawn,
+    ReplyChan,
+    requestReply,
+    reply,
+  )
+where
+
+import Control.Concurrent (Chan)
+import qualified Control.Concurrent as CC
+
+data Server msg = Server CC.ThreadId (Chan msg)
+
+data ReplyChan a = ReplyChan (Chan a)
+
+send :: Chan a -> a -> IO ()
+send chan msg =
+  CC.writeChan chan msg
+
+sendTo :: Server a -> a -> IO ()
+sendTo (Server _tid input) msg =
+  send input msg
+
+receive :: Chan a -> IO a
+receive = CC.readChan
+
+spawn :: (Chan a -> IO ()) -> IO (Server a)
+spawn server = do
+  input <- CC.newChan
+  tid <- CC.forkIO $ server input
+  pure $ Server tid input
+
+requestReply :: Server a -> (ReplyChan b -> a) -> IO b
+requestReply serv con = do
+  reply_chan <- CC.newChan
+  sendTo serv $ con $ ReplyChan reply_chan
+  receive reply_chan
+
+reply :: ReplyChan a -> a -> IO ()
+reply (ReplyChan chan) x = send chan x

a6/src/SPC.hs

@@ -0,0 +1,409 @@
+{-# LANGUAGE InstanceSigs #-}
+module SPC
+  ( -- * SPC startup
+    SPC,
+    startSPC,
+
+    -- * Job functions
+    Job (..),
+    JobId,
+    JobStatus (..),
+    JobDoneReason (..),
+    jobAdd,
+    jobStatus,
+    jobWait,
+    jobCancel,
+
+    -- * Worker functions
+    WorkerName,
+    workerAdd,
+    workerStop,
+
+    -- debugState,
+    -- SPCState (..)
+  )
+where
+
+import Control.Concurrent
+  ( forkIO,
+    killThread,
+    threadDelay,
+    ThreadId
+  )
+import Control.Exception (SomeException, catch)
+import Control.Monad (ap, forever, liftM, void, filterM, when)
+import GenServer
+import System.Clock.Seconds (Clock (Monotonic), Seconds, getTime)
+
+-- First some general utility functions.
+
+-- | Retrieve Unix time using a monotonic clock. You cannot use this
+-- to measure the actual world time, but you can use it to measure
+-- elapsed time.
+getSeconds :: IO Seconds
+getSeconds = getTime Monotonic
+
+-- | Remove mapping from association list.
+removeAssoc :: (Eq k) => k -> [(k, v)] -> [(k, v)]
+removeAssoc needle ((k, v) : kvs) =
+  if k == needle
+    then kvs
+    else (k, v) : removeAssoc needle kvs
+removeAssoc _ [] = []
+
+-- Then the definition of the glorious SPC.
+
+-- | A job that is to be enqueued in the glorious SPC.
+data Job = Job
+  { -- | The IO action that comprises the actual action of the job.
+    jobAction :: IO (),
+    -- | The maximum allowed runtime of the job, counting from when
+    -- the job begins executing (not when it is enqueued).
+    jobMaxSeconds :: Int
+  }
+
+-- | A unique identifier of a job that has been enqueued.
+newtype JobId = JobId Int
+  deriving (Eq, Ord, Show)
+
+-- | How a job finished.
+data JobDoneReason
+  = -- | Normal termination.
+    Done
+  | -- | The job was killed because it ran for too long.
+    DoneTimeout
+  | -- | The job was explicitly cancelled, or the worker
+    -- it was running on was stopped.
+    DoneCancelled
+  | -- | The job crashed due to an exception.
+    DoneCrashed
+  deriving (Eq, Ord, Show)
+
+-- | The status of a job.
+data JobStatus
+  = -- | The job is done and this is why.
+    JobDone JobDoneReason
+  | -- | The job is still running.
+    JobRunning
+  | -- | The job is enqueued, but is waiting for an idle worker.
+    JobPending
+  | -- | A job with this ID is not known to this SPC instance.
+    JobUnknown
+  deriving (Eq, Ord, Show)
+
+-- | A worker decides its own human-readable name. This is useful for
+-- debugging.
+type WorkerName = String
+
+-- | Messages sent to workers. These are sent both by SPC and by
+-- processes spawned by the workes.
+data WorkerMsg
+  = -- | New job time
+    MsgStartJob (IO ()) JobId (ReplyChan ThreadId)
+  | -- | Remove worker
+    MsgKill
+
+-- Messages sent to SPC.
+data SPCMsg
+  = -- | Add the job, and reply with the job ID.
+    MsgJobAdd Job (ReplyChan JobId)
+  | -- | Cancel the given job.
+    MsgJobCancel JobId
+  | -- | Immediately reply the status of the job.
+    MsgJobStatus JobId (ReplyChan JobStatus)
+  | -- | Reply when the job is done.
+    MsgJobWait JobId (ReplyChan JobDoneReason)
+  | -- | Some time has passed.
+    MsgTick
+  | -- | Ask if worker exists
+    MsgWorkerExists WorkerName (ReplyChan Bool)
+  | -- | Add a new worker
+    MsgAddWorker WorkerName Worker
+  | -- | Worker finished job
+    MsgJobDone JobId
+  | -- | Crashed
+    MsgJobCrashed JobId
+  | -- | Remove worker (workplace accident)
+    MsgRemoveWorker WorkerName
+
+-- | A handle to the SPC instance.
+data SPC = SPC (Server SPCMsg)
+
+-- | A handle to a worker.
+data Worker = Worker (Server WorkerMsg)
+
+-- | The central state. Must be protected from the bourgeoisie.
+data SPCState = SPCState
+  { spcJobsPending :: [(JobId, Job)],
+    spcJobsRunning :: [(JobId, (WorkerName, Seconds, ThreadId))],
+    spcJobsDone :: [(JobId, JobDoneReason)],
+    spcJobCounter :: JobId,
+    spcWorkers :: [(WorkerName, Worker)],
+    spcWaiting :: [(JobId, (ReplyChan JobDoneReason))]
+  }
+
+-- | The monad in which the main SPC thread runs. This is a state
+-- monad with support for IO.
+newtype SPCM a = SPCM (SPCState -> IO (a, SPCState))
+
+instance Functor SPCM where
+  fmap :: (a -> b) -> SPCM a -> SPCM b
+  fmap = liftM
+
+instance Applicative SPCM where
+  pure x = SPCM $ \state -> pure (x, state)
+  (<*>) = ap
+
+instance Monad SPCM where
+  SPCM m >>= f = SPCM $ \state -> do
+    (x, state') <- m state
+    let SPCM f' = f x
+    f' state'
+
+-- | Retrieve the state.
+get :: SPCM SPCState
+get = SPCM $ \state -> pure (state, state)
+
+-- | Overwrite the state.
+put :: SPCState -> SPCM ()
+put state = SPCM $ \_ -> pure ((), state)
+
+-- | Lift an 'IO' action into 'SPCM'.
+io :: IO a -> SPCM a
+io m = SPCM $ \state -> do
+  x <- m
+  pure (x, state)
+
+-- | Run the SPCM monad.
+runSPCM :: SPCState -> SPCM a -> IO a
+runSPCM state (SPCM f) = fst <$> f state
+
+workerIsIdle :: (WorkerName, Worker) -> SPCM Bool
+workerIsIdle (name, _) = do
+  state <- get
+  pure (all (\(_, (w,_,_)) -> w /= name) (spcJobsRunning state))
+
+checkJobTimeout :: (JobId, (WorkerName, Seconds, ThreadId)) -> SPCM ()
+checkJobTimeout (jobid, (_, deadline, t)) = do
+  now <- io $ getSeconds
+  when (now >= deadline) $ do
+    io $ killThread t
+    jobDone jobid DoneTimeout
+
+checkTimeouts :: SPCM ()
+checkTimeouts = do
+  state <- get
+  mapM_ checkJobTimeout (spcJobsRunning state)
+
+getIdleWorkers :: SPCM [(WorkerName, Worker)]
+getIdleWorkers = do
+  state <- get
+  filterM (workerIsIdle) (spcWorkers state)
+
+schedule :: SPCM ()
+schedule = do
+  state <- get
+  case spcJobsPending state of
+    ((jobid, job) : jobs) -> do
+      workers <- getIdleWorkers
+      case workers of
+        (workerName,worker):_ -> do
+          w <- (\(Worker w) -> pure w) worker
+          threadId <- io $ requestReply w (MsgStartJob (jobAction job) jobid)
+          now <- io $ getSeconds
+          let deadline = now + fromIntegral (jobMaxSeconds job)
+          put $
+            state
+              { spcJobsRunning = (jobid, (workerName, deadline, threadId)) : spcJobsRunning state,
+                spcJobsPending = jobs
+              }
+        _ -> pure ()
+    _ -> pure ()
+
+handleMsg :: Chan SPCMsg -> SPCM ()
+handleMsg c = do
+  checkTimeouts
+  schedule
+  msg <- io $ receive c
+  case msg of
+    MsgJobAdd job rsvp -> do
+      state <- get
+      let JobId jobid = spcJobCounter state
+      put $
+        state
+          { spcJobsPending =
+              (spcJobCounter state, job) : spcJobsPending state,
+            spcJobCounter = JobId $ succ jobid
+          }
+      io $ reply rsvp $ JobId jobid
+    MsgJobStatus jobid rsvp -> do
+      state <- get
+      io $ reply rsvp $ case ( lookup jobid $ spcJobsPending state,
+                               lookup jobid $ spcJobsRunning state,
+                               lookup jobid $ spcJobsDone state
+                             ) of
+        (Just _, _, _) -> JobPending
+        (_, Just _, _) -> JobRunning
+        (_, _, Just r) -> JobDone r
+        _ -> JobUnknown
+    MsgWorkerExists name rsvp -> do
+      state <- get
+      io $ reply rsvp $ case (lookup name $ spcWorkers state) of
+        Just _ -> True
+        _ -> False
+    MsgAddWorker name worker -> do
+      state <- get
+      put $
+        state
+          { spcWorkers =
+              (name, worker) : spcWorkers state
+          }
+    MsgJobDone jobid -> do
+      state <- get
+      case (lookup jobid $ spcJobsRunning state) of
+        Just (_, _, _) -> do
+          jobDone jobid Done
+        Nothing -> pure ()
+    MsgJobWait jobid rsvp -> do
+      state <- get
+      case lookup jobid $ spcJobsDone state of
+        Just reason -> do
+          io $ reply rsvp $ reason
+        Nothing ->
+          put $ state {spcWaiting = (jobid, rsvp) : spcWaiting state}
+    MsgJobCancel jobid -> do
+      state <- get
+      case (lookup jobid $ spcJobsRunning state, lookup jobid $ spcJobsPending state) of
+        (Just (_,_,t), _) -> do
+          io $ killThread t
+          jobDone jobid DoneCancelled
+        (_, Just _) -> do
+          put $
+            state
+              { spcJobsPending = removeAssoc jobid $ spcJobsPending state,
+                spcJobsDone = (jobid, DoneCancelled) : spcJobsDone state
+              }
+        _ -> pure ()
+    MsgJobCrashed jobid -> do
+      state <- get
+      case (lookup jobid $ spcJobsRunning state) of
+        Just (_, _, _) -> do
+          jobDone jobid DoneCrashed
+        Nothing -> pure ()
+    MsgRemoveWorker workerName -> do
+      state <- get
+      case (lookup workerName $ spcWorkers state) of
+        Just (Worker (Server threadId _)) -> do
+          jobs <- pure $ map (\(jobid, (name,_,t)) -> (name,(jobid,t))) $ spcJobsRunning state
+          case (lookup workerName jobs) of
+            Just (jobid,t) -> do
+              io $ killThread t
+              jobDone jobid DoneCancelled
+            Nothing -> pure ()
+
+          state2 <- get
+          put $ state2 {spcWorkers = removeAssoc workerName $ spcWorkers state2}
+          io $ killThread threadId
+        _ -> pure ()
+    _ -> pure ()
+
+startSPC :: IO SPC
+startSPC = do
+  let initial_state =
+        SPCState
+          { spcJobCounter = JobId 0,
+            spcJobsPending = [],
+            spcJobsRunning = [],
+            spcJobsDone = [],
+            spcWorkers = [],
+            spcWaiting = []
+          }
+  c <- spawn $ \c -> runSPCM initial_state $ forever $ handleMsg c
+  void $ spawn $ timer c
+  pure $ SPC c
+  where
+    timer c _ = forever $ do
+      threadDelay 1000000 -- 1 second
+      sendTo c MsgTick
+
+jobDone :: JobId -> JobDoneReason -> SPCM ()
+jobDone jobid reason = do
+  state <- get
+  case lookup jobid $ spcJobsDone state of
+    Just _ ->
+      -- We already know this job is done.
+      pure ()
+    Nothing -> do
+      case (lookup jobid (spcWaiting state)) of
+        Just rsvp -> io $ reply rsvp $ reason
+        _ -> pure ()
+      put $
+        state
+          { spcJobsRunning =
+              removeAssoc jobid $ spcJobsRunning state,
+            spcJobsDone =
+              (jobid, reason) : spcJobsDone state
+          }
+
+-- | Add a job for scheduling.
+jobAdd :: SPC -> Job -> IO JobId
+jobAdd (SPC c) job =
+  requestReply c $ MsgJobAdd job
+
+-- | Asynchronously query the job status.
+jobStatus :: SPC -> JobId -> IO JobStatus
+jobStatus (SPC c) jobid =
+  requestReply c $ MsgJobStatus jobid
+
+-- | Synchronously block until job is done and return the reason.
+jobWait :: SPC -> JobId -> IO JobDoneReason
+jobWait (SPC c) jobid =
+  requestReply c $ MsgJobWait jobid
+
+-- | Asynchronously cancel a job.
+jobCancel :: SPC -> JobId -> IO ()
+jobCancel (SPC c) jobid =
+  sendTo c $ MsgJobCancel jobid
+
+-- debugState :: SPC -> IO SPCState
+-- debugState (SPC c) =
+--   requestReply c $ MsgDebug
+
+-- | Add a new worker with this name. Fails with 'Left' if a worker
+-- with that name already exists.
+workerAdd :: SPC -> WorkerName -> IO (Either String Worker)
+workerAdd (SPC c) name = do
+  exists <- requestReply c $ MsgWorkerExists name
+  if exists
+    then pure $ Left "Worker with given name already exist"
+  else do
+    worker <- workerSpawn name c
+    sendTo c $ MsgAddWorker name worker
+    pure $ Right worker
+
+workerSpawn :: WorkerName -> (Server SPCMsg)  -> IO Worker
+workerSpawn name c = do
+  w <- spawn $ workerLoop name c
+  pure $ Worker w
+
+workerLoop :: WorkerName -> (Server SPCMsg) -> Chan WorkerMsg -> IO ()
+workerLoop name c m = forever $ do
+  msg <- receive m
+  case msg of
+    -- stuff happening here
+    MsgStartJob action jobid rsvp -> do
+      t <- forkIO $ do
+        let doJob = do
+              action
+              sendTo c $ MsgJobDone jobid
+            onException :: SomeException -> IO ()
+            onException _ =
+              sendTo c $ MsgJobCrashed jobid
+        doJob `catch` onException
+      reply rsvp t
+    MsgKill -> sendTo c $ MsgRemoveWorker name
+
+-- | Shut down a running worker. No effect if the worker is already
+-- terminated.
+workerStop :: Worker -> IO ()
+workerStop (Worker w) = sendTo w MsgKill

a6/src/SPC_Tests.hs

@@ -0,0 +1,180 @@
+module SPC_Tests (tests) where
+
+import Control.Concurrent (threadDelay)
+import Data.IORef
+import SPC
+import Test.Tasty (TestTree, localOption, mkTimeout, testGroup)
+import Test.Tasty.HUnit (testCase, (@?=))
+import Data.Either (isRight)
+
+tests :: TestTree
+tests =
+  localOption (mkTimeout 3000000) $
+    testGroup
+      "SPC (core)"
+      [
+        testCase "workerAdd" $ do
+          spc <- startSPC
+
+          w <- workerAdd spc "R2-D2"
+          isRight w @?= True,
+        testCase "workerAdd (2)" $ do
+          spc <- startSPC
+
+          w1 <- workerAdd spc "MSE-6"
+          isRight w1 @?= True
+
+          w2 <- workerAdd spc "GNK"
+          isRight w2 @?= True,
+        testCase "workerAdd (fail)" $ do
+          spc <- startSPC
+
+          w1 <- workerAdd spc "BD-1"
+          isRight w1 @?= True
+
+          w2 <- workerAdd spc "BD-1"
+          isRight w2 @?= False,
+        testCase "Running a job" $ do
+          ref <- newIORef False
+          spc <- startSPC
+
+          w <- workerAdd spc "R5-D4"
+          isRight w @?= True
+
+          j <- jobAdd spc $ Job (writeIORef ref True) 1
+          r <- jobWait spc j
+          r @?= Done
+
+          x <- readIORef ref
+          x @?= True,
+        testCase "Adding job before worker" $ do
+          ref <- newIORef False
+          spc <- startSPC
+
+          j <- jobAdd spc $ Job (writeIORef ref True) 1
+
+          w <- workerAdd spc "R5-D4"
+          isRight w @?= True
+
+          r <- jobWait spc j
+          r @?= Done
+
+          x <- readIORef ref
+          x @?= True,
+        testCase "Running two jobs" $ do
+          ref <- newIORef (0::Int)
+          spc <- startSPC
+
+          w <- workerAdd spc "K-2SO"
+          isRight w @?= True
+
+          j1 <- jobAdd spc $ Job (writeIORef ref 1) 1
+          r1 <- jobWait spc j1
+          r1 @?= Done
+
+          x1 <- readIORef ref
+          x1 @?= 1
+
+          j2 <- jobAdd spc $ Job (writeIORef ref 2) 1
+          r2 <- jobWait spc j2
+          r2 @?= Done
+
+          x2 <- readIORef ref
+          x2 @?= 2,
+        testCase "Canceling job (pending)" $ do
+          spc <- startSPC
+          j <- jobAdd spc $ Job (pure ()) 1
+          jobCancel spc j
+          r <- jobStatus spc j
+          r @?= JobDone DoneCancelled,
+        testCase "Canceling job (running)" $ do
+          spc <- startSPC
+
+          w <- workerAdd spc "IG-88"
+          isRight w @?= True
+
+          j <- jobAdd spc $ Job (threadDelay 2000000) 2
+          jobCancel spc j
+          r <- jobStatus spc j
+          r @?= JobDone DoneCancelled,
+        testCase "Canceling job (running) (new job)" $ do
+          ref <- newIORef False
+          spc <- startSPC
+
+          w <- workerAdd spc "C-3PO"
+          isRight w @?= True
+
+          j1 <- jobAdd spc $ Job (threadDelay 2000000) 2
+          jobCancel spc j1
+          r1 <- jobStatus spc j1
+          r1 @?= JobDone DoneCancelled
+
+          -- job has been cancelled. Starting new job
+          j2 <- jobAdd spc $ Job (writeIORef ref True) 1
+          r2 <- jobWait spc j2
+          r2 @?= Done
+
+          x <- readIORef ref
+          x @?= True,
+        testCase "Timeout" $ do
+          spc <- startSPC
+
+          w <- workerAdd spc "L3-37"
+          isRight w @?= True
+
+          j <- jobAdd spc $ Job (threadDelay 2000000) 1
+          r <- jobWait spc j
+
+          r @?= DoneTimeout,
+        testCase "Timeout (2 jobs)" $ do
+          ref <- newIORef False
+          spc <- startSPC
+
+          w <- workerAdd spc "General Kalani"
+          isRight w @?= True
+
+          j1 <- jobAdd spc $ Job (threadDelay 2000000) 1
+          j2 <- jobAdd spc $ Job (writeIORef ref True) 1
+          r1 <- jobWait spc j1
+          r1 @?= DoneTimeout
+
+          r2 <- jobWait spc j2
+          r2 @?= Done
+
+          x <- readIORef ref
+          x @?= True,
+        testCase "Crash" $ do
+          ref <- newIORef False
+          spc <- startSPC
+          w <- workerAdd spc "C1-10P"
+          isRight w @?= True
+
+          j1 <- jobAdd spc $ Job (error "boom") 1
+          r1 <- jobWait spc j1
+          r1 @?= DoneCrashed
+
+          -- Ensure new jobs can still work.
+          j2 <- jobAdd spc $ Job (writeIORef ref True) 1
+          r2 <- jobWait spc j2
+          r2 @?= Done
+          x <- readIORef ref
+          x @?= True,
+        testCase "Remove worker" $ do
+          spc <- startSPC
+          w1 <- workerAdd spc "D-O"
+          isRight w1 @?= True
+          case w1 of
+            (Right worker) -> do
+              w2 <- workerAdd spc "D-O" -- Can't make another worker with same name yet
+              isRight w2 @?= False
+
+              j <- jobAdd spc $ Job (threadDelay 1000000) 1
+              workerStop worker
+              threadDelay 100
+              r <- jobStatus spc j
+              r @?= JobDone DoneCancelled
+
+              w3 <- workerAdd spc "D-O" -- But we can make one now
+              isRight w3 @?= True
+            _ -> False @?= True
+      ]