call/cc

src/Gyehoek/Scheme/Syntax.hs

@@ -40,7 +40,7 @@ import GHC.Generics (Generic)
 import Prelude hiding ((.), id)
 import Control.Category
 import Data.List.NonEmpty (NonEmpty)
-import Gyehoek.Sexp qualified
+import Gyehoek.Sexp qualified as GS
 import Gyehoek.GenSym (Gen)
 import Control.Lens
 import Data.Generics.Labels ()
@@ -85,7 +85,8 @@ data Prim e
   | PrimZeroP e
   | PrimNewline
   | PrimMakeClosure { code :: e, env :: List e }
-  | PriEnvRef e Int
+  | PrimEnvRef e Int
+  | PrimCallCC e
   deriving (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
 
 instance Each (Prim e) (Prim e') e e'
@@ -156,29 +157,29 @@ instance SexpIso Name where
 
 primSexpIso :: (Text -> Text) -> Sexp.SexpGrammar a -> Sexp.SexpGrammar (Prim a)
 primSexpIso namefn a = match
-    $ With (. binop "+")
-    $ With (. binop "-")
-    $ With (. binop "*")
-    $ With (. binop "/")
-    $ With (. binop "cons")
-    $ With (. unop "car")
-    $ With (. unop "cdr")
-    $ With (. unop "immediate?")
-    $ With (. unop "cons?")
-    $ With (. unop "integer?")
-    $ With (. unop "write")
-    $ With (. unop "zero?")
+    $ With (. ht2 "+")
+    $ With (. ht2 "-")
+    $ With (. ht2 "*")
+    $ With (. ht2 "/")
+    $ With (. ht2 "cons")
+    $ With (. ht1 "car")
+    $ With (. ht1 "cdr")
+    $ With (. ht1 "immediate?")
+    $ With (. ht1 "cons?")
+    $ With (. ht1 "integer?")
+    $ With (. ht1 "write")
+    $ With (. ht1 "zero?")
     $ With (. nullop "newline")
-    $ With (. mkclosure)
-    $ With (. envref)
+    $ With (. ht1' "make-closure")
+    $ With (. GS.headTagged2 (namefn "env-ref") a Sexp.int)
+    $ With (. ht1 "call/cc")
     $ End
     where
       idn s = el (sym (namefn s))
       nullop s = list $ idn s
-      unop s = list $ idn s >>> el a
-      binop s = list $ idn s >>> el a >>> el a
-      mkclosure = list $ idn "make-closure" >>> el a >>> rest a
-      envref = list $ idn "env-ref" >>> el a >>> el Sexp.int
+      ht1 s = GS.headTagged1 (namefn s) a
+      ht2 s = GS.headTagged2 (namefn s) a a
+      ht1' s = GS.headTagged1' (namefn s) a a
 
 instance SexpIso a => SexpIso (Prim a) where
   -- sexpIso = primSexpIso ("prim:"<>) sexpIso
@@ -188,14 +189,14 @@ instance SexpIso Lit where
   sexpIso = match
     $ With (. sexpIso)
     $ With (. sym "nil")
-    $ With (. Gyehoek.Sexp.schemeBool)
+    $ With (. GS.schemeBool)
     $ With (. sexpIso)
-    $ With (. Gyehoek.Sexp.prefixSugar "quote" Sexp.Quote sexpIso)
+    $ With (. GS.prefixSugar "quote" Sexp.Quote sexpIso)
     $ End
 
 instance SexpIso Sexp where
   sexpIso = match
-    $ With (\conss -> conss . Gyehoek.Sexp.todo)
+    $ With (\conss -> conss . GS.todo)
     $ With (\s -> s . symbol)
     $ With (\lit -> lit . sexpIso)
     $ End
@@ -212,8 +213,8 @@ instance SexpIso Def where
   
 instance SexpIso Exp where
   sexpIso = match
-    $ With (. Gyehoek.Sexp.let_ "let" sexpIso sexpIso sexpIso)
-    $ With (. Gyehoek.Sexp.let_ "letrec" sexpIso sexpIso sexpIso)
+    $ With (. GS.let_ "let" sexpIso sexpIso sexpIso)
+    $ With (. GS.let_ "letrec" sexpIso sexpIso sexpIso)
     $ With (. sexpIso)
     $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
     $ With (. if_)
@@ -225,7 +226,7 @@ instance SexpIso Exp where
     where
       if_ = list $ el (sym "if") >>> el sexpIso >>> el sexpIso >>> el sexpIso
       lam = list
-        ( el Gyehoek.Sexp.lambdaKeyword
+        ( el GS.lambdaKeyword
           >>> el (sexpIso @(List Name))
           >>> el sexpIso )
 
@@ -242,7 +243,7 @@ instance SexpIso CommandOrDef where
 -- utilities
 
 scm :: QuasiQuoter
-scm = Gyehoek.Sexp.makeSx [|| Gyehoek.Sexp.fromSexp @Exp ||]
+scm = GS.makeSx [|| GS.fromSexp @Exp ||]
 
 free :: Exp -> HashSet Name
 free = cata \case
@@ -278,7 +279,7 @@ hGetContents h = T.decodeUtf8 <$> FB.hGetContents h
 readProgram :: IOE :> es => FilePath -> Eff es Program
 readProgram fp = runFileSystem $
   FS.withFile fp FS.ReadMode $ \h ->
-    Gyehoek.Sexp.parseSexps @CommandOrDef (fileName fp) <$> hGetContents h
+    GS.parseSexps @CommandOrDef (fileName fp) <$> hGetContents h
      >>= either error (pure . MkProgram)
 
 readExp :: IOE :> es => FilePath -> Eff es Exp