msyds committed
1 parent
c340ede84f
commit
4beeb7c4cd
12 files changed
+650
-166
No files matched your search
+74
-103
@@ -17,11 +17,9 @@ module Gyehoek.Scheme.Syntax
|
||||
, Def(..)
|
||||
, Exp(..)
|
||||
, ExpF(..)
|
||||
, Sexp(..)
|
||||
, Program(..)
|
||||
, CommandOrDef(..)
|
||||
, primSexpIso
|
||||
, pattern Void
|
||||
, primDatumIso
|
||||
, free
|
||||
, subst
|
||||
, getName
|
||||
@@ -36,10 +34,6 @@ module Gyehoek.Scheme.Syntax
|
||||
where
|
||||
|
||||
import Data.List (intersperse)
|
||||
import Language.SexpGrammar
|
||||
( SexpIso(..), list, el, rest, sym, symbol )
|
||||
import Language.SexpGrammar qualified as Sexp
|
||||
import Language.SexpGrammar.Generic
|
||||
import Effectful
|
||||
import Prelude hiding ((.), id)
|
||||
import Control.Category
|
||||
@@ -58,6 +52,9 @@ import qualified Effectful.FileSystem.IO as FS
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Effectful.FileSystem.IO.ByteString as FB
|
||||
import qualified Data.Set.Ordered as O
|
||||
import Gyehoek.Sexp.Grammar qualified as Sexp
|
||||
import Gyehoek.Sexp.Grammar qualified as S
|
||||
import Gyehoek.Sexp.Grammar (DatumIso)
|
||||
import Gyehoek.Prelude
|
||||
|
||||
|
||||
@@ -97,16 +94,11 @@ instance Each (Prim e) (Prim e') e e'
|
||||
|
||||
data Lit
|
||||
= LitInt Int
|
||||
| LitNil
|
||||
| LitBool Bool
|
||||
| LitString Text
|
||||
| LitQuote Sexp
|
||||
deriving stock (Show, Generic, Data, Eq)
|
||||
deriving anyclass (NFData)
|
||||
|
||||
pattern Void :: Lit
|
||||
pattern Void = LitNil
|
||||
|
||||
data Def
|
||||
= DefConstant Name Exp
|
||||
| DefProcedure Name (List Name) (List Exp)
|
||||
@@ -126,13 +118,6 @@ data Exp
|
||||
deriving stock (Show, Generic, Data)
|
||||
deriving anyclass (NFData)
|
||||
|
||||
data Sexp
|
||||
= SexpCons Sexp Sexp
|
||||
| SexpSymbol Text
|
||||
| SexpLit Lit
|
||||
deriving stock (Show, Generic, Data, Eq)
|
||||
deriving anyclass (NFData)
|
||||
|
||||
data CommandOrDef
|
||||
= Command Exp
|
||||
| Definition Def
|
||||
@@ -159,96 +144,82 @@ makeBaseFunctor ''Exp
|
||||
|
||||
|
||||
|
||||
instance SexpIso Name where
|
||||
sexpIso = symbol >>> Sexp.partialOsi f g
|
||||
instance DatumIso Name where
|
||||
datumIso = S.symbol >>> S.iso MkName (review _Unwrapped')
|
||||
|
||||
primDatumIso
|
||||
:: (Text -> Text)
|
||||
-> S.DatumGrammar a -> S.DatumGrammar (Prim a)
|
||||
primDatumIso namefn a = S.match
|
||||
$ S.With (. ht2 "+")
|
||||
$ S.With (. ht2 "-")
|
||||
$ S.With (. ht2 "*")
|
||||
$ S.With (. ht2 "/")
|
||||
$ S.With (. ht2 "cons")
|
||||
$ S.With (. ht1 "car")
|
||||
$ S.With (. ht1 "cdr")
|
||||
$ S.With (. ht1 "immediate?")
|
||||
$ S.With (. ht1 "cons?")
|
||||
$ S.With (. ht1 "integer?")
|
||||
$ S.With (. ht1 "write")
|
||||
$ S.With (. ht1 "zero?")
|
||||
$ S.With (. nullop "newline")
|
||||
$ S.With (. ht1' "make-closure")
|
||||
$ S.With (. S.headTagged2 (namefn "env-ref") a S.int)
|
||||
$ S.With (. ht1 "env-code")
|
||||
$ S.With (. ht1 "call/cc")
|
||||
$ S.End
|
||||
where
|
||||
f = Right . MkName
|
||||
g (MkName s) = s
|
||||
idn = S.el . S.sym . namefn
|
||||
nullop s = S.list $ idn s
|
||||
ht1 s = S.headTagged1 (namefn s) a
|
||||
ht2 s = S.headTagged2 (namefn s) a a
|
||||
ht1' s = S.headTagged1' (namefn s) a a
|
||||
|
||||
primSexpIso :: (Text -> Text) -> Sexp.SexpGrammar a -> Sexp.SexpGrammar (Prim a)
|
||||
primSexpIso namefn a = match
|
||||
$ With (. ht2 "+")
|
||||
$ With (. ht2 "-")
|
||||
$ With (. ht2 "*")
|
||||
$ With (. ht2 "/")
|
||||
$ With (. ht2 "cons")
|
||||
$ With (. ht1 "car")
|
||||
$ With (. ht1 "cdr")
|
||||
$ With (. ht1 "immediate?")
|
||||
$ With (. ht1 "cons?")
|
||||
$ With (. ht1 "integer?")
|
||||
$ With (. ht1 "write")
|
||||
$ With (. ht1 "zero?")
|
||||
$ With (. nullop "newline")
|
||||
$ With (. ht1' "make-closure")
|
||||
$ With (. GS.headTagged2 (namefn "env-ref") a Sexp.int)
|
||||
$ With (. ht1 "env-code")
|
||||
$ With (. ht1 "call/cc")
|
||||
$ End
|
||||
instance DatumIso a => DatumIso (Prim a) where
|
||||
-- datumIso = primDatumIso ("prim:"<>) datumIso
|
||||
datumIso = primDatumIso id S.datumIso
|
||||
|
||||
instance DatumIso Lit where
|
||||
datumIso = S.match
|
||||
$ S.With (. S.int)
|
||||
$ S.With (. S.boolean)
|
||||
$ S.With (. S.string)
|
||||
$ S.End
|
||||
|
||||
instance DatumIso Def where
|
||||
datumIso = S.match
|
||||
$ S.With (. defconst)
|
||||
$ S.With (. defun)
|
||||
$ S.End
|
||||
where
|
||||
idn s = el (sym (namefn s))
|
||||
nullop s = list $ idn s
|
||||
ht1 s = GS.headTagged1 (namefn s) a
|
||||
ht2 s = GS.headTagged2 (namefn s) a a
|
||||
ht1' s = GS.headTagged1' (namefn s) a a
|
||||
|
||||
instance SexpIso a => SexpIso (Prim a) where
|
||||
-- sexpIso = primSexpIso ("prim:"<>) sexpIso
|
||||
sexpIso = primSexpIso id sexpIso
|
||||
|
||||
instance SexpIso Lit where
|
||||
sexpIso = match
|
||||
$ With (. sexpIso)
|
||||
$ With (. sym "nil")
|
||||
$ With (. GS.schemeBool)
|
||||
$ With (. sexpIso)
|
||||
$ With (. GS.prefixSugar "quote" Sexp.Quote sexpIso)
|
||||
$ End
|
||||
|
||||
instance SexpIso Sexp where
|
||||
sexpIso = match
|
||||
$ With (\conss -> conss . GS.todo)
|
||||
$ With (\s -> s . symbol)
|
||||
$ With (\lit -> lit . sexpIso)
|
||||
$ End
|
||||
|
||||
instance SexpIso Def where
|
||||
sexpIso = match
|
||||
$ With (. defconst)
|
||||
$ With (. defun)
|
||||
$ End
|
||||
where
|
||||
defconst = list $ el (sym "define") >>> el sexpIso >>> el sexpIso
|
||||
defun = list $ el (sym "define") >>> el args >>> rest sexpIso
|
||||
args = list $ el sexpIso >>> rest sexpIso
|
||||
defconst = S.list $ S.el (S.sym "define")
|
||||
>>> S.el S.datumIso >>> S.el S.datumIso
|
||||
defun = S.list $ S.el (S.sym "define")
|
||||
>>> S.el args >>> S.rest S.datumIso
|
||||
args = S.list $ S.el S.datumIso >>> S.rest S.datumIso
|
||||
|
||||
instance SexpIso Exp where
|
||||
sexpIso = match
|
||||
$ With (. GS.let_ "let" sexpIso sexpIso sexpIso)
|
||||
$ With (. GS.let_ "letrec" sexpIso sexpIso sexpIso)
|
||||
$ With (. sexpIso)
|
||||
$ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
|
||||
$ With (. if_)
|
||||
$ With (. sexpIso)
|
||||
$ With (. lam)
|
||||
$ With (. sexpIso)
|
||||
$ With (\app -> app . list (el sexpIso >>> rest sexpIso))
|
||||
$ End
|
||||
instance DatumIso Exp where
|
||||
datumIso = S.match
|
||||
$ S.With (. S.letLike "let" S.datumIso S.datumIso S.datumIso)
|
||||
$ S.With (. S.letLike "letrec" S.datumIso S.datumIso S.datumIso)
|
||||
$ S.With (. S.datumIso)
|
||||
$ S.With (. S.beginLike "begin" S.datumIso)
|
||||
$ S.With (. S.ifLike "if" S.datumIso S.datumIso S.datumIso)
|
||||
$ S.With (. S.datumIso)
|
||||
$ S.With (. lam)
|
||||
$ S.With (. S.datumIso)
|
||||
$ S.With (\app -> app . S.list (S.el S.datumIso >>> S.rest S.datumIso))
|
||||
$ S.End
|
||||
where
|
||||
if_ = list $ el (sym "if") >>> el sexpIso >>> el sexpIso >>> el sexpIso
|
||||
lam = list
|
||||
( el GS.lambdaKeyword
|
||||
>>> el (sexpIso @(List Name))
|
||||
>>> el sexpIso )
|
||||
lam = S.lambdaLike S.lambdaKeyword S.datumIso (S.el S.datumIso)
|
||||
|
||||
instance SexpIso CommandOrDef where
|
||||
sexpIso = match
|
||||
$ With (\_Command -> _Command . sexpIso)
|
||||
$ With (\_Definition -> _Definition . sexpIso)
|
||||
$ With (\_Begin -> _Begin . bgn)
|
||||
$ End
|
||||
where
|
||||
bgn = list $ el (sym "begin") >>> rest sexpIso
|
||||
instance DatumIso CommandOrDef where
|
||||
datumIso = S.match
|
||||
$ S.With (\_Command -> _Command . S.datumIso)
|
||||
$ S.With (\_Definition -> _Definition . S.datumIso)
|
||||
$ S.With (\_Begin -> _Begin . S.beginLike "begin" S.datumIso)
|
||||
$ S.End
|
||||
|
||||
|
||||
-- utilities
|
||||
|
||||
Reference in new issue
Block a user