✨

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,73 @@
+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
+
+-- Replace with your 'eval' from your solution to assignment 2.
+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

a4/src/APL/InterpIO.hs

@@ -0,0 +1,70 @@
+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)) = error "TODO in Task 3"
+    runEvalIO' r db (Free (StatePutOp s m)) = error "TODO in Task 3"
+    runEvalIO' r db (Free (PrintOp p m)) = do
+      putStrLn p
+      runEvalIO' r db m
+    runEvalIO' _ _ (Free (ErrorOp e)) = pure $ Left e

a4/src/APL/InterpPure.hs

@@ -0,0 +1,16 @@
+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' _ _ (Free (ErrorOp e)) = ([], Left e)

a4/src/APL/Interp_Tests.hs

@@ -0,0 +1,95 @@
+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")
+    ]
+
+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 ())
+        -- NOTE: This test will give a runtime error unless you replace the
+        -- version of `eval` in `APL.Eval` with a complete version that supports
+        -- `Print`-expressions. Uncomment at your own risk.
+        -- 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)
+    ]

a4/src/APL/Monad.hs

@@ -0,0 +1,129 @@
+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
+
+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
+
+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 = error "TODO"
+
+evalKvGet :: Val -> EvalM Val
+evalKvGet = error "TODO"
+
+evalKvPut :: Val -> Val -> EvalM ()
+evalKvPut = error "TODO"
+
+transaction :: EvalM () -> EvalM ()
+transaction = error "TODO"

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