eval agian

src/Gyehoek/CPS/Eval.hs

@@ -9,24 +9,27 @@ module Gyehoek.CPS.Eval
   , eGrammar
   ) where
 
-import Gyehoek.CPS.Syntax hiding (Hob(..), Obj(..))
+import Gyehoek.CPS.Syntax hiding (Hob(..), Obj(..), cont)
 import Gyehoek.Sexp qualified as S
-import Control.Lens
+import Control.Lens hiding (assign)
 import Data.Maybe (fromMaybe)
 import Text.Show.Functions ()
 import qualified Data.HashMap.Strict as H
-import Gyehoek.Prelude
+import Gyehoek.Prelude hiding (assign)
 import Debug.Pretty.Simple
 import Gyehoek.Jalmot
-import Control.Monad.Cont qualified as Cont
+import Control.Monad.Cont
 import Gyehoek.Sexp qualified as S
 import GHC.Generics (Generically(..))
 import Gyehoek.Sexp ((:-)(..))
-import Data.List (nub, mapAccumR)
+import Data.List (nub, mapAccumR, compareLength)
 import Data.HashSet.Lens (setOf)
 import Data.IntMap.Strict (IntMap)
 import Data.IntMap.Strict qualified as IM
 import Data.Monoid
+import Control.Monad.State
+import Data.Traversable (for)
+import Data.Foldable (traverse_)
 
 
 newtype Loc = MkLoc { getLoc :: Int }
@@ -37,11 +40,17 @@ data Store = MkStore
   { nextLoc :: Loc
   , heap :: IntMap E
   }
-  deriving stock (Show, Generic, Data)
+  deriving stock (Show, Generic)
+
+type instance Index Store = Loc
+type instance IxValue Store = E
+
+instance Ixed Store where ix (MkLoc j) = #heap . ix j
+instance At Store where at (MkLoc j) = #heap . at j
 
 emptyStore :: Store
 emptyStore = MkStore
-  { nextLoc = 0
+  { nextLoc = MkLoc 0
   , heap = mempty
   }
 
@@ -67,57 +76,45 @@ update (MkLoc loc) v = #heap %~ IM.alter f loc
 updates :: Foldable f => f (Loc, E) -> Store -> Store
 updates = alaf Endo foldMap (uncurry update)
 
-fetch :: Loc -> Store -> E
+fetch :: Loc -> M r E
-fetch (MkLoc loc) st = st ^?! #heap . ix loc
+fetch (MkLoc loc) = gets (^?! #heap . ix loc)
 
-new :: Store -> (Store, Loc)
+new :: M r Loc
-new st = (st & #nextLoc %~ succ, st.nextLoc)
+new = state \st -> (st.nextLoc, st & #nextLoc %~ succ)
 
-new' :: E -> Store -> (Store, Loc)
+new' :: E -> M r Loc
-new' e st = (update l e st', l)
+new' e = state \st ->
-  where
+  ( st.nextLoc
-    (st',l) = new st
+  , st & #nextLoc %~ succ & at st.nextLoc ?~ e
+  )
 
-news' :: Traversable t => t E -> Store -> (Store, Loc)
+defines :: Traversable t => t (Name, E) -> M Answer Env
-news' es st = mapAccumR _ st es
+defines = alaf Ap foldMap \(name,e) -> do
-  where
+  l <- new' e
-    (st',l) = new st
+  pure $ bind name l
 
-var :: HasCallStack => Env -> Name -> Loc
+var :: HasCallStack => Env -> Name -> M Answer Loc
-var g x = g ^?! ix x
+var g x = case g ^. at x of
+  Just l -> pure l
+  Nothing -> wrong [i|unbound variable #{x}|]
 
 type CmdCont = Store -> Answer
 type ExpCont = List E -> CmdCont
 
+type M r = ContT r (State Store)
+
 data Answer
-  = AnswerValues Store (List E)
+  = AnswerValues (List E)
-  | AnswerError Text
+  | AnswerError AJalmot
-  deriving (Show, Generic, Data)
+  deriving (Show, Generic)
 
 data Mutability
   = Mut
   | NoMut
   deriving (Show, Generic, Data, Eq)
 
-wrong :: Text -> CmdCont
+wrong :: Text -> M Answer a
-wrong = const . AnswerError
+wrong s = ContT \_ -> pure . AnswerError . EvalError $ s
-
-single :: (E -> CmdCont) -> ExpCont
-single k = \case
-  [x] -> k x
-  _ -> wrong "wrong number of return values"
-
-send :: E -> ExpCont -> CmdCont
-send e k = k [e]
-
--- | Continue with the value located at a given 'Loc'.
-hold :: Loc -> ExpCont -> CmdCont
-hold loc k st = send (fetch loc st) k st
-
-tievals :: Traversable t => t E -> (t Loc -> CmdCont) -> CmdCont
-tievals es f st0 = f ls stn
-  where
-    (stn,ls) = mapAccumR (flip new') st0 es
 
 bind :: Name -> Loc -> Env
 bind k = MkEnv . H.singleton k
@@ -125,13 +122,19 @@ bind k = MkEnv . H.singleton k
 extends :: Foldable f => f (Name, Loc) -> Env -> Env
 extends xs g = g <> foldMap (uncurry bind) xs
 
+assign :: Loc -> E -> M Answer ()
+assign l e = do
+  use (at l) >>= \case
+    Just _ -> at l ?= e
+    Nothing -> wrong [i|#{e}에서 #{l}이라는 주소는 없다|]
+
 
 
 -- | The denotation of an expressed value.
 data E
   = ESymbol Text
   | ECharacter Char
-  | EInteger Int
+  | EInt Int
   | EBool Bool
   | EUndefined
   | EUnspecified
@@ -139,19 +142,19 @@ data E
   | EPair Loc Loc Mutability
   | EVec (List Loc) Mutability
   | EString (List Loc) Mutability
-  | EProcedure Loc Procedure
+  | EProcedure Procedure
-  deriving stock (Show, Generic, Data)
+  deriving stock (Show, Generic)
 
-type Procedure = List E -> DynPoints -> ExpCont -> CmdCont
+type Procedure = List E -> DynPoints -> M Answer (List E)
 
 eGrammar :: Store -> S.DatumGrammar E
 eGrammar st = S.partialOsi (const . Left $ mempty) go
   where
-    gofetch x = go $ fetch x st
+    gofetch x = go $ st ^?! ix x
     go = \case
       ESymbol s -> S.Symbol s
       ECharacter c -> S.Character c
-      EInteger n -> S.Number (fromIntegral n)
+      EInt n -> S.Number (fromIntegral n)
       EBool b -> S.Boolean b
       EUndefined -> S.Unreadable "#<undefined>"
       EUnspecified -> S.Unreadable "#<unspecified>"
@@ -165,88 +168,73 @@ data DynPoints = MkDynPoints
 
 
 
--- 뻘짓이어라
+evalVal :: Env -> Val -> M Answer E
-telescope
-  :: Traversable t
-  => (a -> (b -> r) -> r)
-  -> t a -> (t b -> r) -> r
-telescope f = Cont.runCont . traverse (Cont.cont . f)
 
-
+evalVal g (ValVar x) = var g x >>= fetch
 
-procedure :: Env -> Procedure -> (E -> CmdCont) -> CmdCont
+evalVal g (ValImm imm) = pure case imm of
-procedure = _
+  ImmInt n -> EInt n
+  ImmBool b -> EBool b
+  ImmUndefined -> EUndefined
 
-evalVal :: Env -> Val -> ExpCont -> CmdCont
+evalKexp :: Env -> Kexp -> M Answer E
-evalVal g (ValVar x) k = hold (var g x) $ single \case
+evalKexp g (KexpVar x) = var g x >>= fetch
-  EUndefined -> wrong "undefined variable"
+evalKexp g (KexpKappa kap) = evalAbs g (AbsKappa kap)
-  e -> send e k
 
-evalVal1 :: Env -> Val -> (E -> CmdCont) -> CmdCont
+evalAbs :: Env -> Abs -> M Answer E
-evalVal1 g v k = evalVal g v (single k)
+evalAbs g (MkAbs formals ktail e) = pure . EProcedure $ \xs dps ->
-
-evalKexp :: Env -> Kexp -> ExpCont -> CmdCont
-
-evalKexp g (KexpVar x) k = evalVal g (ValVar x) k
-
-evalKexp g (KexpKappa kap) k = evalAbs g (AbsKappa kap) k
-
-evalAbs :: Env -> Abs -> ExpCont -> CmdCont
-evalAbs g (MkAbs formals mtail e) k st = send ab k st'
-  where
-    (st',l) = new' EUnspecified st
-    ab = EProcedure l \args dps k' ->
-      tievals args \argLocs ->
-        let argEnv = zip (formals ++ foldMap (:[]) mtail) argLocs
-            g' = g <> foldMap (uncurry bind) argEnv
-        in eval g' dps e k'
-
-eval :: Env -> DynPoints -> Exp -> ExpCont -> CmdCont
-
-eval g dps (ExpLetRec bs e) k = \st0 ->
   let
-    rhss = bs ^.. each . _2
+    formals' = formals ++ foldMap (:[]) ktail
-    (st',ls) = mapAccumR (\st _ -> new st) st0 bs
+    lformals = length formals'
-    g' = g & extends (zip (bs ^.. each . _1) ls)
+    lxs = length xs
-    f :: List E -> CmdCont
+  in if lformals /= lxs
-    f = \rhss' -> eval g' dps e k . updates (zip ls rhss')
+  then wrong [i|함수는 #{lformals}개의 인자를 필요로 하는데 #{lxs}개 받았다.|]
-  in telescope (\ab -> evalAbs g' ab . single) rhss f st'
+  else do
+    ls <- xs & traverse new'
+    let g' = g & extends (zip formals' ls)
+    eval g' dps e
 
-eval g dps (ExpJump f xs ktail) k =
+eval :: Env -> DynPoints -> Exp -> M Answer (List E)
-  telescope (evalVal1 g) (f:|xs) \(f':|xs') ->
-    telescope (\ke -> evalKexp g ke . single) (ktail ^.. each) \ktail' ->
-      case f' of
-        EProcedure _loc fp -> fp xs' dps k
-        _ -> wrong "bad procedure"
 
-eval g dps (ExpContinue f xs) k =
+eval g dps (ExpJump f xs ktail) = do
-  telescope (evalVal1 g) (f:|xs) \(f':|xs') ->
+  f' <- evalVal g f
-    case f' of
+  xs' <- traverse (evalVal g) xs
-      EProcedure _loc fp -> fp xs' dps k
+  ktail' <- traverse (evalKexp g) (ktail ^.. _Just)
-      _ -> wrong "bad procedure"
+  case f' of
+    EProcedure p -> p (xs' ++ ktail') dps
+    _ -> wrong "bad procedure"
 
-eval g dps (ExpApply f xs ktail) k =
+eval g dps (ExpLetRec bs e) = do
-  telescope (evalVal1 g) (f:|xs) \(f':|xs') ->
+  ls <- for bs . const $ new' EUndefined
-    evalKexp g ktail . single $ \ktail' ->
+  let g' = g & extends (zip (bs ^.. each . _1) ls)
-      case f' of
+  bs' <- forOf (each . _2) bs (evalAbs g')
-        EProcedure _loc fp -> fp (xs' ++ [ktail']) dps k
+  traverse_ (uncurry assign) $ zip ls (bs' ^.. each . _2)
-        _ -> wrong "bad procedure"
+  eval g' dps e
+
+eval g dps e = error [i|unimplemented #{e}|]
 
 
 
-prim_halt :: Procedure
-prim_halt xs _dps _k st = AnswerValues st xs
-
-setup :: (Env -> CmdCont) -> CmdCont
-setup k = tievals (defs ^.. each) _
-  where
-    defs :: HashMap Name E
-    defs =
-      [ ("halt", EProcedure _ prim_halt)
-      ]
-
 evalExp :: Jalmot :> es => Exp -> Eff es _
 evalExp e = _
 
-evalProgram :: Jalmot :> es => Program -> Eff es (List E)
+evalProgram :: Jalmot :> es => Program -> Eff es (List S.Datum)
-evalProgram (MkProgram lam) = _
+evalProgram (MkProgram lam) = case run (pure . AnswerValues) of
+  (AnswerError jm, _) -> throwError jm
+  (AnswerValues vs, st) -> traverse (S.toDatum $ eGrammar st) vs
+  where
+    run f = (`runState` emptyStore) . (`runContT` f) $ do
+      g <- setup
+      eval g MkDynPoints (ExpLetRec
+        [("_start",AbsLambda lam)]
+        (ExpApply (ValVar "_start") [] (KexpVar "halt")))
+
+
+
+setup :: M Answer Env
+setup = defines @List
+  [ ("halt", EProcedure prim_halt)
+  ]
+
+prim_halt :: Procedure
+prim_halt xs _dps = ContT \_ -> pure $ AnswerValues xs

src/Gyehoek/Jalmot.hs

@@ -31,6 +31,7 @@ data AJalmot
   = ReaderError (ParseErrorBundle Text Void)
   | GrammarError (Grammar.ErrorMessage Ann)
   | VMError Text
+  | EvalError Text
   deriving (Show, Generic, Data)
 
 data AJalmotCS = MkAJalmotCS !CallStack !AJalmot
@@ -66,6 +67,7 @@ instance Exception AJalmot where
         & layoutPretty defaultLayoutOptions
         & renderString
     VMError err -> [i|#{err}|]
+    EvalError err -> [i|#{err}|]
 
 instance Exception AJalmotCS where
   backtraceDesired = const False