Yippie

3/Assignment.hs

@@ -1,25 +1,48 @@
-{-# Language LambdaCase #-}
+{-# Language LambdaCase, Strict #-}
 module Assignment where
 
 import Chi
+import Control.Monad
+import Control.Monad.Identity
+import Debug.Trace (trace)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HM
+import Data.Functor ( (<&>) )
+import Control.Monad.Identity (Identity(runIdentity))
 
 subst :: Variable -> Exp -> Exp -> Exp
 subst var e = \case
   Apply e1 e2 -> Apply (subst var e e1) (subst var e e2)
-  Lambda x e' -> Lambda x $ if var /= x then (subst var e e') else e'
+  Lambda x e' -> Lambda x $ if var /= x then subst var e e' else e'
   Var x -> if var == x then e else Var x
   Const c es -> Const c $ map (subst var e) es
-  Rec x e' -> Rec x $ if var /= x then (subst var e e') else e' 
-  Case e' branches -> Case (subst var e e') $ map substBr branches
+  Rec x e' -> Rec x $ if var /= x then subst var e e' else e'
+  Case e' bs -> Case (subst var e e') $ map substBr bs
     where
       substBr :: Br -> Br
-      substBr (Branch c vs e') = Branch c vs $ if var `notElem` vs then (subst var e e') else e'
+      substBr (Branch c vs e') = Branch c vs $ if var `notElem` vs then subst var e e' else e'
 
-eval' :: Exp -> Reader (Map Variable Exp) Exp
-eval' = undefined
+lookupBranch :: Constructor -> [Br] -> Identity ([Variable], Exp)
+lookupBranch c [] = error "No matching branch"
+lookupBranch c ((Branch c' bs e):brs) = if c == c' then pure (bs,e) else lookupBranch c brs
+
+eval' :: Exp -> Identity Exp
+eval' = \case
+  e@(Apply e1 e2) -> eval' e1 >>= \case
+    Lambda x e' -> eval' e2 >>= eval' . flip (subst x) e'
+    _ -> error $ "Function was not function in evaluation: " <> show e
+  Const c es -> mapM eval' es <&> Const c
+  Rec x e -> eval' $ subst x (Rec x e) e
+  Case e bs -> eval' e >>= \case
+    Const c vs -> lookupBranch c bs >>= \case
+      (xs,e') ->
+        if length vs /= length xs then error "Not the same amount of arguments in case" else
+        eval' $ foldr (uncurry subst) e' (zip xs vs)
+    e -> error $ "Non const in case: " <> show e
+  x -> pure x
 
 eval :: Exp -> Exp
-eval = undefined
+eval = runIdentity . eval'
 
 main :: IO ()
 main = getLine >>= print . eval . parse