cps

app/Gyehoek/CPS/Convert.hs

@@ -0,0 +1,31 @@
+module Gyehoek.CPS.Convert
+  ( convert
+  ) where
+
+import Gyehoek.CPS.Syntax
+import Gyehoek.Scheme.Syntax qualified as Scm
+import Gyehoek.GenSym
+import Effectful
+import Control.Monad.Cont qualified as Cont
+
+
+-- 뻘짓이어라
+telescope
+  :: Traversable t
+  => (a -> (b -> r) -> r)
+  -> t a -> (t b -> r) -> r
+telescope f = Cont.runCont . traverse (Cont.cont . f)
+
+convert
+  :: forall es. (GenSym :> es)
+  => Scm.Exp -> (Val -> Eff es Exp) -> Eff es Exp
+
+convert (Scm.ExpVar x) k = k $ ValVar x
+convert (Scm.ExpLit l) k = k $ ValLit l
+
+convert (Scm.ExpPrim p) k =
+  telescope (convert @es) p \p' -> do
+    r <- gensym' "r"
+    ExpPrim p' [r] . pure <$> k (ValVar r)
+
+convert _ _ = _

app/Gyehoek/CPS/Syntax.hs

@@ -0,0 +1,77 @@
+{-# LANGUAGE OverloadedLabels #-}
+module Gyehoek.CPS.Syntax
+  ( Val(..)
+  , Kappa(..)
+  , Exp(..)
+  , Name(..)
+  , Prim(..)
+  )
+  where
+
+import Language.SexpGrammar qualified as S
+import Gyehoek.Sexp qualified
+import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primSexpIso, Lit)
+import Data.Text (Text)
+import Data.List (List)
+import GHC.Generics (Generic)
+import Language.SexpGrammar.Generic
+import Control.Category
+import Data.Text qualified as T
+import Data.Generics.Labels
+import Prelude hiding ((.), id)
+import Data.List.NonEmpty (NonEmpty)
+
+-- Data types
+
+data Val
+  = ValLabel Name
+  | ValVar Name
+  | ValLit Lit
+  deriving (Show, Generic)
+
+data Kappa = MkKappa (List Name) Exp
+  deriving (Show, Generic)
+
+data Exp
+  = ExpPrim (Prim Val) (List Name) (List Exp)
+  | ExpFix (NonEmpty (Name, Kappa)) Exp
+  | ExpApply Val (List Val)
+  deriving (Show, Generic)
+
+
+-- 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 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 (. let_)
+    $ With (. app)
+    $ End
+    where
+      let_ = Gyehoek.Sexp.let_ "fix" S.sexpIso S.sexpIso 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.rest S.sexpIso