eval cons

src/Gyehoek/CPS/Eval.hs

@@ -12,7 +12,7 @@ module Gyehoek.CPS.Eval
 import Gyehoek.CPS.Syntax hiding (Hob(..), Obj(..), cont)
 import Gyehoek.Sexp qualified as S
 import Control.Lens hiding (assign)
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, isJust)
 import Text.Show.Functions ()
 import qualified Data.HashMap.Strict as H
 import Gyehoek.Prelude hiding (assign)
@@ -116,6 +116,13 @@ data Mutability
 wrong :: Text -> M Answer a
 wrong s = ContT \_ -> pure . AnswerError . EvalError $ s
 
+orWrong
+  :: Getting (First a) s a
+  -> s -> Text -> (a -> M Answer c) -> M Answer c
+orWrong p s msg f = case getFirst . getConst $ p (Const . First . Just) s of
+  Nothing -> wrong msg
+  Just x -> f x
+
 bind :: Name -> Loc -> Env
 bind k = MkEnv . H.singleton k
 
@@ -139,9 +146,9 @@ data E
   | EUndefined
   | EUnspecified
   | ENull
-  | EPair Loc Loc Mutability
-  | EVec (List Loc) Mutability
-  | EString (List Loc) Mutability
+  | EPair Mutability Loc Loc
+  | EVec Mutability (List Loc)
+  | EString Mutability (List Loc)
   | EProcedure Procedure
   deriving stock (Show, Generic)
 
@@ -159,24 +166,30 @@ eGrammar st = S.partialOsi (const . Left $ mempty) go
       EUndefined -> S.Unreadable "#<undefined>"
       EUnspecified -> S.Unreadable "#<unspecified>"
       ENull -> S.List []
-      EPair car cdr _mut -> S.DotList [gofetch car] (gofetch cdr)
-      EVec xs _mut -> S.Vector . fmap gofetch $ xs
-      EString xs _mut -> S.String _
+      EPair _mut car cdr -> S.DotList [gofetch car] (gofetch cdr)
+      EVec _mut xs -> S.Vector . fmap gofetch $ xs
+      EString _mut xs -> S.String _
 
 data DynPoints = MkDynPoints
   deriving (Generic, Data)
 
 
 
+truthy :: E -> Bool
+truthy (EBool False) = False
+truthy _ = True
+
+
+
 evalVal :: Env -> Val -> M Answer E
 
 evalVal g (ValVar x) = var g x >>= fetch
 
-evalVal g (ValImm imm) = pure case imm of
-  ImmLabel l -> error [i|#{l}|]
-  ImmInt n -> EInt n
-  ImmBool b -> EBool b
-  ImmUndefined -> EUndefined
+evalVal g (ValImm imm) = case imm of
+  ImmLabel (MkLabel l) -> var g l >>= fetch
+  ImmInt n -> pure $ EInt n
+  ImmBool b -> pure $ EBool b
+  ImmUndefined -> pure EUndefined
 
 evalKexp :: Env -> Kexp -> M Answer E
 evalKexp g (KexpVar x) = var g x >>= fetch
@@ -218,6 +231,13 @@ eval g dps (ExpPrim p k) = do
     EProcedure fp -> fp p' dps
     _ -> wrong [i|prim(#{p})의 계속을 나쁘다|]
 
+eval g dps (ExpIf c t f) = do
+  c' <- evalVal g c
+  let b = if truthy c' then t else f
+  var g b >>= fetch >>= \case
+    EProcedure fp -> fp [] dps
+    _ -> wrong [i|if의 계속을 나쁘다|]
+
 eval g dps e = error [i|unimplemented #{e}|]
 
 evalPrim :: Env -> Prim E -> M Answer (List E)
@@ -226,11 +246,20 @@ evalPrim g = \case
   PrimMul x y -> arith2 (*) x y
   PrimSub x y -> arith2 (-) x y
   PrimDiv x y -> arith2 div x y
+  PrimZeroP x -> pure [EBool . isJust $ x ^? #EInt . only 0]
+  PrimCons x y -> do
+    (x',y') <- traverseOf both new' (x,y)
+    pure [EPair Mut x' y']
+  PrimCar p -> cr p _2
+  PrimCdr p -> cr p _3
   PrimValues xs -> pure xs
   p -> wrong [i|prim(#{p})은 벌써 나지 않다|]
   where
     arith2 f (EInt x) (EInt y) = pure [EInt $ f x y]
     arith2 f x y = wrong [i|나쁜 인자: #{x}, #{y}|]
+    cr p l = orWrong (#_EPair . l) p
+      [i|car/cdr는 pair을 받지 않다|]
+      (fmap (:[]) . fetch)