kexp

src/Gyehoek/CPS/Convert.hs

@@ -67,11 +67,11 @@ 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)
 

src/Gyehoek/CPS/Syntax.hs

@@ -10,6 +10,7 @@ module Gyehoek.CPS.Syntax
   , Kappa(..)
   , Lambda(..)
   , Exp(..)
+  , Kexp(..)
   , ExpF(..)
   , Name(..)
   , Prim(..)
@@ -121,17 +122,22 @@ pattern AbsLambda' :: List Name -> Name -> Exp -> Abs
 pattern AbsLambda' xs e ktail = AbsLambda (MkLambda xs e ktail)
 
 data Exp
-  = ExpPrim (Prim Val) Name
+  = ExpPrim (Prim Val) Kexp
   | ExpLetRec { binders :: List (Name, Abs), body :: Exp }
   | ExpContinue Val (List Val)
   | 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
 
@@ -272,27 +278,32 @@ 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
 
@@ -346,11 +357,16 @@ 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 ^.. folded . #ValVar . filtered (`notElem` bound))
-      ++ mif (`notElem` bound) k
+      ++ freeWithBound' bound k
     ExpLetRec bs m ->
       foldMapOf (each . _2) (freeWithBound' bound') bs
       <> freeWithBound' bound' m
@@ -361,7 +377,7 @@ instance Free Exp where
       <> mif (`notElem` bound) t <> mif (`notElem` bound) f
     ExpApply f xs k ->
       (f:xs) ^.. (each . #ValVar . filtered (`notElem` bound))
-      <> mif (`notElem` bound) k
+      <> freeWithBound' bound k
 
 instance Free Kappa where
   freeWithBound' bound (MkKappa xs m) =

src/Gyehoek/Sexp/Grammar/Base.hs

@@ -9,7 +9,7 @@ module Gyehoek.Sexp.Grammar.Base
   , DatumGrammar
   , DataGrammar
   , Grammar
-  , ListContext
+  , ListContext(..)
   , (:-)((:-))
   -- * lists
   , list