cleanup options

.dir-locals.el

@@ -9,6 +9,9 @@
       . (progn (defun apply-cabal-fmt-h ()
                  (haskell-mode-buffer-apply-command "cabal-fmt"))
                (add-hook 'before-save-hook #'apply-cabal-fmt-h nil t)))))
+ (scheme-mode
+  . ((eval . (dolist (s '(kappa κ prim))
+               (put s 'scheme-indent-function 1)))))
  (nil
   . ((eval
       . (progn (defun display-ansi ()

.gitignore

@@ -9,3 +9,4 @@ dist-newstyle
 .direnv
 result
 play/
+trace.html

doc/closure-conversion.org

@@ -132,3 +132,34 @@ multiple ~env-ref~ calls could probably be replaced with a primitive that loads
                                  $code)
                      1))))
 #+end_src
+
+** example
+
+#+begin_src scheme
+  (λ (n m ktail)
+    (letrec ((f (λ (x ktail-0) (+ x n ktail-0)))
+             (g (λ (y ktail-1) (+ y g ktail-1))))
+      (prim (cons f g) ktail)))
+#+end_src
+
+#+begin_src scheme
+  (λ (n m ktail)
+    (letrec ((f-code (λ (x ktail-0)
+                       (prim (env-get 2)
+                         (κ (n)
+                           (+ x n ktail-0)))))
+             (g-code (λ (y ktail-1)
+                       (prim (env-get 3)
+                         (κ (m)
+                           (+ y m ktail-1))))))
+      (letrec ((with-closure-code
+                (κ (f g)
+                  (prim (get-env 0)
+                    (κ (ktail)
+                      (prim cons f g ktail))))))
+        (prim (make-shared-closure (with-closure-code)
+                                   ktail)
+          (κ (with-closure)
+            (prim (make-shared-closure (f-code g-code) n m)
+              with-closure))))))
+#+end_src

doc/libraries.org

@@ -0,0 +1,9 @@
+#+title: on libraries
+
+R⁷RS leaves it unspecified how exactly libraries correspond to files:
+
+#+begin_quote
+Programs and libraries are typically stored in files, although in some implementations they can be entered interactively into a running Scheme system. Other paradigms are possible. Implementations which store libraries in files should document the mapping from the name of a library to its location in the file system.
+#+end_quote
+
+thus the implementation of ~define-library~ is open to much interpretation. we could possibly define libraries as first-class objects, or deal with them statically. the former case is appealing to me, as it could massively simplify interactive use.

doc/make-vm-stackier.org

@@ -0,0 +1,100 @@
+* rationale?
+
+previously, the VM's stack was used for storing local variables across blocks; a Scheme procedure was split into several low-level routines (one for the procedure itself and one for each continuation), and the stack was used as a communication channel for these separate routines. in contrast, registers were local to each routine. this aligns with Wasm's model of functions pretty well, with Wasm /locals/ acting as the VM's /registers/, and a global mutable stack serving as fallback.
+
+this worked quite well until it became time to implement ~call/cc~.
+
+we are considering making the following alterations to the VM:
+- explicitly segment the stack into frames.
+- passing procedures and return addresses on the stack.
+- new instructions:
+  + ~(tail-call /n/)~
+  + ~(call /n/)~
+  + ~(load /r/ /n/)~
+  + ~(return /n/)~
+
+* scratchpad
+
+#+begin_src scheme
+  (letrec ((fac (λ (n)
+                (if (zero? n)
+                    1
+                    (* n (fac (- n 1)))))))
+  (fac 3))
+#+end_src
+
+#+begin_src scheme
+  (λ (ktail0)
+  (letrec ((fac
+            (λ (n ktail1)
+              (zero?
+               n
+               (κ (x0)
+                  (if x0
+                      (continue ktail1 1)
+                      (- n 1
+                         (κ (x1)
+                            (fac x1
+                                 (κ (x2)
+                                    (* n x2 ktail1)))))))))))
+    (fac 3)))
+#+end_src
+
+#+begin_example
+n ktail1
+| |
+| | x0
+| | |
+| | ^
+| |
+| | x1
+| | |
+| | ^
+| | 
+| | x2
+| | |
+^ ^ ^
+#+end_example
+
+#+begin_src scheme
+  (define $fac-c0
+    (pop! %x0 0) ; [ x0 $fac-c0 n $fac ktail1 ]
+    (if %x0 ; [ $fac-c0 n $fac ktail1 ]
+        ;; every variable but `ktail1' is dead so we pop them all.
+        ;; this probably means that `if' should take two continuations
+        ;; rather than two blocks.
+        (then (push! 1) ; [ $fac-c0 n $fac ktail1 ]
+              (return 1)) ; [ 1 $fac-c0 n $fac ktail1 ]
+        (else (load %n 1) ; [ $fac-c0 n $fac ktail1 ]
+              (prim %x1 (- %n 1)) ; [ $fac-c0 n $fac ktail1 ]
+              (push! $fac-c1) ; [ $fac-c0 n $fac ktail1 ]
+              (push! $fac) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
+              (push! %x1) ; [ $fac $fac-c1 $fac-c0 n $fac ktail1 ]
+              (call 1) ; [ x1 $fac $fac-c1 $fac-c0 n $fac ktail1 ]
+              )))
+
+  (define $fac-c1
+    (pop! %x2) ; [ x2 $fac-c1 $fac-c0 n $fac ktail1 ]
+    (load %n 3) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
+    (prim %x3 (* %n %x2))
+    (push! %x3) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
+    (return 1) ; [ x3 $fac-c1 $fac-c0 n $fac ktail1 ]
+    )
+
+  (define $fac
+    (load %ktail1 2) ; [ n $fac ktail1 ]
+    (load %n 0) ; [ n $fac ktail1 ]
+    (push! $fac-c0) ; [ n $fac ktail1 ]
+    (push! $zero?) ; [ $fac-c0 n $fac ktail1 ]
+    (push! %n) ; [ $zero? $fac-c0 n $fac ktail1 ]
+    (call 1) ; [ n $zero? $fac-c0 n $fac ktail1 ]
+    )
+
+  (define $start
+    (push! $fac) ; [ $start ktail0 ]
+    (push! 3) ; [ $fac $start ktail0 ]
+    (tail-call 1) ; [ 3 $fac $start ktail0 ]
+    ;; ↑ `tail-call' knows how to dispose of the caller's stack frame.
+    )
+#+end_src
+

golden/exec/cons-2/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > (456 . 123)

golden/exec/cons-2/source.scm

@@ -0,0 +1,2 @@
+(let ((p (cons 123 456)))
+  (cons (cdr p) (car p)))

golden/exec/lit-int/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 123

golden/exec/lit-int/source.scm

@@ -0,0 +1 @@
+123

golden/exec/map/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > (0 . (1 . (4 . (9 . (16 . ())))))

golden/exec/map/source.scm

@@ -0,0 +1,7 @@
+(letrec ((my-map (λ (f l)
+                   (if (pair? l)
+                       (cons (f (car l))
+                             (my-map f (cdr l)))
+                       (list)))))
+  (my-map (λ (x) (* x x))
+          (list 0 1 2 3 4)))

gyehoek.cabal

@@ -60,11 +60,12 @@ library
     Gyehoek.CPS.Close
     Gyehoek.CPS.Convert
     Gyehoek.CPS.Eval
-    Gyehoek.CPS.Stackify
+    Gyehoek.CPS.Hoist
     Gyehoek.CPS.Syntax
     Gyehoek.Driver
     Gyehoek.GenSym
     Gyehoek.Jalmot
+    Gyehoek.Language
     Gyehoek.Lift1
     Gyehoek.Options
     Gyehoek.Prelude
@@ -76,9 +77,6 @@ library
     Gyehoek.Sexp.QQ
     Gyehoek.Sexp.Read
     Gyehoek.Sexp.Syntax
-    Gyehoek.Stack.Lower
-    Gyehoek.Stack.Syntax
-    Gyehoek.Stack.VM
     Gyehoek.Wasm
 
   build-depends:
@@ -99,6 +97,7 @@ library
     , hashable
     , invertible-grammar
     , lens
+    , lucid
     , megaparsec
     , mtl
     , optparse-applicative
@@ -106,6 +105,7 @@ library
     , pretty-simple
     , prettyprinter
     , prettyprinter-ansi-terminal
+    , prettyprinter-lucid
     , process
     , recursion-schemes
     , scientific
@@ -116,8 +116,7 @@ library
     , typed-process
     , unordered-containers
     , vector
-    , lucid
+    , tardis
-    , prettyprinter-lucid
 
   hs-source-dirs:   src
   default-language: GHC2024
@@ -132,14 +131,11 @@ test-suite test
   -- cabal-fmt: expand test -Main
   other-modules:
     Gyehoek.Test.CPS.Eval
-    Gyehoek.Test.CPS.Stackify
     Gyehoek.Test.CPS.Syntax
-    Gyehoek.Test.Golden
     Gyehoek.Test.Scheme.Syntax
     Gyehoek.Test.Sexp.Print
     Gyehoek.Test.Sexp.QQ
     Gyehoek.Test.Sexp.Read
-    Gyehoek.Test.Stack.VM
     Gyehoek.TestUtil
     Root
 
@@ -167,7 +163,10 @@ test-suite doctest
   import:             ghcstuffs, ghcstuffs-dev
   type:               exitcode-stdio-1.0
   hs-source-dirs:     test
-  build-depends:      base
+  build-depends:
+    , base
+    , gyehoek
+
   default-extensions: CPP
   main-is:            doctest.hs
 

src/Gyehoek/CPS/Close.hs

@@ -7,36 +7,49 @@ import Gyehoek.CPS.Syntax
 import Data.List (nub)
 import Gyehoek.GenSym
 import Gyehoek.Prelude
+import Debug.Pretty.Simple
+import Gyehoek.Sexp qualified as S
+import Data.HashSet.Lens
+import Data.Traversable
 
 
-close :: GenSym :> es => Exp -> Eff es Exp
+genCodeName :: GenSym :> es => Name -> Eff es Name
-close = transformM \case
+genCodeName f = gensym' @Name $ f ^. _Wrapped' . to (<> "-code")
-  ExpLetRec [(f, AbsLambda lam@(MkLambda bs kb m))] e -> do
-    f_code <- gensym' @Name $ f ^. _Wrapped'. to (<> "-code")
-    -- it would probably be most sane to generate a symbol for `env`,
-    -- but we're reusing the lambda binding so we don't have to
-    -- explicitly substitute recursive calls.
-    let frees = nub $ freeWithBound' [f] lam
-    let m' = ifoldr
-             (\n x q -> [cps|(prim (env-ref #{f} #{n})
-                                (κ (#{x}) #{q}))|])
-             m frees
-    pure [cps|
-      (letrec ((#{f_code} (λ (#{f} ##{bs} #{kb})
-                            #{m'})))
-        (prim (make-closure ($ #{f_code}) ##{frees})
-          (κ (#{f}) #{e})))
-    |]
 
-  ExpApply f xs ktail -> do
+bindEnv :: List Name -> Exp -> Exp
-    code <- gensym' @Name "code"
+bindEnv frees m = [cps|
+  (prim (get-env) (κ #{frees} #{m}))
+|]
+
+close1 :: forall es. GenSym :> es => Exp -> Eff es Exp
+close1 = \case
+  lr@(ExpLetRec bs e) -> do
+    let boundNames = bs ^.. each . _1
+    let boundNames' = setOf each boundNames
+    let frees = bs
+          & foldMapOf
+            (each . _2)
+            (freeWithBound' boundNames')
+          & nub
+    env_cont_l <- gensym' @Name "env-cont"
+    e_l <- gensym' @Name "letrec-body-cont"
+    bs' <- for bs \(f,ab) -> do
+      f_code_l <- genCodeName f
+      pure ( f_code_l
+           , ab & absBody %~ bindEnv (boundNames ++ frees)
+           )
+    let codes = bs' ^.. each . _1 . to MkLabel
     pure [cps|
-      (prim (env-code #{f})
+      (letrec #{bs'}
-        (κ (#{code})
+        (prim (make-shared-closure #{codes} #{frees})
-          (#{code} #{f} ##{xs} #{ktail})))
+          (κ #{boundNames}
+            #{e})))
     |]
 
   e -> pure e
 
+close :: forall es. GenSym :> es => Exp -> Eff es Exp
+close = transformM close1
+
 closeProgram :: GenSym :> es => Program -> Eff es Program
 closeProgram = traverseOf (#body . #body) close

src/Gyehoek/CPS/Convert.hs

@@ -46,26 +46,18 @@ convert (Scm.ExpLit l) k = k . one . ValImm $ case l of
   LitBool b -> ImmBool b
   _ -> _
 
--- special case: call/cc is desugared during cps-conversion...
-convert (Scm.ExpPrim (PrimCallCC withcc)) k = do
-  convert1 withcc \withcc' -> do
-    cc <- gensym' @Name "cc"
-    r <- gensym' "r"
-    m <- k . one $ ValVar r
-    ccish <- gensym' @Name "cc-ish"
-    x <- gensym' @Name "x"
-    pure [cps|
-      (letrec ((#{cc} (κ (#{r}) #{m})))
-        (letrec ((#{ccish} (λ (#{x} _) (continue #{cc} #{x}))))
-          (#{withcc'} #{ccish} #{cc})))
-    |]
-
--- ...while all other prims are left as-is for later stages to
--- handle..
 convert (Scm.ExpPrim p) k =
   telescope (convert1 @es) p \p' -> do
-    r <- gensym' "r"
+    r_l <- gensym' "r"
-    ExpPrim p' . MkKappa [r] <$> k [ValVar r]
+    -- k_l <- gensym' @Name "prim-k"
+    m <- k [ValVar r_l]
+    pure [cps|
+      (prim #{p'} (κ (#{r_l}) #{m}))
+    |]
+    -- pure [cps|
+    --   (letrec ((#{k_l} (κ (#{r_l}) #{m})))
+    --     (prim #{p'} #{k_l}))
+    -- |]
 
 convert (Scm.ExpLambda xs e) k = do
   f <- gensym' "lambda-body"
@@ -78,17 +70,25 @@ convert (Scm.ExpLambda xs e) k = do
 
 convert (Scm.ExpApply f xs) k =
   telescope (convert1 @es) (f:|xs) \(f':|xs') -> do
-    r <- gensym' "r"
+    r <- gensym' @Name "r"
     x <- gensym' "x"
     m <- k [ValVar x]
     pure $ ExpLetRec [(r, AbsKappa' [x] m)] $
-      ExpApply f' xs' r
+      ExpApply f' xs' (KexpVar r)
 
 convert (Scm.ExpBegin xs) k = telescope (convert @es) xs (k . NE.last)
 
 convert (Scm.ExpIf c t f) k =
-  convert1 c \c' ->
+  convert1 c \c' -> do
-    ExpIf c' <$> convert t k <*> convert f k
+    t_l <- gensym' @Name "truthy-cont"
+    f_l <- gensym' @Name "falsey-cont"
+    t' <- convert t k
+    f' <- convert f k
+    pure [cps|
+      (letrec ((#{t_l} (κ () #{t'}))
+               (#{f_l} (κ () #{f'})))
+        (if #{c'} #{t_l} #{f_l}))
+    |]
 
 -- let-bindings are desugared into continuation calls whose parameters
 -- are the left-hand sides and whose arguments are the right-hand

src/Gyehoek/CPS/Eval.hs

@@ -1,104 +1,303 @@
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedLists #-}
 module Gyehoek.CPS.Eval
   ( evalProgram
   , module Gyehoek.CPS.Syntax
   , evalExp
+  , eGrammar
   ) where
 
-import Gyehoek.CPS.Syntax
+import Gyehoek.CPS.Syntax hiding (Hob(..), Obj(..), cont)
-import Control.Lens
+import Gyehoek.Sexp qualified as S
-import Data.Maybe (fromMaybe)
+import Control.Lens hiding (assign)
+import Data.Maybe (fromMaybe, isJust)
 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
+import Gyehoek.Sexp qualified as S
+import GHC.Generics (Generically(..))
+import Gyehoek.Sexp ((:-)(..))
+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_, foldrM)
 
 
-data Env = MkEnv
+newtype Loc = MkLoc { getLoc :: Int }
-  { vars :: HashMap Name Obj
+  deriving stock (Generic, Data)
-  , labels :: HashMap Name (Env, Abs)
+  deriving newtype (Show, Eq, Ord, Enum)
+
+data Store = MkStore
+  { nextLoc :: Loc
+  , heap :: IntMap E
   }
-  deriving (Show, Generic)
+  deriving stock (Show, Generic)
 
-eval :: Env -> Exp -> List Obj
+type instance Index Store = Loc
+type instance IxValue Store = E
 
-eval g (Halt xs) = evalVal g <$> xs
+instance Ixed Store where ix (MkLoc j) = #heap . ix j
+instance At Store where at (MkLoc j) = #heap . at j
 
-eval g (ExpContinue k xs) =
+emptyStore :: Store
-  case g ^. #labels . at k' of
+emptyStore = MkStore
-    Just (h, AbsKappa' bs m) -> eval h' m
+  { nextLoc = MkLoc 0
-      where
+  , heap = mempty
-        h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
+  }
-    _ -> error [i|not a kappa: #{k}|]
-  where
-    k' = case evalVal g k of
-      ObjImm (ImmLabel x) -> x
-      x -> error [i|expected label, got #{x}|]
 
-eval g (ExpApply f xs ktail) =
+newtype Env = MkEnv { getEnv :: HashMap Name Loc }
-  case g ^?! #labels . at f' of
+  deriving stock (Show, Generic, Data)
-    Just (h,AbsLambda' bs kb m) -> eval h' m
+  deriving newtype (Semigroup, Monoid)
-      where h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
-                   & #labels . at kb .~ (g ^. #labels . at ktail)
-    Nothing -> error [i|undefined label: #{f}|]
-  where
-    f' = case evalVal g f of
-      ObjImm (ImmLabel x) -> x
-      x -> error [i|expected label, got #{x}|]
-
-eval g (ExpLetRec [(b, ab)] e) = eval g' e
-  where g' = g & #labels . at b ?~ ab
-
-eval g (ExpPrim p (MkKappa bs e)) = case evalVal g <$> p of
-  PrimAdd x y -> arithBinop (+) x y
-  PrimMul x y -> arithBinop (*) x y
-  PrimSub x y -> arithBinop (-) x y
-  PrimDiv x y -> arithBinop div x y
-  PrimMakeClosure x env -> ret [ObjHob (HobClosure lbl env) ]
-    where
-      lbl = case x of
-        ObjImm (ImmLabel l) -> l
-        _ -> error [i|expected label, got #{x}|]
-  PrimEnvCode x -> ret . (:[]) . ObjImm . ImmLabel $ code
-    where
-      code = case x of
-        ObjHob (HobClosure lbl _) -> lbl
-        _ -> error [i|expected closure, got #{x}|]
-  _ -> error [i|unhandled prim: #{p}|]
-  where
-    ret rs = eval
-        (g & #vars <>~ envOfBinds bs rs)
-        e
-    arithBinop f (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) =
-      ret [ObjImm . ImmInt $ f x y]
-    arithBinop _ x y = error [i|bad arith: #{x}, #{y}|]
-
-eval _ e = error [i|unimplemented case: #{e}|]
-
-envOfBinds bs xs = foldMap (uncurry H.singleton) (zip bs xs)
-
-evalVal :: Env -> Val -> Obj
-evalVal g = \case
-  ValVar x -> fromMaybe (error [i|unbound: #{x}|]) $ g ^?! #vars . at x
-  ValImm x -> ObjImm x
 
 emptyEnv :: Env
-emptyEnv = MkEnv
+emptyEnv = mempty
-  { vars = mempty
-  -- a kinda silly hack to make sure `halt` is handled correctly when
-  -- it appears as the tail continuation of an application. the
-  -- special case of `eval` responsible for `halt` only covers terms
-  -- of the form `(continue $halt xs …)`; other terms such as
-  -- `($some-fn xs $halt)` just see an undefined label `$halt`.
-  , labels = H.singleton "halt" $
-     AbsKappa' ["h0"] $ Halt [ValVar "h0"]
-  }
 
-evalExp :: Exp -> List Obj
+type instance Index Env = Name
-evalExp = eval emptyEnv
+type instance IxValue Env = Loc
 
-evalProgram :: Program -> List Obj
+instance Ixed Env where ix j = #getEnv . ix j
-evalProgram (MkProgram lam) = eval emptyEnv [cps|
+instance At Env where at j = #getEnv . at j
-  (letrec ((start #{lam}))
+
-    (start halt))
+update :: Loc -> E -> Store -> Store
-|]
+update (MkLoc loc) v = #heap %~ IM.alter f loc
+  where
+    f (Just _) = Just v
+    f Nothing = error "segfault lol"
+
+updates :: Foldable f => f (Loc, E) -> Store -> Store
+updates = alaf Endo foldMap (uncurry update)
+
+fetch :: Loc -> M r E
+fetch (MkLoc loc) = gets (^?! #heap . ix loc)
+
+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 AJalmot
+  deriving (Show, Generic)
+
+data Mutability
+  = Mut
+  | NoMut
+  deriving (Show, Generic, Data, Eq)
+
+wrong :: Text -> M Answer a
+wrong s = ContT \_ -> pure . AnswerError . EvalError $ s
+
+orWrong
+  :: Getting (First a) s a
+  -> Text -> s -> M Answer a
+orWrong p msg s = case getFirst . getConst $ p (Const . First . Just) s of
+  Nothing -> wrong msg
+  Just x -> pure x
+
+bind :: Name -> Loc -> Env
+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
+  | EInt Int
+  | EBool Bool
+  | EUndefined
+  | EUnspecified
+  | ENull
+  | EPair Mutability Loc Loc
+  | EVec Mutability (List Loc)
+  | EString Mutability (List Loc)
+  | 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 $ st ^?! ix x
+    go = \case
+      ESymbol s -> S.Symbol s
+      ECharacter c -> S.Character c
+      EInt n -> S.Number (fromIntegral n)
+      EBool b -> S.Boolean b
+      EUndefined -> S.Unreadable "#<undefined>"
+      EUnspecified -> S.Unreadable "#<unspecified>"
+      EProcedure _ -> S.Unreadable "#<procedure>"
+      ENull -> S.List []
+      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) = 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
+evalKexp g (KexpKappa kap) = evalAbs g (AbsKappa kap)
+
+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
+
+eval :: Env -> DynPoints -> Exp -> M Answer (List E)
+
+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 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 (ExpPrim (PrimCallCC withcc) k) = do
+  withcc' <- evalVal g withcc >>= orWrong #_EProcedure
+    [i|call/cc: 함수가 아닌 것을 받았다|]
+  k' <- evalKexp g k
+  kproc <- orWrong #_EProcedure [i|call/cc: 몰라...|] k'
+  let cc = EProcedure \xs dps -> case unsnoc xs of
+        Just (xs',_) -> kproc xs' dps
+        Nothing -> wrong [i|call/cc: 잘못하는데!|]
+  withcc' [cc,k'] dps
+
+eval g dps (ExpPrim p k) = do
+  p' <- evalPrim g dps =<< traverse (evalVal g) p
+  evalKexp g k >>= \case
+    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 -> DynPoints -> Prim E -> M Answer (List E)
+evalPrim g dps = \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
+  PrimZeroP x -> pure1 . EBool . isJust $ x ^? #EInt . only 0
+  PrimCons x y -> pcons x y >>= pure1
+  PrimCar p -> cr p _2
+  PrimCdr p -> cr p _3
+  PrimPairP p -> pure1 . EBool . maybe False (const True) $
+    p ^? #_EPair
+  PrimValues xs -> pure xs
+  PrimList xs -> foldrM pcons ENull xs >>= pure1
+  p -> wrong [i|prim(#{p})은 벌써 나지 않다|]
+  where
+    pure1 x = pure [x]
+    pcons x y = do
+      (x',y') <- traverseOf both new' (x,y)
+      pure $ EPair Mut x' y'
+    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) [i|car/cdr는 pair을 받지 않다|] p
+      >>= fmap (:[]) . fetch
+
+
+
+evalExp :: Jalmot :> es => Exp -> Eff es _
+evalExp e = _
+
+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/CPS/Hoist.hs

@@ -0,0 +1,24 @@
+module Gyehoek.CPS.Hoist
+  ( hoistProgram
+  ) where
+
+import Gyehoek.CPS.Syntax
+import Gyehoek.Prelude
+import qualified Data.HashMap.Strict as H
+import Effectful.Writer.Static.Local
+import Data.Foldable
+
+
+type Hoist = Writer (HashMap Label Abs)
+
+hoist :: Hoist :> es => Exp -> Eff es Exp
+hoist = transformM \case
+  ExpLetRec bs m -> do
+    traverse_ (\(k,v) -> tell $ H.singleton (MkLabel k) v) bs
+    pure m
+  e -> pure e
+
+hoistProgram :: Program -> Eff es HoistedProgram
+hoistProgram p = do
+  (body,bindings) <- runWriter $ traverseOf #body hoist p.body
+  pure $ MkHoistedProgram {body,bindings}

src/Gyehoek/CPS/Stackify.hs

@@ -1,178 +0,0 @@
-{-# LANGUAGE OverloadedLists #-}
-module Gyehoek.CPS.Stackify
-  ( stackifyProgram
-  , module Gyehoek.CPS.Syntax
-  ) where
-
-import Gyehoek.CPS.Syntax
-import Gyehoek.Stack.Syntax qualified as Stk
-import Data.Sequence (Seq)
-import Data.Sequence qualified as Seq
-import Gyehoek.GenSym
-import Effectful.Writer.Static.Shared
-import Data.Foldable
-import qualified Data.HashMap.Strict as H
-import Data.List (elemIndex, nub)
-import Data.Text qualified as T
-import Gyehoek.Prelude
-import Debug.Pretty.Simple
-import qualified Gyehoek.Sexp as S
-
-
-type Stackify = Writer Stk.Program
-
-runStackify :: Eff (Stackify : es) a -> Eff es (a, Stk.Program)
-runStackify = runWriter
-
-live :: Free a => Env -> a -> List Name
--- TODO: free' should return an OSet lol
-live g e = nub (free' e) & filter \x ->
-  x `H.member` g.bound
-  -- && not (x `elem` g.contStack)
-
-data BlockBuilder
-  = Code (List Stk.Instr) BlockBuilder
-  | Tail Stk.Tail
-  deriving (Show, Generic)
-
-buildBlock :: BlockBuilder -> Stk.Block
-buildBlock = go [] where
-  go acc (Code xs bb) = go (acc ++ xs) bb
-  go acc (Tail t) = Stk.MkBlock acc t
-
-emitRoutine :: Stackify :> es => Stk.Routine -> Eff es ()
-emitRoutine rt = tell [rt]
-
-stackify
-  :: (GenSym :> es, Stackify :> es)
-  => Env -> Exp -> Eff es BlockBuilder
-
-stackify g (ExpLetRec [(f, AbsKappa kap)] e) = do
-  stackifyKappa g f kap \g' kap' -> do
-    emitRoutine kap'
-    stackify g' e
-
-stackify g (ExpLetRec [(f, AbsLambda lam)] e) = do
-  stackifyLambda g f lam \g' lam' -> do
-    emitRoutine lam'
-    stackify g' e
-
-stackify g (ExpIf c t f) = do
-  let c' = stackifyVal g c
-  t' <- buildBlock <$> stackify g t
-  f' <- buildBlock <$> stackify g f
-  pure . Tail $ Stk.If c' t' f'
-
-stackify g (ExpApply f xs ktail) = pure $
-    Code [ Stk.Push (Stk.ValReg l) | l <- ls ] $
-    Tail (Stk.TailCall (stackifyVal g f) (k : (stackifyVal g <$> xs)))
-  where
-    k = var g ktail
-    ls = fold $ (k ^? #ValImm . #ImmLabel)
-      >>= \klbl -> g ^. #liveness . at klbl
-
-stackify g e@(ExpContinue k xs) = do
-  pure $
-    Code [ Stk.Push (Stk.ValReg l) | l <- ls ] $
-    Tail (Stk.TailCall k' (stackifyVal g <$> xs))
-  where
-    k' = stackifyVal g k
-    ls = fold $ (k' ^? #ValImm . #ImmLabel)
-      >>= \klbl -> g ^. #liveness . at klbl
-
--- stackify g (ExpPrim (PrimCallCC withcc) cc) = do
---   cc_l <- gensym' "cc"
---   rcc_l <- gensym' "reified-cc"
---   stackifyKappa g cc_l cc \g' rt -> do
---     emitRoutine rt
---     pure $
---       Code [ Stk.Prim rcc_l $ PrimReifyCC (Stk.ValLabel cc_l) ] $
---       Tail (Stk.TailCall (stackifyVal g' withcc) [Stk.ValLabel rcc_l])
-
-stackify g (ExpPrim p (MkKappa [x] e)) = do
-  e' <- stackify (g & #bound . at x ?~ Stk.ValReg x) e
-  pure $
-    Code [ Stk.Prim x (stackifyVal g <$> p) ] e'
-
-stackify _ e = error [i|unimplemented exp: #{e}|]
-
--- affine
-_ValName :: Traversal' Val Name
-_ValName = failing #ValVar (#ValImm . #ImmLabel)
-
-stackifyKappa
-  :: (Stackify :> es, GenSym :> es)
-  => Env -> Name -> Kappa
-  -> (Env -> Stk.Routine -> Eff es r)
-  -> Eff es r
-stackifyKappa g name kap@(MkKappa xs m) w = do
-  let vs = (name, Stk.ValLabel name) : (bindReg <$> xs)
-  let ls = live g kap
-  m' <- stackify (g & #bound <>~ H.fromList (vs ++ (bindReg <$> ls))) m
-  let g' = g & #bound . at name ?~ Stk.ValLabel name
-             & #liveness . at name ?~ live g kap
-  let rt = Stk.MkRoutine name xs . buildBlock $
-       -- pop in the opposite order we push
-       Code [Stk.Pop x | x <- reverse ls] m'
-  w g' rt
-
-stackifyLambda
-  :: (Stackify :> es, GenSym :> es)
-  => Env -> Name -> Lambda
-  -> (Env -> Stk.Routine -> Eff es r)
-  -> Eff es r
-stackifyLambda g name (MkLambda xs k m) w = do
-  let vs = [ (x, Stk.ValReg x) | x <- k:xs ]
-  m' <- stackify (g & #bound <>~ H.fromList vs) m
-  let g' = g & #bound . at name ?~ Stk.ValLabel name
-  w g' $ Stk.MkRoutine name (k:xs) (buildBlock m')
-
-stackifyVal :: Env -> Val -> Stk.Val
-stackifyVal g = \case
-  ValImm imm -> Stk.ValImm imm
-  ValVar v -> var g v
-  v -> error [i|unimplemented val: #{v}|]
-
-var :: Env -> Name -> Stk.Val
-var g v = case g ^. #bound . at v of
-  Just x -> x
-  Nothing -> Stk.ValLabel v
-
-bindReg :: Name -> (Name, Stk.Val)
-bindReg x = (x, Stk.ValReg x)
-
-
-
-data Env = MkEnv
-  { bound :: HashMap Name Stk.Val
-  -- | for each locally-bound continuation @k@, @liveness@ has an
-  -- entry @(k,ls)@ where @ls@ is the sequence of registers @k@
-  -- expects to find saved on the stack.
-  , liveness :: HashMap Name (List Name)
-  }
-  deriving (Show, Generic)
-
-emptyEnv :: Env
-emptyEnv = MkEnv mempty mempty
-
-
-
-stackifyProgram :: GenSym :> es => Program -> Eff es Stk.Program
-stackifyProgram (MkProgram lam) = do
-  let g = emptyEnv
-  (_,p) <- runStackify $ stackifyLambda g "start" lam (const emitRoutine)
-  pure p
-
-letfn :: Program
-letfn = [cps|
-(λ (start-ktail0)
-  (letrec ((lambda-body1
-            (λ (x lambda-tail2)
-              (prim (* x x) (κ (r3) (continue lambda-tail2 r3))))))
-    (letrec ((let-body6
-              (κ (square)
-                (letrec ((r4 (κ (x5) (continue start-ktail0 x5))))
-                  (square 4 r4)))))
-      (continue let-body6 lambda-body1))))
-|]
-

src/Gyehoek/CPS/Syntax.hs

@@ -10,14 +10,18 @@ module Gyehoek.CPS.Syntax
   , Kappa(..)
   , Lambda(..)
   , Exp(..)
+  , Kexp(..)
   , ExpF(..)
   , Name(..)
   , Prim(..)
   , Program(..)
+  , HoistedProgram(..)
   , Lit(..)
   , Imm(..)
   , Obj(..)
   , Hob(..)
+  , Label(..)
+  , Reg(..)
   , pattern Halt
   , pattern Halt1
   , _MkKappa
@@ -36,7 +40,13 @@ module Gyehoek.CPS.Syntax
   , Abs(..)
   , Free(..)
   , pattern ValLabel
-  , labelName -- don't like that this is part of the api
+  , pattern ObjLabel
+  , absBody
+  , pattern MkAbs
+  , _MkAbs
+  , unhoist
+  , pattern ExpJump
+  , _ExpJump
   )
   where
 
@@ -52,6 +62,12 @@ import Gyehoek.Prelude hiding (op)
 import Gyehoek.Sexp (Datum)
 import Gyehoek.Sexp (G, (:-)(..))
 import qualified Data.InvertibleGrammar.Base as IG
+import Gyehoek.GenSym (Gen)
+import Data.String (IsString)
+import Control.Applicative
+import qualified Data.HashMap.Strict as H
+import GHC.Records (HasField (..))
+import Data.Bifunctor
 
 -- Data types
 
@@ -60,13 +76,23 @@ data Val
   | ValVar Name
   deriving (Show, Generic, Data, Eq)
 
-pattern ValLabel :: Name -> Val
+pattern ValLabel :: Label -> Val
 pattern ValLabel x = ValImm (ImmLabel x)
 
+newtype Label = MkLabel { inner :: Name }
+  deriving stock (Generic, Data)
+  deriving newtype (Show, Eq, Gen, IsString, Hashable)
+  deriving anyclass (NFData, Wrapped)
+
+newtype Reg = MkReg { inner :: Name }
+  deriving stock (Generic, Data)
+  deriving newtype (Show, Eq, Gen, IsString, Hashable)
+  deriving anyclass (NFData, Wrapped)
+
 data Imm
   = ImmInt Int
   | ImmBool Bool
-  | ImmLabel Name
+  | ImmLabel Label
   | ImmUndefined
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
@@ -77,9 +103,13 @@ data Obj
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
 
+pattern ObjLabel l = ObjImm (ImmLabel l)
+
 -- | a heap object.
 data Hob
-  = HobClosure { label :: Name, env :: List Obj }
+  = HobClosure { label :: Label, env :: List Obj }
+  -- should a continuation have a label, or an Obj?
+  | HobContinuation { cont :: Obj, stack :: NonEmpty (List Obj) }
   | HobPair Obj Obj
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
@@ -95,24 +125,60 @@ data Abs
   | AbsLambda Lambda
   deriving (Show, Generic, Data, Eq)
 
-pattern AbsKappa' :: [Name] -> Exp -> Abs
+pattern AbsKappa' :: List Name -> Exp -> Abs
 pattern AbsKappa' xs e = AbsKappa (MkKappa xs e)
 
-pattern AbsLambda' :: [Name] -> Name -> Exp -> Abs
+pattern AbsLambda' :: List Name -> Name -> Exp -> Abs
 pattern AbsLambda' xs e ktail = AbsLambda (MkLambda xs e ktail)
 
+{-# COMPLETE AbsKappa', AbsLambda' #-}
+
+_MkAbs :: Iso' Abs (List Name, Maybe Name, Exp)
+_MkAbs = iso
+  (\case
+    AbsKappa' xs e -> (xs,Nothing,e)
+    AbsLambda' xs ktail e -> (xs,Just ktail,e))
+  (\(xs,ktail,e) -> case ktail of
+    Just k -> AbsLambda' xs k e
+    Nothing -> AbsKappa' xs e)
+
+pattern MkAbs :: List Name -> Maybe Name -> Exp -> Abs
+pattern MkAbs xs ktail body <- (view _MkAbs -> (xs,ktail,body))
+  where MkAbs xs ktail body = review _MkAbs (xs,ktail,body)
+
+{-# COMPLETE MkAbs #-}
+
+_ExpJump :: Prism' Exp (Val, List Val, Maybe Kexp)
+_ExpJump = prism'
+  (\(f,xs,ktail) -> case ktail of
+    Just k -> ExpApply f xs k
+    Nothing -> ExpContinue f xs)
+  \case
+    ExpApply f xs ktail -> Just (f,xs,Just ktail)
+    ExpContinue f xs -> Just (f,xs,Nothing)
+    _ -> Nothing
+
+pattern ExpJump :: Val -> List Val -> Maybe Kexp -> Exp
+pattern ExpJump f xs ktail <- (preview _ExpJump -> Just (f,xs,ktail))
+  where ExpJump f xs ktail = review _ExpJump (f,xs,ktail)
+
 data Exp
-  = ExpPrim (Prim Val) Kappa
+  = ExpPrim (Prim Val) Kexp
   | ExpLetRec { binders :: List (Name, Abs), body :: Exp }
   | ExpContinue Val (List Val)
-  | ExpIf Val Exp Exp
+  | ExpIf Val Name Name
   | ExpApply
     { op :: Val
     , args :: List Val
-    , cont :: Name
+    , cont :: Kexp
     }
   deriving (Show, Generic, Data, Eq)
 
+data Kexp
+  = KexpVar Name
+  | KexpKappa Kappa
+  deriving (Show, Generic, Data, Eq)
+
 pattern Halt :: List Val -> Exp
 pattern Halt xs = ExpContinue (ValLabel "halt") xs
 
@@ -127,6 +193,22 @@ data Program = MkProgram
   }
   deriving (Show, Generic, Data)
 
+data HoistedProgram = MkHoistedProgram
+  { bindings :: HashMap Label Abs
+  , body :: Lambda
+  }
+  deriving stock (Show, Generic, Data)
+
+type instance Index HoistedProgram = Label
+type instance IxValue HoistedProgram = Abs
+
+instance Ixed HoistedProgram where ix j = #bindings . ix j
+
+instance At HoistedProgram where at j = #bindings . at j
+
+instance Each HoistedProgram HoistedProgram Abs Abs where
+  each = #bindings . each
+
 makePrisms ''Kappa
 makePrisms ''Exp
 makeFieldsId ''Exp
@@ -150,6 +232,21 @@ _AbsLambda' = prism'
 
 instance Plated Exp where plate = uniplate
 
+absBody :: Lens' Abs Exp
+absBody = lens
+  (\case
+    AbsLambda lam -> lam.body
+    AbsKappa kap -> kap.body)
+  (\cases
+    (AbsLambda lam) b -> AbsLambda $ lam & #body .~ b
+    (AbsKappa kap) b -> AbsKappa $ kap & #body .~ b)
+
+unhoist :: HoistedProgram -> Program
+unhoist p =
+  MkProgram $ p.body & body %~ ExpLetRec
+    (p ^.. #bindings . itraversed . withIndex
+      . to (\(MkLabel l, ab) -> (l,ab)))
+
 
 -- DatumIso instances
 
@@ -169,29 +266,44 @@ instance S.DatumIso Imm where
   datumIso = S.match
     $ S.With (. S.int)
     $ S.With (. S.datumIso)
-    $ S.With (. labelName)
+    $ S.With (. S.datumIso)
     $ S.With (. S.unreadable (const "#<undefined>"))
     $ S.End
 
-labelName :: S.DatumGrammar Name
+instance S.DatumIso Label where
-labelName = S.coproduct
+  datumIso = S.with \g -> S.coproduct
-  [ S.decorate S.SynConstant >>> S.datumIso @Name >>> S.prismIso
+    [ S.decorate S.SynConstant >>> S.datumIso @Name >>> S.prismIso
-        (S.expected "label")
+          (S.expected "label")
-        (prefixed @Name "$")
+          (prefixed @Name "$")
-  , S.list $ S.el (S.sym "$") >>> S.el (S.datumIso @Name)
+    , S.list $ S.el (S.sym "$") >>> S.el (S.datumIso @Name)
-  ]
+    ]
+    >>> g
+
+instance S.DatumIso Reg where
+  datumIso = S.with \g ->
+    S.decorate S.SynVariable >>> S.datumIso @Name >>> S.prismIso
+      (S.expected "register")
+      (prefixed @Name "%")
+    >>> g
 
 instance S.DatumIso Hob where
   datumIso = S.match
     $ S.With (. closure)
+    $ S.With (. cont)
     $ S.With (. conspair)
     $ S.End
     where
       conspair = S.dottedList (S.el S.datumIso) S.datumIso
       -- closures can be printed, but not parsed.
-      closure :: G (Datum :- t) (List Obj :- Name :- t)
+      closure :: G (Datum :- t) (List Obj :- Label :- t)
       closure = IG.Flip $ IG.PartialIso
-        (\(env:-code:-t) -> S.Unreadable "#<procedure>" :- t)
+        (\(env:-code:-t) -> S.Unreadable [i|\#<procedure $#{code}>|] :- t)
+        (const . Left $ mempty)
+      cont :: G (Datum :- t) (NonEmpty (List Obj) :- _ :- t)
+      cont = IG.Flip $ IG.PartialIso
+        (\(_ :- l :- t) -> 
+          let x = S.encodeOrShow' @Text S.datumIso l
+          in S.Unreadable [i|\#<continuation #{x}>|] :- t)
         (const . Left $ mempty)
 
 instance S.DatumIso Lambda where
@@ -238,30 +350,51 @@ instance S.DatumIso Exp where
       if_ = S.ifLike "if"
         S.datumIso S.datumIso S.datumIso
       app :: forall t.
-        G (Datum :- t) (Name :- ([Val] :- (Val :- t)))
+        G (Datum :- t) (Kexp :- List Val :- Val :- t)
-      app = S.list $ S.el (S.datumIso @Val)
+      app = S.list $
-        -- >>> S.flipped Gyehoek.Datum.nonEmptyGrammar
+        S.flipped (S.PartialIso
+          (\(S.MkListContext ctx :- t) ->
+            case ctx of
+              f:kexp:xs -> S.MkListContext (f : snoc xs kexp) :- t
+              _ -> error "unreachable")
+          (\(S.MkListContext ctx :- t) ->
+            case unsnoc ctx of
+              Just (f:xs,kexp) -> Right $ S.MkListContext (f:kexp:xs) :- t
+              _ -> Left $ S.expected "continuation arg"))
+        >>> S.el (S.datumIso @Val)
+        >>> S.el (S.datumIso @Kexp)
         >>> S.rest (S.datumIso @Val)
-        -- >>> _
+        >>> S.onTail S.swap
-        >>> S.onTail (S.flipped $ IG.PartialIso
-                      (\(karg :- args :- op :- t) ->
-                         (args ++ [ValVar karg]) :- op :- t)
-                      (\(xs :- op :- t) -> case xs ^? _Snoc of
-                          Just (args,preview #ValVar -> Just karg) ->
-                            Right $ karg:- args :- op :- t
-                          _ -> Left $ S.expected "continuation arg"
-                      ))
-      -- prim = S.headTagged2 "prim"
-      --   (primDatumIso id (S.datumIso @Val))
-      --   (S.datumIso @Kappa)
       prim = S.list $
         S.el (S.decorate S.SynBuiltin >>> S.sym "prim")
         >>> S.el (primDatumIso id (S.datumIso @Val))
         >>> S.el S.datumIso
 
+instance S.DatumIso Kexp where
+  datumIso = S.match
+    $ S.With (S.datumIso @Name >>>)
+    $ S.With (S.datumIso @Kappa >>>)
+    $ S.End
+
 instance S.DatumIso Program where
   datumIso = S.with \prog -> S.datumIso @Lambda >>> prog
 
+-- the printed representation is pretty dishonest in its current
+-- state. consider the following hoisted program:
+-- 
+--  (letrec ((k (κ () (continue start-ktail 123))))
+--    (λ (start-ktail)
+--      (continue k)))
+-- 
+-- here, `start-ktail` is bound in `k`, but the printed representation
+-- fails to reflect that.
+instance S.DatumIso HoistedProgram where
+  datumIso = S.with \prog ->
+    S.letLike "letrec"
+      (S.datumIso @Label) (S.datumIso @Abs) (S.datumIso @Lambda)
+    >>> S.onTail (S.iso H.fromList H.toList)
+    >>> prog
+
 
 -- quasiquoters
 
@@ -274,6 +407,7 @@ instance CPS Kappa where toCPS = S.fromDatumUnsafe S.datumIso
 instance CPS Lambda where toCPS = S.fromDatumUnsafe S.datumIso
 instance CPS Abs where toCPS = S.fromDatumUnsafe S.datumIso
 instance CPS Program where toCPS = S.fromDatumUnsafe S.datumIso
+instance CPS HoistedProgram where toCPS = S.fromDatumUnsafe S.datumIso
 
 cps :: S.QuasiQuoter
 cps = S.makeSx' [| toCPS |]
@@ -296,7 +430,8 @@ class Free a where
   freeWithBound :: HashSet Name -> a -> HashSet Name
   freeWithBound bound = HS.fromList . freeWithBound' bound
 
-  -- | Free variables given in the order of their appearance.
+  -- | Free variables given in the same left-to-right order they
+  -- appear.
   free' :: a -> List Name
   free' = freeWithBound' mempty
 
@@ -306,11 +441,21 @@ instance Free Abs where
   freeWithBound' bound (AbsKappa kap) = freeWithBound' bound kap
   freeWithBound' bound (AbsLambda lam) = freeWithBound' bound lam
 
+mif :: Alternative f => (a -> Bool) -> a -> f a
+mif p a
+  | p a = pure a
+  | otherwise = empty
+
+instance Free Kexp where
+  freeWithBound' bound = \case
+    KexpVar x -> mif (`notElem` bound) x
+    KexpKappa kap -> freeWithBound' bound kap
+
 instance Free Exp where
   freeWithBound' bound = \case
     ExpPrim p k ->
-      p & toListOf (folded . #ValVar . filtered (`notElem` bound))
+      (p ^.. folded . #ValVar . filtered (`notElem` bound))
-        & (<> freeWithBound' bound k)
+      ++ freeWithBound' bound k
     ExpLetRec bs m ->
       foldMapOf (each . _2) (freeWithBound' bound') bs
       <> freeWithBound' bound' m
@@ -318,10 +463,10 @@ instance Free Exp where
     ExpContinue k xs -> filter (`notElem` bound) ((k:xs) ^.. each . #ValVar)
     ExpIf c t f ->
       (c ^.. #ValVar . filtered (`notElem` bound))
-      <> freeWithBound' bound t <> freeWithBound' bound f
+      <> mif (`notElem` bound) t <> mif (`notElem` bound) f
     ExpApply f xs k ->
       (f:xs) ^.. (each . #ValVar . filtered (`notElem` bound))
-      <> (k ^.. filtered (`notElem` bound))
+      <> freeWithBound' bound k
 
 instance Free Kappa where
   freeWithBound' bound (MkKappa xs m) =

src/Gyehoek/Driver.hs

@@ -1,5 +1,5 @@
 module Gyehoek.Driver
-  (main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e)
+  (main, convert_e2e, parse_e2e, readScm, eval_cps1_e2e, eval_cps2_e2e)
   where
 
 import Gyehoek.Options
@@ -17,7 +17,6 @@ import qualified Data.Text.Encoding as T
 import System.IO (Handle)
 import System.IO qualified as IO
 import Gyehoek.CPS.Convert
-import Gyehoek.Stack.Lower
 import Gyehoek.CPS.Eval qualified as CPS
 import Control.Monad
 import Text.Pretty.Simple (pShowNoColor)
@@ -25,16 +24,14 @@ import System.Process.Typed
 import System.Environment.Blank (getEnvDefault)
 import qualified Data.Text.IO as TIO
 import qualified Data.ByteString.Lazy as BS
-import Gyehoek.CPS.Stackify (stackifyProgram)
-import Gyehoek.Stack.VM (eval, writeObj, Obj, traceEval)
 import qualified Data.Text as T
-import Gyehoek.Stack.Syntax qualified as Stk
 import Gyehoek.CPS.Close (closeProgram)
 import Control.Lens.Extras (is)
 import Control.Arrow ((>>>))
 import Gyehoek.Prelude
 import Gyehoek.Jalmot
 import qualified Gyehoek.Sexp as S
+import Gyehoek.CPS.Hoist (hoistProgram)
 
 
 main :: IO ()
@@ -118,29 +115,20 @@ driver opts = do
     hPutStrLn FS.stdout . view strict . pShowNoColor $ scm
   cps <- convertProgram scm
   when opts.dumpCPS do
-     hPutStrLn FS.stdout =<< S.encodeWith S.datumIso cps
+     S.writeDatum cps
   closedCps <- closeProgram cps
   when opts.dumpClosed do
-    hPutStrLn FS.stdout =<< S.encodeWith S.datumIso closedCps
+    S.writeDatum closedCps
+  hoistedCps <- hoistProgram closedCps
+  when opts.dumpHoisted do
+    S.writeDatum hoistedCps
   let rt_is p = is (_Just . p) opts.runtime
-  dumpOrRun opts.dumpStackified (rt_is #Stackify)
+  when (rt_is #HigherOrderCPS) do
-    (stackifyProgram closedCps)
+    CPS.evalProgram cps
-    (hPutStrLn FS.stdout <=< S.encodeDataWith S.dataIso)
+      >>= S.writeData
-    (eval >=> fmap writeObj
-         >>> T.unwords
-         >>> hPutStrLn FS.stdout)
   when (rt_is #CPS) do
-    closedCps
+    CPS.evalProgram closedCps
-      & CPS.evalProgram
+      >>= S.writeData
-      & fmap writeObj
-      & T.unwords
-      & hPutStrLn FS.stdout
-  -- dumpOrRun opts.inspectWasm (rt_is #Wasm)
-  --   (lowerProgram cps)
-  --   inspectWasm
-  --   (\wat -> withFile opts.output FS.WriteMode \h -> hPutStrLn h wat)
-  when opts.traceStackified do
-    stackifyProgram closedCps >>= traceEval
 
 parse_e2e :: FilePath -> IO Scm.Program
 parse_e2e = runJalmotIO . runFileSystem . readScm
@@ -149,12 +137,18 @@ convert_e2e :: FilePath -> IO CPS.Program
 convert_e2e = runJalmotIO . runFileSystem . runGenSym
   . (closeProgram <=< convertProgram <=< readScm)
 
-lower_e2e :: FilePath -> IO Text
+eval_cps1_e2e :: FilePath -> IO Text
-lower_e2e =
+eval_cps1_e2e fp = runJalmotIO . runFileSystem . runGenSym $
-  runJalmotIO . runFileSystem . runGenSym
+  readScm fp
-  . (lowerProgram <=< closeProgram <=< convertProgram <=< readScm)
+   >>= convertProgram
+   >>= closeProgram
+   >>= CPS.evalProgram
+   >>= pure . S.encodeOrShowData' S.dataIso
 
-eval_e2e :: FilePath -> IO (List Obj)
+eval_cps2_e2e :: FilePath -> IO Text
-eval_e2e fp = runJalmotIO . runFileSystem . runGenSym $ do
+eval_cps2_e2e fp = runJalmotIO . runFileSystem . runGenSym $
-  stk <- stackifyProgram <=< closeProgram <=< convertProgram <=< readScm $ fp
+  readScm fp
-  eval stk
+   >>= convertProgram
+   -- >>= closeProgram
+   >>= CPS.evalProgram
+   >>= pure . S.encodeOrShowData' S.dataIso

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/Language.hs

@@ -0,0 +1,4 @@
+module Gyehoek.Language
+  (
+  ) where
+

src/Gyehoek/Options.hs

@@ -13,14 +13,13 @@ import Data.Foldable
 import Gyehoek.Prelude hiding (argument)
 
 
-data Runtime = Stackify | Wasm | CPS
+data Runtime = Wasm | CPS | HigherOrderCPS
   deriving (Show, Generic, Eq)
 
 data Language
   = LanguageScheme
   | LanguageCPS
   | LanguageClosed
-  | LanguageStackified
   | LanguageWasm
   deriving (Show, Generic, Eq)
 
@@ -28,30 +27,30 @@ data Options = MkOptions
   { dumpClosed :: Bool
   , dumpCPS :: Bool
   , dumpParsed :: Bool
-  , dumpStackified :: Bool
+  , dumpHoisted :: Bool
-  , traceStackified :: Bool
+  , noColour :: Bool
   , runtime :: Maybe Runtime
   , inspectWasm :: Bool
   , output :: FilePath
   , sourceFile :: FilePath
   , sourceLanguage :: Language
+  , targetLanguage :: Language
   }
   deriving (Show, Generic)
 
-languageValues = ["scheme","cps","closed","stackified","wasm"]
+languageValues = ["scheme","cps","closed","wasm"]
 languageReader = maybeReader \case
   "scheme" -> Just LanguageScheme
   "cps" -> Just LanguageCPS
   "closed" -> Just LanguageClosed
-  "stackified" -> Just LanguageStackified
   "wasm" -> Just LanguageWasm
   _ -> Nothing
 
 runtimeValues = ["stackify","wasm","cps","none"]
 runtimeReader = maybeReader \case
-  "stackify" -> Just (Just Stackify)
   "wasm" -> Just (Just Wasm)
-  "cps" -> Just (Just CPS)
+  "cps1" -> Just (Just CPS)
+  ("cps";"higher-order-cps") -> Just (Just HigherOrderCPS)
   "none" -> Just Nothing
   _ -> Nothing
 
@@ -59,16 +58,19 @@ parser :: Parser Options
 parser = do
   dumpClosed <- switch (long "dump-closed")
   dumpCPS <- switch (long "dump-cps")
-  dumpStackified <- switch (long "dump-stackified")
   dumpParsed <- switch (long "dump-parsed")
-  traceStackified <- switch (long "trace-stackified")
+  dumpHoisted <- switch (long "dump-hoisted")
+  noColour <- switch . fold $
+    [ long "no-colour"
+    , long "no-color"
+    ]
   inspectWasm <- switch $ long "inspect-wasm" <> short 'p'
   runtime <- option runtimeReader . fold $
     [ long "runtime"
     , short 'R'
-    , value (Just Stackify)
+    , value (Just HigherOrderCPS)
     , completeWith runtimeValues
-    , showDefaultWith $ const "stackify"
+    , showDefaultWith $ const "higher-order-cps"
     , metavar "RUNTIME"
     ]
   sourceLanguage <- option languageReader . fold $
@@ -79,6 +81,14 @@ parser = do
     , showDefaultWith $ const "scheme"
     , metavar "LANGUAGE"
     ]
+  targetLanguage <- option languageReader . fold $
+    [ long "target"
+    , short 'T'
+    , value LanguageCPS
+    , completeWith languageValues
+    , showDefaultWith $ const "cps"
+    , metavar "LANGUAGE"
+    ]
   output <- strOption . fold $
     [ long "output"
     , short 'o'

src/Gyehoek/Prelude.hs

@@ -19,6 +19,7 @@ module Gyehoek.Prelude
   , (>>>)
   , (>=>)
   , (<=<)
+  , wrappedIso
   ) where
 
 import Control.Lens hiding (List, (:<))
@@ -40,4 +41,5 @@ import Data.List.NonEmpty (NonEmpty((:|)))
 import Numeric.Natural (Natural)
 import Control.Category ((>>>))
 import Control.Monad
+import Data.Generics.Wrapped (Wrapped(..))
 

src/Gyehoek/Scheme/Syntax.hs

@@ -10,6 +10,7 @@
 {-# LANGUAGE OrPatterns #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE ViewPatterns #-}
 module Gyehoek.Scheme.Syntax
   ( Name(..)
   , Prim(..)
@@ -53,6 +54,8 @@ import Gyehoek.Sexp.Grammar qualified as Sexp
 import Gyehoek.Sexp.Grammar qualified as S
 import Gyehoek.Sexp.Grammar (DatumIso, G, DataIso, (:-)((:-)))
 import Gyehoek.Prelude
+import Control.Lens.Extras (is)
+import qualified Data.Scientific as Sci
 
 
 newtype Name = MkName { inner :: Text }
@@ -81,11 +84,17 @@ data Prim e
   | PrimZeroP e
   | PrimNewline
   | PrimMakeClosure { code :: e, env :: List e }
-  | PrimEnvRef e Int
+  | PrimMakeSharedClosure { codes :: List e, env :: List e }
-  | PrimEnvCode e
+  | PrimGetEnv
+  | PrimEnv
+  | PrimEnvRef Int
   | PrimCallCC e
+  | PrimCaptureCC
+  | PrimInvokeCC e (List e)
   | PrimValues (List e)
   | PrimCallWithValues e e
+  | PrimPairP e
+  | PrimList (List e)
   deriving stock (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
   deriving anyclass (NFData)
 
@@ -124,8 +133,37 @@ data CommandOrDef
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
-newtype Program = MkProgram
+newtype LibName = MkLibName { inner :: NonEmpty Name }
-  { commandsAndDefs :: List CommandOrDef
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+data ImportSet
+  = ImportLib LibName
+  | ImportOnly ImportSet (NonEmpty Name)
+  | ImportExcept ImportSet (NonEmpty Name)
+  | ImportPrefix ImportSet Name
+  | ImportRename ImportSet (NonEmpty (Name, Name))
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+newtype ImportDecl = MkImportDecl (NonEmpty ImportSet)
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+data LibDecl
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+data Lib = MkLib
+  { name :: LibName
+  , decls :: List LibDecl
+  }
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+data Program = MkProgram
+  { imports :: List ImportDecl
+  , commandsAndDefs :: List CommandOrDef
   }
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
@@ -164,17 +202,25 @@ primDatumIso namefn a = S.match
     $ S.With (. ht1 "integer?")
     $ S.With (. ht1 "write")
     $ S.With (. ht1 "zero?")
-    $ S.With (. nullop "newline")
+    $ S.With (. ht0 "newline")
     $ S.With (. ht1' "make-closure")
-    $ S.With (. S.headTagged2 (namefn "env-ref") a S.int)
+    $ S.With (. S.headTagged2 (namefn "make-shared-closure")
-    $ S.With (. ht1 "env-code")
+      (S.list $ S.rest a)
+      (S.list $ S.rest a))
+    $ S.With (. ht0 "get-env")
+    $ S.With (. ht0 "env")
+    $ S.With (. S.headTagged1 (namefn "env-ref") S.int)
     $ S.With (. ht1 "call/cc")
+    $ S.With (. ht0 "capture/cc")
+    $ S.With (. ht1' "invoke/cc")
     $ S.With (. ht0' "values")
     $ S.With (. ht2 "call-with-values")
+    $ S.With (. ht1 "pair?")
+    $ S.With (. ht0' "list")
     $ S.End
     where
       idn = S.el . S.sym . namefn
-      nullop s = S.list $ idn s
+      ht0 s = S.list $ idn s
       ht1 s = S.headTagged1 (namefn s) a
       ht2 s = S.headTagged2 (namefn s) a a
       ht1' s = S.headTagged1' (namefn s) a a
@@ -230,8 +276,58 @@ instance DatumIso CommandOrDef where
     $ S.With (\_Begin -> _Begin . S.beginLike "begin" (S.rest S.datumIso))
     $ S.End
 
+instance DatumIso LibName where
+  datumIso = S.with \g ->
+    S.list (S.restData $ S.nonEmptyData comp)
+    >>> g
+    where
+      comp = S.partialOsi
+        (\case
+          S.Symbol s -> Right $ MkName s
+          S.Number (Sci.floatingOrInteger @Double @Int -> Right n)
+            | n > 0 -> Right $ MkName [i|#{n}|]
+          _ -> Left $ S.expected "library name part"
+          )
+        \(MkName s) -> S.Symbol s
+
+instance DatumIso ImportSet where
+  datumIso = S.match
+    $ S.With (S.datumIso @LibName >>>)
+    $ S.With (imp "only" >>>)
+    $ S.With (imp "except" >>>)
+    $ S.With (imp' "prefix" >>>)
+    $ S.With (imp "rename" >>>)
+    $ S.End
+    where
+      imp s = S.list $ S.el (S.symBuiltin s)
+        >>> S.el S.datumIso >>> S.restData S.dataIso
+      imp' s = S.list $
+        S.el (S.symBuiltin s)
+        >>> S.el S.datumIso
+        >>> S.el S.datumIso
+
+instance DatumIso ImportDecl where
+  datumIso = S.with \decl ->
+    S.list (S.el (S.symBuiltin "import") >>> S.restData S.dataIso)
+    >>> decl
+
 instance DataIso Program where
-  dataIso = S.dataIso @(List CommandOrDef) >>> S.iso coerce coerce
+  dataIso = S.with \g ->
+    splitG
+    >>> S.onHead (S.sealed S.dataIso)
+    >>> S.onTail (S.onHead . S.sealed $ S.dataIso)
+    >>> g
+    where
+      isImport = \case
+        S.List (S.Symbol "import" : _) -> True
+        _ -> False
+      splitG :: G (List S.Datum :- t) (List S.Datum :- List S.Datum :- t)
+      splitG = S.Iso
+        (\(xs:-t) ->
+          let (ys,zs) = span isImport xs
+          in zs :- ys :- t
+        )
+        \(zs:-ys:-t) -> (ys ++ zs) :- t
 
 
 -- utilities

src/Gyehoek/Sexp/Grammar.hs

@@ -15,6 +15,7 @@ module Gyehoek.Sexp.Grammar
   , encodeDataTest
   , encodeDataTestColour
   , encodeOrShow'
+  , encodeOrShowData'
   , decodeDataWith
   , encodeDataWith'
   , decodeTest
@@ -28,6 +29,8 @@ module Gyehoek.Sexp.Grammar
   , fromDatumUnsafe
   , Control.Category.id
   , fromDataUnsafe
+  , writeDatum
+  , writeData
   )
   where
 
@@ -45,6 +48,8 @@ import qualified Control.Category
 import qualified Data.Vector as V
 import Data.String (IsString (fromString))
 import qualified Data.Text as T
+import System.Environment (lookupEnv)
+import Data.Foldable (toList)
 
 
 toDatum :: Jalmot :> es => DatumGrammar a -> a -> Eff es Datum
@@ -126,6 +131,39 @@ encodeOrShow' g x = fromString $
     Left _ -> show x
     Right t -> T.unpack t
 
+encodeOrShow :: (IsString s, Show a) => DatumGrammar a -> a -> s
+encodeOrShow g x = fromString $
+  case runPureEff . runJalmot . encodeWith g $ x of
+    Left _ -> show x
+    Right t -> T.unpack t
+
+encodeOrShowData' :: (IsString s, Show a) => DataGrammar a -> a -> s
+encodeOrShowData' g x = fromString $
+  case runPureEff . runJalmot . encodeDataWith' g $ x of
+    Left _ -> show x
+    Right t -> T.unpack t
+
+encodeOrShowData :: (IsString s, Show a) => DataGrammar a -> a -> s
+encodeOrShowData g x = fromString $
+  case runPureEff . runJalmot . encodeDataWith g $ x of
+    Left _ -> show x
+    Right t -> T.unpack t
+
+useColour :: IO Bool
+useColour = maybe True (const False) <$> lookupEnv "NO_COLOR"
+
+writeDatum :: (Show a, DatumIso a, MonadIO m) => a -> m ()
+writeDatum x = do
+  c <- liftIO useColour 
+  let f = if c then encodeOrShow else encodeOrShow'
+  liftIO . TIO.putStrLn . f datumIso $ x
+
+writeData :: (Show a, DataIso a, MonadIO m) => a -> m ()
+writeData x = do
+  c <- liftIO useColour 
+  let f = if c then encodeOrShowData else encodeOrShowData'
+  liftIO . TIO.putStrLn . f dataIso $ x
+
 class DatumIso a where
   datumIso :: DatumGrammar a
 
@@ -150,5 +188,8 @@ instance DatumIso a => DataIso (V.Vector a) where
   dataIso = iso fromList V.toList
     >>> (onHead . traversed . sealed $ datumIso @a)
 
+instance DatumIso a => DataIso (NonEmpty a) where
+  dataIso = nonEmptyData datumIso
+
 instance (DatumIso a, DatumIso b) => DatumIso (a, b) where
   datumIso = with \tup2 -> list (el datumIso >>> el datumIso) >>> tup2

src/Gyehoek/Sexp/Grammar/Base.hs

@@ -9,7 +9,7 @@ module Gyehoek.Sexp.Grammar.Base
   , DatumGrammar
   , DataGrammar
   , Grammar
-  , ListContext
+  , ListContext(..)
   , (:-)((:-))
   -- * lists
   , list
@@ -17,6 +17,7 @@ module Gyehoek.Sexp.Grammar.Base
   , el
   , rest
   , restData
+  , nonEmptyData
   , headTagged0'
   , headTagged0
   , headTagged1'
@@ -32,6 +33,8 @@ module Gyehoek.Sexp.Grammar.Base
   , integer
   , int
   , unreadable
+  -- ** symbols
+  , symBuiltin
   -- * TODO: sort lol
   , prismIso
   , isoIso, decorate
@@ -49,7 +52,7 @@ import Data.InvertibleGrammar.Base
 import Data.InvertibleGrammar.Base as Re
   ( Grammar(..))
 import Data.InvertibleGrammar.Combinators
-import Gyehoek.Prelude hiding (iso, cons, coerced, Iso, Simple, simple)
+import Gyehoek.Prelude hiding (traversed, iso, cons, coerced, Iso, Simple, simple)
 import Gyehoek.Sexp.Syntax hiding (position)
 import Gyehoek.Sexp.Print (printDatum')
 import Data.Scientific (Scientific)
@@ -57,6 +60,7 @@ import qualified Data.Scientific as Sci
 import qualified Data.Text as T
 import Control.Monad.RWS (modify)
 import qualified Data.List.NonEmpty as NE
+import Data.Foldable (toList)
 
 
 -- $setup
@@ -107,7 +111,17 @@ list
 list = listWithIndentation Ordinary
 
 -- |
--- >>> decodeTest @(Int,Int) (with \g -> dottedList (el int) int >>> g) "(1 . 2)"
+-- >>> let grammar = with \g -> dottedList (el int) int >>> g
+-- >>> decodeTest @(Int,Int) grammar "(1 . 2)"
+-- ( 1
+-- , 2
+-- )
+-- >>> let grammar = with \g -> dottedList (el int >>> el int) int >>> g
+-- >>> decodeTest @(Int,Int,Int) grammar "(1 2 . 3)"
+-- ( 1
+-- , 2
+-- , 3
+-- )
 dottedList
   :: forall t t' t''. G (ListContext :- t) (ListContext :- t')
   -> G (Datum :- t') t''
@@ -228,6 +242,14 @@ restData g =
   >>> g
   >>> push (MkListContext []) (const True) mempty
 
+nonEmptyData :: DatumGrammar a -> DataGrammar (NonEmpty a)
+nonEmptyData g = partialOsi
+    (\case
+      [] -> Left $ expected "non-empty sequence"
+      x:xs -> Right $ x:|xs)
+    toList
+  >>> (onHead . traversed . sealed $ g)
+
 snoced
   :: Snoc s s a a
   => Grammar p (s :- a :- t) (s :- t)

src/Gyehoek/Stack/Lower.hs

@@ -1,29 +0,0 @@
-module Gyehoek.Stack.Lower
-  ( lowerProgram
-  ) where
-
-import Gyehoek.Stack.Syntax
-import Gyehoek.Wasm qualified as Wasm
-import Gyehoek.Prelude
-import Gyehoek.Wasm (wat, watM)
-
-
-lowerRoutine :: Routine -> Wasm.Function
-lowerRoutine rt = _
-
-lowerBlock :: Block -> Wasm.Expr
-lowerBlock = _
-
-lowerInstr :: Instr -> Wasm.Expr
-lowerInstr = \case
-  -- PopCont ktail -> [wat|
-    
-  -- |]
-
-lowerProgram :: Program -> Eff es Wasm.Module
-lowerProgram p = pure [watM|
-  (module
-    ##{rs})
-|]
-  where
-    rs = p ^.. #routines . each . to lowerRoutine

src/Gyehoek/Stack/Syntax.hs

@@ -1,141 +0,0 @@
-{-# LANGUAGE TemplateHaskellQuotes #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE DeriveAnyClass #-}
-module Gyehoek.Stack.Syntax
-  ( Program(..)
-  , Routine(..)
-  , Instr(..)
-  , Block(..)
-  , Tail(..)
-  , Val(..)
-  , Lit(..)
-  , Obj(..)
-  , Imm(..)
-  , Hob(..)
-  , Prim(..)
-  , Name
-  , pattern ValLabel
-  , stkP
-  ) where
-
-import Control.Lens
-import qualified Gyehoek.Sexp as S
-import Gyehoek.Scheme.Syntax (Name(..), Lit(..), Prim(..))
-import GHC.Exts (IsList(..))
-import Data.List (intersperse)
-import Gyehoek.CPS.Syntax (Imm(..), Obj(..), Hob(..), labelName)
-import Gyehoek.Prelude
-import Gyehoek.Sexp ((:-)((:-)))
-
-
-newtype Program = MkProgram
-  { routines :: HashMap Name Routine
-  }
-  deriving stock (Show, Generic, Data)
-  deriving newtype (Semigroup, Monoid)
-  deriving anyclass (NFData)
-
-instance IsList Program where
-  type Item Program = Routine
-  fromList rs = MkProgram
-    { routines = fromList [ (r.label, r) | r <- rs ]
-    }
-  toList = toListOf $ #routines . each
-
-data Routine = MkRoutine
-  { label :: Name
-  , params :: List Name
-  , start :: Block
-  }
-  deriving stock (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-data Block = MkBlock
-  { code :: List Instr
-  , tail :: Tail
-  }
-  deriving stock (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-data Tail
-  = TailCall Val (List Val)
-  | If Val Block Block
-  deriving stock (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-data Instr
-  = Pop Name
-  | Push Val
-  | Prim Name (Prim Val)
-  deriving stock (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-data Val
-  = ValReg Name
-  | ValImm Imm
-  deriving stock (Show, Generic, Data, Eq)
-  deriving anyclass (NFData)
-
-pattern ValLabel :: Name -> Val
-pattern ValLabel x = ValImm (ImmLabel x)
-
-
---- sexp work
-
-pure []
-
-instance S.DatumIso Instr where
-  datumIso = S.match
-    $ S.With (S.headTagged1 "pop!" regName >>>)
-    $ S.With (S.headTagged1 "push!" S.datumIso >>>)
-    $ S.With (S.headTagged2 "prim" regName S.datumIso >>>)
-    $ S.End
-    where
-
-instance S.DataIso Block where
-  dataIso = S.with \g ->
-    S.flipped S.snoced
-    >>> S.onHead (S.traversed $ S.sealed S.datumIso)
-    >>> S.onTail (S.datumIso @Tail)
-    >>> S.swap
-    >>> g
-
-instance S.DatumIso Tail where
-  datumIso = S.match
-    $ S.With (S.headTagged1' "tail-call" S.datumIso S.datumIso >>>)
-    $ S.With (if_ >>>)
-    $ S.End
-    where
-      if_ = S.ifLike "if" (S.datumIso @Val) (branch "then") (branch "else")
-      branch :: Text -> S.DatumGrammar Block
-      branch s =
-        S.listWithIndentation (S.NSpecial 0) $
-            S.el (S.decorate S.SynBuiltin >>> S.sym s)
-            >>> S.restData (S.dataIso @Block)
-
-instance S.DatumIso Val where
-  datumIso = S.match
-    $ S.With (regName >>>)
-    $ S.With (S.datumIso >>>)
-    $ S.End
-
-instance S.DatumIso Routine where
-  datumIso = S.with \rout ->
-      S.listWithIndentation (S.NSpecial 1)
-       ( S.el (S.decorate S.SynBuiltin >>> S.sym "define")
-       >>> S.el (S.list $ S.el labelName >>> S.rest regName)
-       >>> S.restData (S.dataIso @Block)
-       )
-      >>> rout
-
-regName :: S.DatumGrammar Name
-regName = S.decorate S.SynVariable >>> S.datumIso @Name >>> S.prismIso
-  (S.expected "register")
-  (prefixed @Name "%")
-
-instance S.DataIso Program where
-  dataIso = S.dataIso @(List Routine) >>> S.iso fromList toList
-
-stkP :: S.QuasiQuoter
-stkP = S.makeSxs [|| S.fromDataUnsafe (S.dataIso @Program) ||]

src/Gyehoek/Stack/VM.hs

@@ -1,289 +0,0 @@
-{-# LANGUAGE ViewPatterns, MultilineStrings #-}
-module Gyehoek.Stack.VM
-  ( VM(..)
-  , Env(..)
-  , eval
-  , trace
-  , module Gyehoek.Stack.Syntax
-  , writeObj
-  , traceEval
-  ) where
-
-import Gyehoek.Stack.Syntax
-import Control.Lens
-import qualified Data.HashMap.Strict as H
-import Data.List (unfoldr, intersperse)
-import Gyehoek.Prelude
-import qualified Data.List.NonEmpty as NE
-import Lucid
-import Data.Foldable (traverse_)
-import qualified Gyehoek.Sexp as S
-import Gyehoek.Jalmot
-import Text.Pretty.Simple (pStringNoColor, pShowNoColor)
-import Effectful.State.Static.Local (runState, evalState, get)
-import Data.Traversable
-import Control.Applicative (Alternative(..))
-import Gyehoek.Sexp.Print (htmlData)
-import Control.DeepSeq (deepseq, ($!!))
-import Gyehoek.Sexp.Print (htmlData, htmlDatum)
-import Control.DeepSeq (deepseq, ($!!))
-import Data.String (fromString)
-
-
--- | inessential information maintained only to aide in debugging.
-data DebugVM = MkDebugVM
-  { currentRoutine :: Name
-  }
-  deriving (Show, Generic)
-
-data VM = MkVM
-  { stack :: List Obj
-  , code :: List Instr
-  , tail :: Tail
-  , registers :: HashMap Name Obj
-  , stdout :: Text
-  , result :: Maybe (List Obj)
-  , debug :: DebugVM
-  }
-  deriving (Show, Generic)
-
-data Env = MkEnv
-  { labels :: HashMap Name Routine
-  }
-  deriving (Show, Generic)
-
-step :: Jalmot :> es => Env -> VM -> Eff es VM
-step g vm = case vm ^. #code of
-  c:cs -> stepI g (vm & #code .~ cs) c
-  [] -> stepT g vm vm.tail
-
-vmerror :: (HasCallStack, Jalmot :> es) => Text -> Eff es a
-vmerror = throwError . VMError
-
-stepI :: Jalmot :> es => Env -> VM -> Instr -> Eff es VM
-
-stepI e vm (Push v) = traverseOf #stack push vm
-  where push xs = (:) <$> evalVal e vm v <*> pure xs
-
-stepI e vm (Prim r p) = traverse (evalVal e vm) p >>= \case
-  PrimZeroP x -> case x of
-    ObjImm (ImmInt n) -> ret . ObjImm . ImmBool $ n == 0
-    _ -> vmerror [i|bad arg to zero?: #{x}|]
-  PrimAdd x y -> arith_binop (+) x y
-  PrimMul x y -> arith_binop (*) x y
-  PrimSub x y -> arith_binop (-) x y
-  PrimDiv x y -> arith_binop div x y
-  PrimMakeClosure f env ->
-    case f of
-      ObjImm (ImmLabel l) -> ret . ObjHob $ HobClosure l env
-      _ -> vmerror [i|expected label, got #{f}|]
-  PrimEnvCode env ->
-    case env of
-      ObjHob (HobClosure l _) -> ret . ObjImm . ImmLabel $ l
-      _ -> vmerror [i|expected closure, got #{env}|]
-  PrimEnvRef env n ->
-    case env of
-      ObjHob (HobClosure _ xs) -> ret $ xs ^?! ix n
-      _ -> vmerror [i|expected closure, got #{env}|]
-  PrimCons x y -> ret $ ObjHob $ HobPair x y
-  PrimCar x -> case x of
-      ObjHob (HobPair car _) -> ret car
-      _ -> vmerror [i|expected pair, got ${x}|]
-  PrimCdr x -> case x of
-      ObjHob (HobPair _ cdr) -> ret cdr
-      _ -> vmerror [i|expected pair, got ${x}|]
-  x -> vmerror [i|unimplemented prim: #{p}|]
-  where
-    ret v = pure $ vm & #registers . at r ?~ v
-    arith_binop op (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) =
-      ret $ ObjImm (ImmInt (op x y))
-    arith_binop _ x y = vmerror [i|bad arith: #{x}, #{y}|]
-
-stepI e vm (Pop r) = case vm ^. #stack of
-  [] -> vmerror "empty stack"
-  (x:xs) -> pure $ vm & #registers . at r ?~ x
-               & #stack .~ xs
-
-stepI e vm ins = vmerror [i|unimplemented instruction: #{ins}|]
-
-stepT :: Jalmot :> es => Env -> VM -> Tail -> Eff es VM
-
-stepT g vm (TailCall f xs) = do
-  xs' <- traverse (evalVal g vm) xs
-  evalToLabel g vm f >>= \case
-    "halt" -> pure $ vm & #result ?~ xs'
-    l -> do
-      rt <- case g ^. #labels . at l of
-          Nothing -> vmerror [i|undefined label: #{l}|]
-          Just x -> pure x
-      pure $ vm & #code .~ rt.start.code
-            & #tail .~ rt.start.tail
-            & #registers .~ H.fromList (rt.params `zip` xs')
-            & #debug . #currentRoutine .~ rt.label
-
-stepT g vm (If c t f) = do
-  branch <- evalVal g vm c <&> \case
-      ObjImm (ImmBool False) -> f
-      _ -> t
-  pure $ vm & #code .~ branch.code & #tail .~ branch.tail
-
-evalToLabel :: Jalmot :> es => Env -> VM -> Val -> Eff es Name
-evalToLabel e vm v =
-  evalVal e vm v >>= \case
-    ObjImm (ImmLabel x) -> pure x
-    x -> vmerror [i|not a label: #{x}|]
-
-evalVal :: Jalmot :> es => Env -> VM -> Val -> Eff es Obj
-evalVal e vm = \case
-  ValImm imm -> pure $ ObjImm imm
-  ValReg r -> case vm ^. #registers . at r of
-    Just x -> pure x
-    Nothing -> vmerror [i|undefined register: #{r}|]
-
-initialVM :: VM
-initialVM = MkVM
-  { stack = []
-  , code = []
-  , tail = TailCall (ValLabel "start") [ValLabel "halt"]
-  , registers = mempty
-  , stdout = ""
-  , result = Nothing
-  , debug = MkDebugVM
-    { currentRoutine = "<nowhere>"
-    }
-  }
-
-initialEnv :: Program -> Env
-initialEnv p = MkEnv
-  { labels = p.routines
-  }
-
-loop :: (a -> Either b a) -> a -> b
-loop f a = case f a of
-  Right a' -> loop f a'
-  Left b -> b
-
-loopM :: Monad m => (a -> m (Either b a)) -> a -> m b
-loopM f a = f a >>= \case
-  Right a' -> loopM f a'
-  Left b -> pure b
-
-eval :: Jalmot :> es => Program -> Eff es (List Obj)
-eval p = initialVM & loopM \vm -> case vm ^. #result of
-  Nothing -> Right <$> step (initialEnv p) vm
-  Just rs -> pure . Left $ rs
-
-data Trace
-  = Step { vm :: VM, next :: Trace }
-  | StepToSuccess { vm :: VM, result :: List Obj }
-  | StepToFailure { vm :: VM, err :: AJalmotCS }
-  deriving (Show)
-
-trace :: Program -> Trace
-trace p = go (initialEnv p) initialVM
-  where
-    go g vm =
-      case vm.result of
-        Just rs -> StepToSuccess vm rs
-        Nothing ->
-          case runPureEff . runJalmotCS $ step g vm of
-            Left err -> StepToFailure vm err
-            Right vm' -> Step vm (go g vm')
-
-writeObj :: Obj -> Text
-writeObj = runJalmotUnsafe . S.encodeWith' S.datumIso
-
-traceEval :: IOE :> es => Program -> Eff es ()
-traceEval p = do
-  let t = trace p
-  liftIO . renderToFile "trace.html" . ppDoc p $ t
-
-ppDoc :: Program -> Trace -> Html ()
-ppDoc p t =
-  html_ do
-    head_ do
-      title_ "stackify trace"
-      style_ """
-        pre {
-          max-width: 95vw;
-          overflow: scroll;
-        }
-        table {
-          max-width: 95vw;
-        }
-        tbody > tr:nth-of-type(even) {
-            background-color: rgb(237 238 242);
-        }
-        .loc {
-            font-size: 0.8rem;
-        }
-        .syn-builtin, .syn-macro {
-            color: purple;
-            font-style: italic;
-            font-weight: bold;
-        }
-        .syn-constant {
-            color: olive;
-        }
-        .syn-procedure {
-            color: teal;
-        }
-        .syn-paren-0 { color: maroon; }
-        .syn-paren-1 { color: olive; }
-        .syn-paren-2 { color: green; }
-        .syn-paren-3 { color: navy; }
-        .syn-paren-4 { color: purple; }
-      """
-    body_ do
-      details_ do
-        summary_ "stack code"
-        pre_ $ code_ do
-          htmlData . runJalmotUnsafe . S.toData S.dataIso $ p
-      ppTrace t
-
-ppTrace :: Trace -> Html ()
-ppTrace trace =
-  table_ do
-    thead_ $ tr_ do
-      traverse_ (th_ [scope_ "col"])
-        ["location","instruction","stack"]
-    tbody_ do
-      go trace
-  where
-    go :: Trace -> Html ()
-    go = \case
-      Step vm next -> ppVM vm >> go next
-      StepToSuccess vm rs -> do
-        ppVM vm
-        tr_ [colspan_ "3",class_ "trace-result"] do
-          sequence_ . intersperse " | " $ code_ . ppDatum <$> rs
-      StepToFailure vm err -> do
-        ppVM vm
-        tr_ [class_ "trace-failure"] do
-          td_ [colspan_ "3"] do
-            details_ do
-              summary_ "error"
-              pre_ do
-                samp_ do
-                  fromString $ displayException err
-
-ppVM :: VM -> Html ()
-ppVM vm = do
-  tr_ do
-    td_ do
-      details_ do
-        summary_ do
-          var_ [class_ "loc"] . toHtml $ vm ^. #debug . #currentRoutine
-            . re (_Unwrapped' . prefixed "$")
-        pre_ do
-          code_ . toHtml . pShowNoColor $ vm
-    td_ do
-      code_ curi
-    td_ do
-      let xs = code_ . ppDatum <$> (vm ^. #stack)
-      sequence_ $ intersperse " | " xs
-  where
-    curi = vm ^?! failing (#code . _head . to ppDatum) (#tail . to ppDatum)
-
-ppDatum :: S.DatumIso a => a -> Html ()
-ppDatum = htmlDatum . runJalmotUnsafe . S.toDatum S.datumIso

src/Gyehoek/Wasm.hs

@@ -1,4 +1,3 @@
-{- HLINT ignore "Use newtype instead of data" -}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE TemplateHaskellQuotes #-}

t.scm

@@ -0,0 +1,5 @@
+((λ ()
+   (* 2 (call/cc
+         (λ (k)
+           (begin (k 6)
+                  3))))))

test/Gyehoek/Test/CPS/Eval.hs

@@ -5,53 +5,75 @@ import Test.Tasty.HUnit
 import Gyehoek.CPS.Syntax (cps, Obj(..), Hob(..), Imm(..))
 import Gyehoek.CPS.Eval qualified as Sut
 import Data.List (List)
-import Test.Tasty.ExpectedFailure (ignoreTestBecause)
+import Test.Tasty.ExpectedFailure (ignoreTestBecause, expectFail)
+import System.Directory (listDirectory)
+import Test.Tasty.Silver
+import System.FilePath
+import Control.Exception
+import qualified Gyehoek.Driver as Driver
+import Control.DeepSeq (($!!))
+import System.Exit (ExitCode(..))
+import qualified Data.Text as T
+import Data.Function (applyWhen)
+import Gyehoek.Prelude
 
 
-test_cpsInterpreter =
+brokenEvalTests :: List String
-  ignoreTestBecause "i forgorrrr" $
+brokenEvalTests =
-  testGroup "cps interpreter" $
+  []
-  [ primitives
+  -- [ "adder"
-  , testCase "halt with constant" do
+  -- , "apply2"
-      evalsTo [ObjImm (ImmInt 123)] [cps|
+  -- , "apply-twice"
-        (continue halt 123)
+  -- , "arith"
-      |]
+  -- , "begin-1"
-  , testCase "identity cont" do
+  -- , "callcc-constant"
-      evalsTo [ObjImm (ImmInt 154)] [cps|
+  -- , "callcc-discard"
-        (letrec ((id (κ (x)
+  -- , "callcc-early-exit-1"
-                       (continue halt x))))
+  -- , "callcc-early-exit-2"
-          (continue id 154))
+  -- , "callcc-early-exit-3"
-      |]
+  -- , "callcc-early-exit-4"
-  , testCase "identity function" do
+  -- , "callcc-early-exit-5"
-      evalsTo [ObjImm (ImmInt 456)] [cps|
+  -- , "callcc-early-exit-6"
-        (letrec ((id (λ (x ktail)
+  -- , "callcc-nested-1"
-                       (continue ktail x))))
+  -- , "callcc-nested-2"
-          (id 456 halt))
+  -- , "complicated-1"
-      |]
+  -- , "cons-1"
-  , testCase "square" do
+  -- , "factorial"
-      evalsTo [ObjImm (ImmInt 81)] [cps|
+  -- , "false"
-        (letrec ((square (λ (x ktail)
+  -- , "fn-of-fn"
-                           (prim (* x x)
+  -- , "if-false"
-                             (κ (r) (continue ktail r))))))
+  -- , "if-number"
-          (square 9 halt))
+  -- , "if-true"
-      |]
+  -- , "lambda"
-  ]
+  -- , "letrec-fn"
+  -- , "let-fn"
+  -- , "lit-int"
+  -- , "square"
+  -- , "true"
+  -- ]
 
-evalsTo :: HasCallStack => List Obj -> Sut.Exp -> Assertion
+test_eval :: IO TestTree
-evalsTo rs e = Sut.evalExp e @?= rs
+test_eval = do
-
+  cs <- listDirectory "golden/exec"
-primitives = testGroup "primitives"
+      <&> fmap ("golden/exec" </>)
-  [ testGroup "arith"
+  pure $ testGroup "cps interpreter"
-    [ testCase "basic 1" do
+    [ testGroup "higher-order" $ cpsCase Driver.eval_cps2_e2e <$> cs
-        evalsTo [ObjImm (ImmInt 20)] [cps|
+    -- , testGroup "first-order" $ cpsCase Driver.eval_cps1_e2e <$> cs
-          (prim (* 4 5)
-            (κ (x) (continue halt x)))
-          |]
-    , testCase "basic 2" do
-        evalsTo [ObjImm (ImmInt 35)] [cps|
-          (prim (* 2 16)
-            (κ (x) (prim (+ x 3)
-                      (κ (r) (continue halt r)))))
-          |]
     ]
-  ]
+
+maybeBroken name broken = applyWhen (name `elem` broken) expectFail
+
+cpsCase :: (FilePath -> IO Text) -> FilePath -> TestTree
+cpsCase f test =
+  maybeBroken testName brokenEvalTests $
+    goldenVsAction testName resultFile action printProcResult
+  where
+    testName = takeFileName test
+    resultFile = test </> "exec"
+    sourceFile = test </> "source.scm"
+    action = catch @SomeException
+      (do r <- f sourceFile
+          pure $!! ( ExitSuccess
+                   , r
+                   , "" ))
+      \e -> pure (ExitFailure 1, "", T.pack $ displayException e)

test/Gyehoek/Test/CPS/Stackify.hs

@@ -1,90 +0,0 @@
-module Gyehoek.Test.CPS.Stackify where
-
-import Test.Tasty (TestTree, testGroup)
-import Test.Tasty.HUnit
-import qualified Gyehoek.CPS.Stackify as Sut
-import Gyehoek.Stack.VM as Stk
-import Gyehoek.CPS.Syntax (cps)
-import Gyehoek.CPS.Syntax qualified as CPS
-import Gyehoek.GenSym (runGenSym)
-import Effectful
-import Gyehoek.Prelude
-import Gyehoek.Jalmot
-
-
-test_stackify =
-  [ trivialReturn
-  , tailCall
-  , prim
-  , condition
-  , procedure
-  ]
-
-evalsTo :: List Obj -> Sut.Exp -> Assertion
-evalsTo rs e = runJalmotUnsafe (Stk.eval e') @?= rs
-  where
-    e' = e & CPS.MkLambda [] "_ktail"
-      & CPS.MkProgram
-      & Sut.stackifyProgram & runGenSym & runPureEff
-
-trivialReturn = testGroup "trivial return"
-  [ testCase "return int" do
-      evalsTo [ObjImm (ImmInt 4)]
-        [cps|(continue halt 4)|]
-  , testCase "return bool" do
-      evalsTo [ObjImm (ImmBool True)]
-        [cps|(continue halt #t)|]
-      evalsTo [ObjImm (ImmBool False)]
-        [cps|(continue halt #f)|]
-  ]
-
-tailCall = testGroup "tail call"
-  [ testCase "square" do
-      evalsTo [ObjImm (ImmInt 16)]
-        [cps|(letrec ((square (λ (x ktail)
-                                (prim (* x x)
-                                  (κ (x0) (continue ktail x0))))))
-               (square 4 halt))|]
-  ]
-
-prim = testGroup "prim"
-  [ testCase "multiply" do
-      evalsTo [ObjImm (ImmInt 20)]
-        [cps|(prim (* 4 5)
-               (κ (x) (continue halt x)))|]
-  , testCase "add" do
-      evalsTo [ObjImm (ImmInt 9)]
-        [cps|(prim (+ 4 5)
-               (κ (x) (continue halt x)))|]
-  -- , testGroup "call/cc"
-  --   [ testCase "trivial" do
-  --       evalsTo [ObjImm (ImmInt 123)]
-  --         [cps|(letrec ((f (λ (cc ktail) (continue cc 123))))
-  --                (prim (call/cc f)))|]
-  --   ]
-  ]
-
-condition = testCase "if" do
-  evalsTo [ObjImm (ImmInt 123)]
-    [cps|(if #t (continue halt 123) (continue halt 456))|]
-  evalsTo [ObjImm (ImmInt 456)]
-    [cps|(if #f (continue halt 123) (continue halt 456))|]
-
-procedure = testGroup "procedure"
-  [ testCase "factorial" do
-      evalsTo [ObjImm (ImmInt 720)]
-        [cps|(letrec ((fac (λ (n ktail)
-                             (prim (zero? n)
-                               (κ (x0)
-                                 (if x0
-                                   (continue ktail 1)
-                                   (prim (- n 1)
-                                     (κ (x1)
-                                       (letrec ((fac-k0
-                                                  (κ (x2)
-                                                    (prim (* n x2)
-                                                      (κ (x3)
-                                                        (continue ktail x3))))))
-                                         (fac x1 fac-k0))))))))))
-               (fac 6 halt))|]
-  ]

test/Gyehoek/Test/CPS/Syntax.hs

@@ -46,9 +46,9 @@ qq = testGroup "parser"
   , testCase "application" do
       assertEqual "" (Sut.ExpApply (Sut.ValVar "f")
                      [Sut.ValVar "x",Sut.ValVar "y"]
-                     "k")
+                     (Sut.KexpVar "k"))
         [cps|(f x y k)|]
       assertEqual "" (Sut.ExpApply (Sut.ValVar "f")
-                     [] "k")
+                     [] (Sut.KexpVar "k"))
         [cps|(f k)|]
   ]

test/Gyehoek/Test/Golden.hs

@@ -1,87 +0,0 @@
-module Gyehoek.Test.Golden where
-
-import Test.Tasty (TestTree, testGroup)
-import Test.Tasty.Silver
-import Gyehoek.Driver qualified as Driver
-import System.FilePath
-import Data.List (List)
-import Data.Functor ((<&>))
-import System.Directory
-import Data.Function
-import System.Environment.Blank (getEnvDefault)
-import qualified System.Process.Text as PT
-import Control.Exception (SomeException (SomeException), Exception (..), catch)
-import Gyehoek.Stack.VM (writeObj)
-import Data.Text qualified as T
-import System.Exit (ExitCode(..))
-import Test.Tasty.ExpectedFailure (expectFail, ignoreTestBecause)
-import Control.DeepSeq (($!!))
-import Text.Pretty.Simple (pShow, pShowNoColor)
-import Control.Lens (strict, view)
-import Gyehoek.Sexp.Read qualified as Read
-import Effectful
-
-
-brokenWasmTests :: List String
-brokenWasmTests =
-  [
-  ]
-
-brokenStackifyTests :: List String
-brokenStackifyTests =
-  []
-  -- [ "adder"
-  -- , "let-fn"
-  -- , "callcc-nested1" -- requires closure-conversion
-  -- ]
-
-test_root :: IO TestTree
-test_root = do
-  all_cases <- listDirectory "golden/exec"
-  let tests = all_cases
-            & fmap ("golden/exec"</>)
-  testGroup "execution" <$> sequenceA
-    [ ignoreTestBecause "wasm codegen is on the backburner"
-      <$> wasmTests tests
-    , stackifyTests tests
-    ]
-
-maybeBroken name broken = applyWhen (name `elem` broken) expectFail
-
-wasmTests :: List FilePath -> IO TestTree
-wasmTests files = do
-  cmd <- getEnvDefault "GYEHOEK_WASM_RUNTIME"
-    "runtime/target/debug/gyehoek-wasm-runtime"
-  pure $ testGroup "wasm" $ files <&> \test ->
-    let testname = takeFileName test
-        scmfile = test </> "source.scm"
-        resultfile = test </> "exec"
-        action = do
-          t <- Driver.lower_e2e scmfile
-          PT.readProcessWithExitCode cmd ["-"] t
-    in maybeBroken testname brokenWasmTests $
-      goldenVsAction
-       testname
-       resultfile
-       action
-       printProcResult
-
-stackifyTests :: List FilePath -> IO TestTree
-stackifyTests files = do
-  pure $ testGroup "stackified" $ files <&> \test ->
-    let testname = takeFileName test
-        scmfile = test </> "source.scm"
-        resultfile = test </> "exec"
-        action =
-          catch @SomeException
-            (do rs <- Driver.eval_e2e scmfile
-                pure $!! ( ExitSuccess
-                     , T.unwords . fmap writeObj $ rs
-                     , "" ))
-            \e -> pure (ExitFailure 1, "", T.pack $ displayException e)
-    in maybeBroken testname brokenStackifyTests $
-     goldenVsAction
-       testname
-       resultfile
-       action
-       printProcResult

test/Gyehoek/Test/Stack/VM.hs

@@ -1,76 +0,0 @@
-{-# LANGUAGE OverloadedLists #-}
-module Gyehoek.Test.Stack.VM where
-
-import Test.Tasty (TestTree, testGroup)
-import Test.Tasty.HUnit
-import Gyehoek.Stack.Syntax
-import Gyehoek.Stack.VM qualified as Sut
-import Data.List (List)
-import Gyehoek.Jalmot
-
-
-evalsTo :: List Obj -> Program -> Assertion
-evalsTo rs p = runJalmotUnsafe (Sut.eval p) @?= rs
-
-test_root = testGroup "stack machine"
-  [ testCase "lit int" do
-      evalsTo [ObjImm (ImmInt 3)] [stkP|
-        (define ($start %ktail)
-          (tail-call %ktail 3))
-      |]
-  , testCase "return constant" do
-      evalsTo [ObjImm (ImmInt 123)] [stkP|
-        (define ($start %ktail)
-          (tail-call $silly %ktail))
-        (define ($silly %ktail)
-          (tail-call %ktail 123))
-      |]
-  , testCase "identity continuation" do
-      evalsTo [ObjImm (ImmInt 45)] [stkP|
-        (define ($start %ktail)
-          (push! %ktail)
-          (tail-call $id 45))
-        (define ($id %x)
-          (pop! %ktail)
-          (tail-call %ktail %x))
-      |]
-  , testCase "identity function" do
-      evalsTo [ObjImm (ImmInt 45)] [stkP|
-        (define ($start %ktail)
-          (tail-call $id 45 %ktail))
-        (define ($id %x %ktail)
-          (tail-call %ktail %x))
-      |]
-  , testCase "square" do
-      evalsTo [ObjImm (ImmInt 16)] [stkP|
-        (define ($start %ktail)
-          (tail-call $square 4 %ktail))
-        (define ($square %x %ktail)
-          (prim %x2 (* %x %x))
-          (tail-call %ktail %x2))
-      |]
-  , testCase "factorial" do
-      let hsfac (n :: Int) = foldr (*) (1) [1..n]
-      let fac (n :: Int) = [stkP|
-            (define ($fac %n %ktail)
-              (prim %x0 (zero? %n))
-              (if %x0
-                (then (tail-call %ktail 1))
-                (else (push! %n)
-                      (push! %ktail)
-                      (prim %x1 (- %n 1))
-                      (tail-call $fac %x1 $fac-k0))))
-            (define ($fac-k0 %x2)
-              (pop! %ktail)
-              (pop! %n)
-              (prim %x3 (* %x2 %n))
-              (tail-call %ktail %x3))
-            (define ($start %ktail)
-              (tail-call $fac #{n} %ktail))
-          |]
-      evalsTo [ObjImm (ImmInt 1)] $ fac 0
-      evalsTo [ObjImm (ImmInt 1)] $ fac 1
-      evalsTo [ObjImm (ImmInt 720)] $ fac 6
-      -- 20 is the greatest `n` for which n! ≤ maxBount @Int
-      evalsTo [ObjImm (ImmInt 2432902008176640000)] $ fac 20
-  ]