fix runtime parsing lol

src/Gyehoek/CPS/Eval.hs

@@ -9,37 +9,57 @@ 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)
+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 }
   deriving stock (Generic, Data)
-  deriving newtype (Show, Eq, Ord)
+  deriving newtype (Show, Eq, Ord, Enum)
 
 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 = MkLoc 0
+  , heap = mempty
+  }
 
 newtype Env = MkEnv { getEnv :: HashMap Name Loc }
   deriving stock (Show, Generic, Data)
+  deriving newtype (Semigroup, Monoid)
+
+emptyEnv :: Env
+emptyEnv = mempty
 
 type instance Index Env = Name
 type instance IxValue Env = Loc
@@ -53,42 +73,60 @@ update (MkLoc loc) v = #heap %~ IM.alter f loc
     f (Just _) = Just v
     f Nothing = error "segfault lol"
 
-fetch :: Loc -> Store -> E
-fetch (MkLoc loc) st = st ^?! #heap . ix loc
+updates :: Foldable f => f (Loc, E) -> Store -> Store
+updates = alaf Endo foldMap (uncurry update)
 
-new :: Store -> Loc
-new = _
+fetch :: Loc -> M r E
+fetch (MkLoc loc) = gets (^?! #heap . ix loc)
 
-var :: HasCallStack => Env -> Name -> Loc
-var g x = g ^?! ix x
+new :: M r Loc
+new = state \st -> (st.nextLoc, st & #nextLoc %~ succ)
+
+new' :: E -> M r Loc
+new' e = state \st ->
+  ( st.nextLoc
+  , st & #nextLoc %~ succ & at st.nextLoc ?~ e
+  )
+
+defines :: Traversable t => t (Name, E) -> M Answer Env
+defines = alaf Ap foldMap \(name,e) -> do
+  l <- new' e
+  pure $ bind name l
+
+var :: HasCallStack => Env -> Name -> M Answer Loc
+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 (List E)
-  | AnswerError Text
-  deriving (Show, Generic, Data)
+  | AnswerError AJalmot
+  deriving (Show, Generic)
 
 data Mutability
   = Mut
   | NoMut
   deriving (Show, Generic, Data, Eq)
 
-wrong :: Text -> CmdCont
-wrong = const . AnswerError
+wrong :: Text -> M Answer a
+wrong s = ContT \_ -> pure . AnswerError . EvalError $ s
 
-single :: (E -> CmdCont) -> ExpCont
-single k = \case
-  [x] -> k x
-  _ -> wrong "wrong number of return values"
+bind :: Name -> Loc -> Env
+bind k = MkEnv . H.singleton k
 
-send :: E -> ExpCont -> CmdCont
-send e k = k [e]
+extends :: Foldable f => f (Name, Loc) -> Env -> Env
+extends xs g = g <> foldMap (uncurry bind) xs
 
--- | Continue with the value located at a given 'Loc'.
-hold :: Loc -> ExpCont -> CmdCont
-hold loc k st = send (fetch loc st) k st
+assign :: Loc -> E -> M Answer ()
+assign l e = do
+  use (at l) >>= \case
+    Just _ -> at l ?= e
+    Nothing -> wrong [i|#{e}에서 #{l}이라는 주소는 없다|]
 
 
 
@@ -96,7 +134,7 @@ hold loc k st = send (fetch loc st) k st
 data E
   = ESymbol Text
   | ECharacter Char
-  | EInteger Int
+  | EInt Int
   | EBool Bool
   | EUndefined
   | EUnspecified
@@ -104,17 +142,19 @@ data E
   | EPair Loc Loc Mutability
   | EVec (List Loc) Mutability
   | EString (List Loc) Mutability
-  | EProcedure Loc (List E -> DynPoints -> ExpCont -> CmdCont)
-  deriving stock (Show, Generic, Data)
+  | EProcedure Procedure
+  deriving stock (Show, Generic)
+
+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>"
@@ -128,47 +168,92 @@ data DynPoints = MkDynPoints
 
 
 
--- 뻘짓이어라
-telescope
-  :: Traversable t
-  => (a -> (b -> r) -> r)
-  -> t a -> (t b -> r) -> r
-telescope f = Cont.runCont . traverse (Cont.cont . f)
+evalVal :: Env -> Val -> M Answer E
 
-
+evalVal g (ValVar x) = var g x >>= fetch
 
-evalVal :: Env -> Val -> ExpCont -> CmdCont
-evalVal g (ValVar x) k = hold (var g x) $ single \case
-  EUndefined -> wrong "undefined variable"
-  e -> send e k
+evalVal g (ValImm imm) = pure case imm of
+  ImmLabel l -> error [i|#{l}|]
+  ImmInt n -> EInt n
+  ImmBool b -> EBool b
+  ImmUndefined -> EUndefined
 
-evalVal1 :: Env -> Val -> (E -> CmdCont) -> CmdCont
-evalVal1 g v k = evalVal g v (single k)
+evalKexp :: Env -> Kexp -> M Answer E
+evalKexp g (KexpVar x) = var g x >>= fetch
+evalKexp g (KexpKappa kap) = evalAbs g (AbsKappa kap)
 
-evalKexp :: Env -> Kexp -> ExpCont -> CmdCont
+evalAbs :: Env -> Abs -> M Answer E
+evalAbs g (MkAbs formals ktail e) = pure . EProcedure $ \xs dps ->
+  let
+    formals' = formals ++ foldMap (:[]) ktail
+    lformals = length formals'
+    lxs = length xs
+  in if lformals /= lxs
+  then wrong [i|함수는 #{lformals}개의 인자를 필요로 하는데 #{lxs}개 받았다.|]
+  else do
+    ls <- xs & traverse new'
+    let g' = g & extends (zip formals' ls)
+    eval g' dps e
 
-evalKexp g (KexpVar x) k = evalVal g (ValVar x) k
+eval :: Env -> DynPoints -> Exp -> M Answer (List E)
 
-evalKexp g (KexpKappa kap) k = _
+eval g dps (ExpJump f xs ktail) = do
+  f' <- evalVal g f
+  xs' <- traverse (evalVal g) xs
+  ktail' <- traverse (evalKexp g) (ktail ^.. _Just)
+  case f' of
+    EProcedure p -> p (xs' ++ ktail') dps
+    _ -> wrong "bad procedure"
 
-eval :: Env -> DynPoints -> Exp -> ExpCont -> CmdCont
+eval g dps (ExpLetRec bs e) = do
+  ls <- for bs . const $ new' EUndefined
+  let g' = g & extends (zip (bs ^.. each . _1) ls)
+  bs' <- forOf (each . _2) bs (evalAbs g')
+  traverse_ (uncurry assign) $ zip ls (bs' ^.. each . _2)
+  eval g' dps e
 
-eval g dps (ExpContinue f xs) k =
-  telescope (evalVal1 g) (f:|xs) \(f':|xs') ->
-    case f' of
-      EProcedure _loc fp -> fp xs' dps k
-      _ -> wrong "bad procedure"
+eval g dps (ExpPrim p k) = do
+  p' <- evalPrim g =<< traverse (evalVal g) p
+  evalKexp g k >>= \case
+    EProcedure fp -> fp p' dps
+    _ -> wrong [i|prim(#{p})의 계속을 나쁘다|]
 
-eval g dps (ExpApply f xs ktail) k =
-  telescope (evalVal1 g) (f:|xs) \(f':|xs') ->
-    case f' of
-      EProcedure _loc fp -> fp xs' dps k
-      _ -> wrong "bad procedure"
+eval g dps e = error [i|unimplemented #{e}|]
+
+evalPrim :: Env -> Prim E -> M Answer (List E)
+evalPrim g = \case
+  PrimAdd x y -> arith2 (+) x y
+  PrimMul x y -> arith2 (*) x y
+  PrimSub x y -> arith2 (-) x y
+  PrimDiv x y -> arith2 div x y
+  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}|]
 
 
 
 evalExp :: Jalmot :> es => Exp -> Eff es _
 evalExp e = _
 
-evalProgram :: Jalmot :> es => Program -> Eff es _
-evalProgram (MkProgram lam) = _
+evalProgram :: Jalmot :> es => Program -> Eff es (List S.Datum)
+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

src/Gyehoek/Options.hs

@@ -54,8 +54,8 @@ runtimeValues = ["stackify","wasm","cps","none"]
 runtimeReader = maybeReader \case
   "stackify" -> Just (Just Stackify)
   "wasm" -> Just (Just Wasm)
-  "cps" -> Just (Just CPS)
-  ("cps2";"higher-order-cps") -> Just (Just CPS)
+  "cps1" -> Just (Just CPS)
+  ("cps";"higher-order-cps") -> Just (Just HigherOrderCPS)
   "none" -> Just Nothing
   _ -> Nothing