allow multiple values in cps conversion

golden/exec/callcc-early-exit/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > #t

golden/exec/callcc-early-exit/source.scm

@@ -0,0 +1,12 @@
+(letrec ((iter (λ (n f)
+                 (if (zero? n)
+                     #f
+                     (begin (f n)
+                            (iter (- n 1) f))))))
+  (call/cc
+   (λ (k)
+     (iter 10 (λ (n)
+                ;; i don't feel like implementing (= n 5) right now lmfao
+                (if (zero? (- n 5))
+                    (k #t)
+                    #f))))))

src/Gyehoek/CPS/Convert.hs

@@ -12,6 +12,7 @@ import Data.List.NonEmpty (NonEmpty((:|)))
 import Control.Monad.Cont qualified as Cont
 import qualified Data.List.NonEmpty as NE
 import Gyehoek.Prelude
+import Debug.Pretty.Simple
 
 
 -- 뻘짓이어라
@@ -23,23 +24,34 @@ telescope f = Cont.runCont . traverse (Cont.cont . f)
 
 
 
+one :: a -> List a
+one a = [a]
+
+oneOrUndefined :: List Val -> Val
+oneOrUndefined = \case
+  [x] -> x
+  _ -> ValImm ImmUndefined
+
+convert1 :: (GenSym :> es) => Scm.Exp -> (Val -> Eff es Exp) -> Eff es Exp
+convert1 e k = convert e (k . oneOrUndefined)
+
 -- | Transform an expression with a meta-continuation.
 convert
   :: forall es. (GenSym :> es)
-  => Scm.Exp -> (Val -> Eff es Exp) -> Eff es Exp
+  => Scm.Exp -> (List Val -> Eff es Exp) -> Eff es Exp
 
-convert (Scm.ExpVar x) k = k $ ValVar x
+convert (Scm.ExpVar x) k = k [ValVar x]
-convert (Scm.ExpLit l) k = k . ValImm $ case l of
+convert (Scm.ExpLit l) k = k . one . ValImm $ case l of
   LitInt n -> ImmInt n
   LitBool b -> ImmBool b
   _ -> _
 
 -- special case: call/cc is desugared during cps-conversion...
 convert (Scm.ExpPrim (PrimCallCC withcc)) k = do
-  convert withcc \withcc' -> do
+  convert1 withcc \withcc' -> do
     cc <- gensym' @Name "cc"
     r <- gensym' "r"
-    m <- k $ ValVar r
+    m <- k . one $ ValVar r
     ccish <- gensym' @Name "cc-ish"
     x <- gensym' @Name "x"
     pure [cps|
@@ -51,30 +63,31 @@ convert (Scm.ExpPrim (PrimCallCC withcc)) k = do
 -- ...while all other prims are left as-is for later stages to
 -- handle..
 convert (Scm.ExpPrim p) k =
-  telescope (convert @es) p \p' -> do
+  telescope (convert1 @es) p \p' -> do
     r <- gensym' "r"
-    ExpPrim p' . MkKappa [r] <$> k (ValVar r)
+    ExpPrim p' . MkKappa [r] <$> k [ValVar r]
 
 convert (Scm.ExpLambda xs e) k = do
   f <- gensym' "lambda-body"
   lam <- convertLambda xs e
-  ke <- k $ ValVar f
+  ke <- k [ValVar f]
   pure [cps|
     (letrec ((#{f} #{lam}))
       #{ke})
   |]
 
 convert (Scm.ExpApply f xs) k =
-  telescope (convert @es) (f:|xs) \(f':|xs') -> do
+  telescope (convert1 @es) (f:|xs) \(f':|xs') -> do
     r <- gensym' "r"
     x <- gensym' "x"
-    m <- k (ValVar x)
+    m <- k [ValVar x]
-    pure $ ExpLetRec [(r, AbsKappa' [x] m)] $ ExpApply f' xs' r
+    pure $ ExpLetRec [(r, AbsKappa' [x] m)] $
+      ExpApply f' xs' r
 
-convert (Scm.ExpBegin xs) k = _
+convert (Scm.ExpBegin xs) k = telescope (convert @es) xs (k . NE.last)
 
 convert (Scm.ExpIf c t f) k =
-  convert c \c' ->
+  convert1 c \c' ->
     ExpIf c' <$> convert t k <*> convert f k
 
 -- let-bindings are desugared into continuation calls whose parameters
@@ -82,7 +95,7 @@ convert (Scm.ExpIf c t f) k =
 -- sides.
 convert (Scm.ExpLet bs e) k =
   let rhss = bs ^.. each . _2
-  in telescope (convert @es) rhss \rhss' -> do
+  in telescope (convert1 @es) rhss \rhss' -> do
     e' <- convert e k
     kbody <- gensym' @Name "let-body"
     let bs' = bs ^.. each . _1
@@ -105,15 +118,15 @@ convertLambda
   => List Name -> Scm.Exp -> Eff es Lambda
 convertLambda bs m = do
   ktail <- gensym' "lambda-tail"
-  m' <- convert m $ pure . ExpContinue (ValVar ktail) . (:[])
+  m' <- convert1 m $ pure . ExpContinue (ValVar ktail) . (:[])
   pure [cps|(λ (##{bs} #{ktail}) #{m'})|]
 
 convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program
 convertProgram p = do
   ktail <- gensym' "start-ktail"
-  m <- telescope (convert @es) (p ^.. each . _Left)
+  m <- telescope (convert1 @es) (p ^.. each . _Left)
         (pure . ExpContinue (ValVar ktail))
   pure . MkProgram $ MkLambda [] ktail m
 
 convertExp :: forall es. (GenSym :> es) => Scm.Exp -> Eff es Exp
-convertExp e = convert e (pure . Halt1)
+convertExp e = convert e (pure . Halt)

src/Gyehoek/CPS/Syntax.hs

@@ -67,6 +67,7 @@ data Imm
   = ImmInt Int
   | ImmBool Bool
   | ImmLabel Name
+  | ImmUndefined
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
 
@@ -168,6 +169,7 @@ instance S.DatumIso Imm where
     $ S.With (. S.int)
     $ S.With (. S.datumIso)
     $ S.With (. labelName)
+    $ S.With (. S.unreadable (const "#<undefined>"))
     $ S.End
 
 labelName :: S.DatumGrammar Name
@@ -261,7 +263,7 @@ instance S.DatumIso Program where
 -- quasiquoters
 
 class Data a => CPS a where
-  toCPS :: Datum -> a
+  toCPS :: HasCallStack => Datum -> a
 
 instance CPS Exp where toCPS = S.fromDatumUnsafe S.datumIso
 instance CPS Val where toCPS = S.fromDatumUnsafe S.datumIso

src/Gyehoek/Scheme/Syntax.hs

@@ -51,7 +51,7 @@ import qualified Effectful.FileSystem.IO.ByteString as FB
 import qualified Data.Set.Ordered as O
 import Gyehoek.Sexp.Grammar qualified as Sexp
 import Gyehoek.Sexp.Grammar qualified as S
-import Gyehoek.Sexp.Grammar (DatumIso, DataIso)
+import Gyehoek.Sexp.Grammar (DatumIso, G, DataIso, (:-)((:-)))
 import Gyehoek.Prelude
 
 
@@ -84,6 +84,8 @@ data Prim e
   | PrimEnvRef e Int
   | PrimEnvCode e
   | PrimCallCC e
+  | PrimValues (List e)
+  | PrimCallWithValues e e
   deriving stock (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
   deriving anyclass (NFData)
 
@@ -106,7 +108,7 @@ data Exp
   = ExpLet (List (Name, Exp)) Exp
   | ExpLetRec (List (Name, Exp)) Exp
   | ExpPrim (Prim Exp)
-  | ExpBegin (List Exp)
+  | ExpBegin (NonEmpty Exp)
   | ExpIf Exp Exp Exp
   | ExpLit Lit
   | ExpLambda (List Name) Exp
@@ -167,6 +169,8 @@ primDatumIso namefn a = S.match
     $ S.With (. S.headTagged2 (namefn "env-ref") a S.int)
     $ S.With (. ht1 "env-code")
     $ S.With (. ht1 "call/cc")
+    $ S.With (. ht0' "values")
+    $ S.With (. ht2 "call-with-values")
     $ S.End
     where
       idn = S.el . S.sym . namefn
@@ -174,6 +178,7 @@ primDatumIso namefn a = S.match
       ht1 s = S.headTagged1 (namefn s) a
       ht2 s = S.headTagged2 (namefn s) a a
       ht1' s = S.headTagged1' (namefn s) a a
+      ht0' s = S.headTagged0' (namefn s) a
 
 instance DatumIso a => DatumIso (Prim a) where
   -- datumIso = primDatumIso ("prim:"<>) datumIso
@@ -203,7 +208,7 @@ instance DatumIso Exp where
     $ S.With (. S.letLike "let" S.datumIso S.datumIso S.datumIso)
     $ S.With (. S.letLike "letrec" S.datumIso S.datumIso S.datumIso)
     $ S.With (. S.datumIso)
-    $ S.With (. S.beginLike "begin" S.datumIso)
+    $ S.With (. begin)
     $ S.With (. S.ifLike "if" S.datumIso S.datumIso S.datumIso)
     $ S.With (. S.datumIso)
     $ S.With (. lam)
@@ -212,12 +217,18 @@ instance DatumIso Exp where
     $ S.End
     where
       lam = S.lambdaLike S.lambdaKeyword S.datumIso (S.el S.datumIso)
+      begin :: forall t. G (S.Datum :- t) (NonEmpty Exp :- t)
+      begin = S.beginLike "begin" $
+        S.el (S.datumIso @Exp) >>> S.rest (S.datumIso @Exp)
+        >>> S.onTail (S.Iso
+          (\(xs:-x:-t) -> (x:|xs):-t)
+          (\((x:|xs):-t) -> xs:-x:-t))
 
 instance DatumIso CommandOrDef where
   datumIso = S.match
     $ S.With (\_Command -> _Command . S.datumIso)
     $ S.With (\_Definition -> _Definition . S.datumIso)
-    $ S.With (\_Begin -> _Begin . S.beginLike "begin" S.datumIso)
+    $ S.With (\_Begin -> _Begin . S.beginLike "begin" (S.rest S.datumIso))
     $ S.End
 
 instance DataIso Program where

src/Gyehoek/Sexp/Grammar.hs

@@ -59,19 +59,21 @@ toData g =
   >>> runGrammar noAnn
   >>> either (throwError . GrammarError) pure
 
-fromDatum :: Jalmot :> es => DatumGrammar a -> Datum -> Eff es a
+fromDatum :: (HasCallStack, Jalmot :> es) => DatumGrammar a -> Datum -> Eff es a
 fromDatum g =
   forward (sealed g)
   >>> runGrammar noAnn
   >>> either (throwError . GrammarError) pure
 
-fromDatumUnsafe :: DatumGrammar a -> Datum -> a
+fromDatumUnsafe :: HasCallStack => DatumGrammar a -> Datum -> a
 fromDatumUnsafe g = runJalmotUnsafe . fromDatum g
 
-fromDataUnsafe :: DataGrammar a -> List Datum -> a
+fromDataUnsafe :: HasCallStack => DataGrammar a -> List Datum -> a
 fromDataUnsafe g = runJalmotUnsafe . fromData g
 
-fromData :: Jalmot :> es => DataGrammar a -> List Datum -> Eff es a
+fromData
+  :: (HasCallStack, Jalmot :> es)
+  => DataGrammar a -> List Datum -> Eff es a
 fromData g =
   forward (sealed g)
   >>> runGrammar noAnn

src/Gyehoek/Sexp/Grammar/Base.hs

@@ -31,6 +31,7 @@ module Gyehoek.Sexp.Grammar.Base
   , number
   , integer
   , int
+  , unreadable
   -- * TODO: sort lol
   , prismIso
   , isoIso, decorate
@@ -381,11 +382,19 @@ kappaKeyword = coproduct [ sym "κ", sym "kappa" ]
 
 beginLike
   :: Text
-  -> DatumGrammar a
+  -> G (ListContext :- t) (ListContext :- t')
-  -> G (Datum :- t) (List a :- t)
+  -> G (Datum :- t) t'
 beginLike kw g =
   listWithIndentation (NSpecial 0) $
-    el (symBuiltin kw) >>> rest g
+    el (symBuiltin kw) >>> g
+
+-- | define a printed syntax for an object which cannot be read.
+unreadable
+  :: (t -> Text)
+  -> G (Datum :- t) t
+unreadable f = Flip $ PartialIso
+  (\t -> Unreadable (f t) :- t)
+  (const $ Left mempty)
 
 isoIso :: Iso' s a -> Grammar p (s :- t) (a :- t)
 isoIso l = iso (view l) (review l)

src/Gyehoek/Sexp/Print.hs

@@ -87,6 +87,7 @@ prettySimple depth = \case
     & annotate SynConstant
   SimpleString s -> annotate SynString $ viaShow s
   SimpleSymbol s -> pretty s
+  SimpleUnreadable s -> pretty s
 
 putDoc :: Doc Syn -> IO ()
 putDoc = ANSI.renderIO stdout

src/Gyehoek/Sexp/Syntax.hs

@@ -29,6 +29,7 @@ module Gyehoek.Sexp.Syntax
   , indentation
   , adorn
   , indentWith
+  , pattern Unreadable
   , pattern Bytevector
   , pattern Symbol
   , pattern String
@@ -79,6 +80,7 @@ data Simple
   | SimpleString Text
   | SimpleSymbol Text
   | SimpleBytevector ByteString
+  | SimpleUnreadable Text
   deriving stock (Show, Eq, Data, Generic, Lift)
   deriving anyclass (NFData)
 
@@ -230,6 +232,7 @@ pattern Character a = Simple (SimpleCharacter a)
 pattern String a = Simple (SimpleString a)
 pattern Symbol a = Simple (SimpleSymbol a)
 pattern Bytevector a = Simple (SimpleBytevector a)
+pattern Unreadable a = Simple (SimpleUnreadable a)
 
 
 --- Lift1 instances