cps

app/Gyehoek/Scheme/Syntax.hs

@@ -2,13 +2,15 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE DerivingStrategies #-}
 module Gyehoek.Scheme.Syntax
-  ( Name
+  ( Name(..)
   , Prim(..)
   , Lit(..)
   , Define(..)
   , Exp(..)
   , Sexp(..)
+  , primSexpIso
   )
   where
 
@@ -23,10 +25,14 @@ import Prelude hiding ((.), id)
 import Control.Category
 import Data.List.NonEmpty (NonEmpty ((:|)))
 import Gyehoek.Sexp qualified
+import Gyehoek.GenSym (Gen)
 import Control.Lens (Each)
+import Data.String (IsString)
 
 
-type Name = Text
+newtype Name = MkName { getName :: Text }
+  deriving newtype (Show, Eq, IsString, Gen)
+  deriving stock (Generic)
 
 data Prim e
   = PrimAdd e e
@@ -40,6 +46,7 @@ data Prim e
   | PrimConsP e
   | PrimIntegerP e
   | PrimWrite e
+  | PrimZeroP e
   | PrimNewline
   deriving (Show, Generic, Functor, Foldable, Traversable)
 
@@ -78,8 +85,14 @@ data Sexp
 
 
 
-instance SexpIso a => SexpIso (Prim a) where
-  sexpIso = match
+instance SexpIso Name where
+  sexpIso = symbol >>> Sexp.partialOsi f g
+    where
+      f = Right . MkName
+      g (MkName s) = s
+
+primSexpIso :: (Text -> Text) -> Sexp.SexpGrammar a -> Sexp.SexpGrammar (Prim a)
+primSexpIso namefn a = match
     $ With (. binop "+")
     $ With (. binop "-")
     $ With (. binop "*")
@@ -91,13 +104,16 @@ instance SexpIso a => SexpIso (Prim a) where
     $ With (. unop "cons?")
     $ With (. unop "integer?")
     $ With (. unop "write")
+    $ With (. unop "zero?")
     $ With (. nullop "newline")
     $ End
     where
-      primname = ("prim:" <>)
-      nullop s = list $ el (sym (primname s))
-      unop s = list $ el (sym (primname s)) >>> el sexpIso
-      binop s = list $ el (sym (primname s)) >>> el sexpIso >>> el sexpIso
+      nullop s = list $ el (sym (namefn s))
+      unop s = list $ el (sym (namefn s)) >>> el a
+      binop s = list $ el (sym (namefn s)) >>> el a >>> el a
+
+instance SexpIso a => SexpIso (Prim a) where
+  sexpIso = primSexpIso ("prim:"<>) sexpIso
 
 instance SexpIso Lit where
   sexpIso = match
@@ -121,20 +137,20 @@ instance SexpIso Define where
     $ With (. defun)
     $ End
     where
-      defconst = list $ el (sym "define") >>> el symbol >>> el sexpIso
+      defconst = list $ el (sym "define") >>> el sexpIso >>> el sexpIso
       defun = list $ el (sym "define") >>> el args >>> rest sexpIso
-      args = list $ el symbol >>> rest symbol
+      args = list $ el sexpIso >>> rest sexpIso
   
 instance SexpIso Exp where
   sexpIso = match
-    $ With (. Gyehoek.Sexp.let_ symbol sexpIso sexpIso)
+    $ With (. Gyehoek.Sexp.let_ "let" sexpIso sexpIso sexpIso)
     $ With (. sexpIso)
     $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
     $ With (. sexpIso)
     $ With (. if_)
     $ With (. sexpIso)
     $ With (. lam)
-    $ With (. symbol)
+    $ With (. sexpIso)
     $ With (\app -> app . list (el sexpIso >>> rest sexpIso))
     $ End
     where