140 lines
3.2 KiB
Haskell
140 lines
3.2 KiB
Haskell
{-# 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
|