diff --git a/src/Gyehoek/CPS/Eval.hs b/src/Gyehoek/CPS/Eval.hs index 92f69ee..d7df320 100644 --- a/src/Gyehoek/CPS/Eval.hs +++ b/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 "#" EUnspecified -> S.Unreadable "#" 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)