superfuck

src/Gyehoek/CPS/Eval.hs

@@ -9,57 +9,37 @@ module Gyehoek.CPS.Eval
   , eGrammar
   ) where
 
-import Gyehoek.CPS.Syntax hiding (Hob(..), Obj(..), cont)
+import Gyehoek.CPS.Syntax hiding (Hob(..), Obj(..))
 import Gyehoek.Sexp qualified as S
-import Control.Lens hiding (assign)
+import Control.Lens
 import Data.Maybe (fromMaybe)
 import Text.Show.Functions ()
 import qualified Data.HashMap.Strict as H
-import Gyehoek.Prelude hiding (assign)
+import Gyehoek.Prelude
 import Debug.Pretty.Simple
 import Gyehoek.Jalmot
-import Control.Monad.Cont
+import Control.Monad.Cont qualified as Cont
 import Gyehoek.Sexp qualified as S
 import GHC.Generics (Generically(..))
 import Gyehoek.Sexp ((:-)(..))
-import Data.List (nub, mapAccumR, compareLength)
+import Data.List (nub)
 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, Enum)
+  deriving newtype (Show, Eq, Ord)
 
 data Store = MkStore
   { nextLoc :: Loc
   , heap :: IntMap E
   }
-  deriving stock (Show, Generic)
+  deriving stock (Show, Generic, Data)
-
-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
@@ -73,60 +53,42 @@ update (MkLoc loc) v = #heap %~ IM.alter f loc
     f (Just _) = Just v
     f Nothing = error "segfault lol"
 
-updates :: Foldable f => f (Loc, E) -> Store -> Store
+fetch :: Loc -> Store -> E
-updates = alaf Endo foldMap (uncurry update)
+fetch (MkLoc loc) st = st ^?! #heap . ix loc
 
-fetch :: Loc -> M r E
+new :: Store -> Loc
-fetch (MkLoc loc) = gets (^?! #heap . ix loc)
+new = _
 
-new :: M r Loc
+var :: HasCallStack => Env -> Name -> Loc
-new = state \st -> (st.nextLoc, st & #nextLoc %~ succ)
+var g x = g ^?! ix x
-
-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 AJalmot
+  | AnswerError Text
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data)
 
 data Mutability
   = Mut
   | NoMut
   deriving (Show, Generic, Data, Eq)
 
-wrong :: Text -> M Answer a
+wrong :: Text -> CmdCont
-wrong s = ContT \_ -> pure . AnswerError . EvalError $ s
+wrong = const . AnswerError
 
-bind :: Name -> Loc -> Env
+single :: (E -> CmdCont) -> ExpCont
-bind k = MkEnv . H.singleton k
+single k = \case
+  [x] -> k x
+  _ -> wrong "wrong number of return values"
 
-extends :: Foldable f => f (Name, Loc) -> Env -> Env
+send :: E -> ExpCont -> CmdCont
-extends xs g = g <> foldMap (uncurry bind) xs
+send e k = k [e]
 
-assign :: Loc -> E -> M Answer ()
+-- | Continue with the value located at a given 'Loc'.
-assign l e = do
+hold :: Loc -> ExpCont -> CmdCont
-  use (at l) >>= \case
+hold loc k st = send (fetch loc st) k st
-    Just _ -> at l ?= e
-    Nothing -> wrong [i|#{e}에서 #{l}이라는 주소는 없다|]
 
 
 
@@ -134,7 +96,7 @@ assign l e = do
 data E
   = ESymbol Text
   | ECharacter Char
-  | EInt Int
+  | EInteger Int
   | EBool Bool
   | EUndefined
   | EUnspecified
@@ -142,19 +104,17 @@ data E
   | EPair Loc Loc Mutability
   | EVec (List Loc) Mutability
   | EString (List Loc) Mutability
-  | EProcedure Procedure
+  | EProcedure Loc (List E -> DynPoints -> ExpCont -> CmdCont)
-  deriving stock (Show, Generic)
+  deriving stock (Show, Generic, Data)
-
-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 $ st ^?! ix x
+    gofetch x = go $ fetch x st
     go = \case
       ESymbol s -> S.Symbol s
       ECharacter c -> S.Character c
-      EInt n -> S.Number (fromIntegral n)
+      EInteger n -> S.Number (fromIntegral n)
       EBool b -> S.Boolean b
       EUndefined -> S.Unreadable "#<undefined>"
       EUnspecified -> S.Unreadable "#<unspecified>"
@@ -168,92 +128,47 @@ 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
+
 
-evalVal g (ValImm imm) = pure case imm of
+evalVal :: Env -> Val -> ExpCont -> CmdCont
-  ImmLabel l -> error [i|#{l}|]
+evalVal g (ValVar x) k = hold (var g x) $ single \case
-  ImmInt n -> EInt n
+  EUndefined -> wrong "undefined variable"
-  ImmBool b -> EBool b
+  e -> send e k
-  ImmUndefined -> EUndefined
 
-evalKexp :: Env -> Kexp -> M Answer E
+evalVal1 :: Env -> Val -> (E -> CmdCont) -> CmdCont
-evalKexp g (KexpVar x) = var g x >>= fetch
+evalVal1 g v k = evalVal g v (single k)
-evalKexp g (KexpKappa kap) = evalAbs g (AbsKappa kap)
 
-evalAbs :: Env -> Abs -> M Answer E
+evalKexp :: Env -> Kexp -> ExpCont -> CmdCont
-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
 
-eval :: Env -> DynPoints -> Exp -> M Answer (List E)
+evalKexp g (KexpVar x) k = evalVal g (ValVar x) k
 
-eval g dps (ExpJump f xs ktail) = do
+evalKexp g (KexpKappa kap) k = _
-  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 g dps (ExpLetRec bs e) = do
+eval :: Env -> DynPoints -> Exp -> ExpCont -> CmdCont
-  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 (ExpPrim p k) = do
+eval g dps (ExpContinue f xs) k =
-  p' <- evalPrim g =<< traverse (evalVal g) p
+  telescope (evalVal1 g) (f:|xs) \(f':|xs') ->
-  evalKexp g k >>= \case
+    case f' of
-    EProcedure fp -> fp p' dps
+      EProcedure _loc fp -> fp xs' dps k
-    _ -> wrong [i|prim(#{p})의 계속을 나쁘다|]
+      _ -> wrong "bad procedure"
 
-eval g dps e = error [i|unimplemented #{e}|]
+eval g dps (ExpApply f xs ktail) k =
-
+  telescope (evalVal1 g) (f:|xs) \(f':|xs') ->
-evalPrim :: Env -> Prim E -> M Answer (List E)
+    case f' of
-evalPrim g = \case
+      EProcedure _loc fp -> fp xs' dps k
-  PrimAdd x y -> arith2 (+) x y
+      _ -> wrong "bad procedure"
-  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 (List S.Datum)
+evalProgram :: Jalmot :> es => Program -> Eff es _
-evalProgram (MkProgram lam) = case run (pure . AnswerValues) of
+evalProgram (MkProgram lam) = _
-  (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,7 +31,6 @@ data AJalmot
   = ReaderError (ParseErrorBundle Text Void)
   | GrammarError (Grammar.ErrorMessage Ann)
   | VMError Text
-  | EvalError Text
   deriving (Show, Generic, Data)
 
 data AJalmotCS = MkAJalmotCS !CallStack !AJalmot
@@ -67,7 +66,6 @@ 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)
-  "cps1" -> Just (Just CPS)
+  "cps" -> Just (Just CPS)
-  ("cps";"higher-order-cps") -> Just (Just HigherOrderCPS)
+  ("cps2";"higher-order-cps") -> Just (Just CPS)
   "none" -> Just Nothing
   _ -> Nothing