tests

src/Gyehoek/CPS/Syntax.hs

@@ -0,0 +1,139 @@
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Gyehoek.CPS.Syntax
+  ( Val(..)
+  , Kappa(..)
+  , Lambda(..)
+  , Exp(..)
+  , Name(..)
+  , Prim(..)
+  , Program(..)
+  , Lit(..)
+  , pattern Void
+  , pattern Halt
+  , pattern Halt1
+  , _MkKappa
+  , _ExpPrim
+  , _ExpFix
+  , _ExpApply
+  )
+  where
+
+import Language.SexpGrammar qualified as S
+import Gyehoek.Sexp qualified
+import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit(..), pattern Void)
+import Data.Text (Text)
+import Data.List (List)
+import GHC.Generics (Generic)
+import Language.SexpGrammar.Generic
+import Control.Category
+import Control.Lens
+import Data.Text qualified as T
+import Data.Generics.Labels
+import Prelude hiding ((.), id)
+import Data.List.NonEmpty (NonEmpty)
+import Data.InvertibleGrammar.Base qualified as IGB
+import Data.InvertibleGrammar.Base ((:-)((:-)))
+import qualified Data.InvertibleGrammar as IG
+
+-- Data types
+
+data Val
+  = ValLabel Name
+  | ValVar Name
+  | ValLit Lit
+  deriving (Show, Generic)
+
+data Kappa = MkKappa (List Name) Exp
+  deriving (Show, Generic)
+
+data Lambda = MkLambda (List Name) Name Exp
+  deriving (Show, Generic)
+
+data Exp
+  = ExpPrim (Prim Val) (List Name) Exp
+  | ExpFix (NonEmpty (Name, Kappa)) Exp
+  | ExpLet (NonEmpty (Name, Lambda)) Exp
+  | ExpContinue Name (List Val)
+  | ExpIf Val Exp Exp
+  | ExpApply Val (List Val)
+  deriving (Show, Generic)
+
+pattern Halt :: List Val -> Exp
+pattern Halt xs = ExpApply (ValVar "halt") xs
+
+pattern Halt1 :: Val -> Exp
+pattern Halt1 x = ExpApply (ValVar "halt") [x]
+
+data Def = DefConstant Name Exp
+  deriving (Show, Generic)
+
+data Program = MkProgram
+  { body :: Exp
+  }
+  deriving (Show, Generic)
+
+makePrisms ''Kappa
+makePrisms ''Exp
+
+
+-- SexpIso instances
+
+instance S.SexpIso Val where
+  sexpIso = match
+    $ With (. label)
+    $ With (. var)
+    $ With (. S.sexpIso)
+    $ End
+    where
+      label = S.keyword >>> S.iso MkName getName
+      var = S.sexpIso
+
+instance S.SexpIso Lambda where
+  sexpIso = match
+    $ With (. lambda)
+    $ End
+    where
+      lambda = S.list $
+        S.el Gyehoek.Sexp.lambdaKeyword
+        >>> S.el (S.list (S.rest S.sexpIso))
+        >>> S.el S.sexpIso
+        >>> S.el S.sexpIso
+
+instance S.SexpIso Kappa where
+  sexpIso = match
+    $ With (. kappa)
+    $ End
+    where
+      kappa = S.list $
+        S.el Gyehoek.Sexp.kappaKeyword
+        >>> S.el (S.list $ S.rest S.sexpIso)
+        >>> S.el S.sexpIso
+
+instance S.SexpIso Exp where
+  sexpIso = match
+    $ With (. prim)
+    $ With (. fix)
+    $ With (. let_)
+    $ With (. continue)
+    $ With (. if_)
+    $ With (. app)
+    $ End
+    where
+      continue = S.list $
+        S.el (S.sym "continue")
+        >>> S.el S.sexpIso
+        >>> S.rest S.sexpIso
+      fix = Gyehoek.Sexp.let_ "fix" S.sexpIso S.sexpIso S.sexpIso
+      let_ = Gyehoek.Sexp.let_ "let" S.sexpIso S.sexpIso S.sexpIso
+      if_ = S.list $ S.el (S.sym "if")
+        >>> S.el S.sexpIso >>> S.el S.sexpIso >>> S.el S.sexpIso
+      app = S.list $ S.el S.sexpIso >>> S.rest S.sexpIso
+      prim = S.list $
+        S.el (S.sym "prim")
+        >>> S.el (primSexpIso id (S.sexpIso @Val))
+        >>> S.el S.sexpIso
+        >>> S.el S.sexpIso
+
+instance S.SexpIso Program where
+  sexpIso = with \prog -> S.sexpIso @Exp >>> prog