95 lines
2.0 KiB
Haskell
95 lines
2.0 KiB
Haskell
{-# LANGUAGE OverloadedLabels #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
module Gyehoek.CPS.Syntax
|
|
( Val(..)
|
|
, Kappa(..)
|
|
, Exp(..)
|
|
, Name(..)
|
|
, Prim(..)
|
|
, 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)
|
|
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)
|
|
|
|
-- 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)
|
|
|
|
pattern Halt :: List Val -> Exp
|
|
pattern Halt xs = ExpApply (ValVar "halt") xs
|
|
|
|
pattern Halt1 :: Val -> Exp
|
|
pattern Halt1 x = ExpApply (ValVar "halt") [x]
|
|
|
|
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 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
|