🤐 Zip

.gitignore

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

a4/src/APL/InterpIO.hs

@@ -78,7 +78,12 @@ runEvalIO evalm = do
       case result of
         Right s -> case (lookup key s) of
           Just val -> runEvalIO' r db $ k val
-          Nothing ->  pure $ Left "Cannot find key :)"
+          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
@@ -88,4 +93,20 @@ runEvalIO evalm = do
           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

@@ -20,7 +20,16 @@ runEval = runEval' envEmpty stateInitial
     runEval' r s (Free (KvGetOp key k)) =
       case (lookup key s) of
         Just val -> runEval' r s $ k val
-        Nothing -> ([], Left "Cannot find key :)")
+        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

@@ -79,7 +79,7 @@ pureTests =
         eval' (TryCatch (Div (CstInt 1) (CstInt 0)) (CstInt 1))
           @?= ([], Right (ValInt 1)),
       --
-      testCase "TryCatch catch1" $
+      testCase "TryCatch catch2" $
         eval' (TryCatch (Div (CstInt 1) (CstInt 0)) (Div (CstInt 1) (CstInt 0)))
           @?= ([], Left "Division by zero"),
       --
@@ -97,7 +97,47 @@ pureTests =
       --
       testCase "KvGetOp fail" $
         eval' (KvGet (CstInt 1))
-          @?= ([], Left "Cannot find key :)")
+          @?= ([], 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
@@ -130,7 +170,23 @@ ioTests =
           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),
@@ -139,11 +195,79 @@ ioTests =
         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 <- evalIO' (KvGet (CstInt 1))
+        (_, r) <-
-        r @?= Left "Cannot find key :)"
+          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

@@ -79,6 +79,7 @@ data EvalOp a
   | 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
@@ -89,6 +90,7 @@ instance Functor EvalOp where
   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
 
@@ -132,4 +134,4 @@ evalKvPut :: Val -> Val -> EvalM ()
 evalKvPut v1 v2 = Free $ KvPutOp v1 v2 $ pure ()
 
 transaction :: EvalM () -> EvalM ()
-transaction = error "TODO"
+transaction v = Free $ TransactionOp v $ pure ()

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
+      ]