146 lines
3.4 KiB
Haskell
146 lines
3.4 KiB
Haskell
{-# LANGUAGE DeriveGeneric #-}
|
||
{-# LANGUAGE OverloadedStrings #-}
|
||
{-# LANGUAGE TypeOperators #-}
|
||
{-# LANGUAGE PartialTypeSignatures #-}
|
||
module Gyehoek.Scheme.Syntax
|
||
( Name
|
||
, Prim(..)
|
||
, Lit(..)
|
||
, Define(..)
|
||
, Exp(..)
|
||
, Sexp(..)
|
||
)
|
||
where
|
||
|
||
import Data.Text (Text)
|
||
import Data.List (List)
|
||
import Language.SexpGrammar
|
||
( SexpIso(..), list, el, (>>>), rest, sym, symbol )
|
||
import Language.SexpGrammar qualified as Sexp
|
||
import Language.SexpGrammar.Generic
|
||
import GHC.Generics
|
||
import Prelude hiding ((.), id)
|
||
import Control.Category
|
||
import Data.List.NonEmpty (NonEmpty ((:|)))
|
||
import Gyehoek.Sexp qualified
|
||
import Control.Lens (Each)
|
||
|
||
|
||
type Name = Text
|
||
|
||
data Prim e
|
||
= PrimAdd e e
|
||
| PrimSub e e
|
||
| PrimMul e e
|
||
| PrimDiv e e
|
||
| PrimCons e e
|
||
| PrimCar e
|
||
| PrimCdr e
|
||
| PrimImmediateP e
|
||
| PrimConsP e
|
||
| PrimIntegerP e
|
||
| PrimWrite e
|
||
| PrimNewline
|
||
deriving (Show, Generic, Functor, Foldable, Traversable)
|
||
|
||
instance Each (Prim e) (Prim e') e e'
|
||
|
||
data Lit
|
||
= LitInt Int
|
||
| LitNil
|
||
| LitBool Bool
|
||
| LitString Text
|
||
| LitQuote Sexp
|
||
deriving (Show, Generic)
|
||
|
||
data Define
|
||
= DefineConstant Name Exp
|
||
| DefineProcedure Name (List Name) (List Exp)
|
||
deriving (Show, Generic)
|
||
|
||
data Exp
|
||
= ExpLet (NonEmpty (Name, Exp)) Exp
|
||
| ExpPrim (Prim Exp)
|
||
| ExpBegin (List Exp)
|
||
| ExpDefine Define
|
||
| ExpIf Exp Exp Exp
|
||
| ExpLit Lit
|
||
| ExpLambda (List Name) Exp
|
||
| ExpVar Name
|
||
| ExpApply Exp (List Exp)
|
||
deriving (Show, Generic)
|
||
|
||
data Sexp
|
||
= SexpCons Sexp Sexp
|
||
| SexpSymbol Text
|
||
| SexpLit Lit
|
||
deriving (Show, Generic)
|
||
|
||
|
||
|
||
instance SexpIso a => SexpIso (Prim a) where
|
||
sexpIso = match
|
||
$ With (. binop "+")
|
||
$ With (. binop "-")
|
||
$ With (. binop "*")
|
||
$ With (. binop "/")
|
||
$ With (. binop "cons")
|
||
$ With (. unop "car")
|
||
$ With (. unop "cdr")
|
||
$ With (. unop "immediate?")
|
||
$ With (. unop "cons?")
|
||
$ With (. unop "integer?")
|
||
$ With (. unop "write")
|
||
$ With (. nullop "newline")
|
||
$ End
|
||
where
|
||
primname = ("prim:" <>)
|
||
nullop s = list $ el (sym (primname s))
|
||
unop s = list $ el (sym (primname s)) >>> el sexpIso
|
||
binop s = list $ el (sym (primname s)) >>> el sexpIso >>> el sexpIso
|
||
|
||
instance SexpIso Lit where
|
||
sexpIso = match
|
||
$ With (. sexpIso)
|
||
$ With (. sym "nil")
|
||
$ With (. sexpIso)
|
||
$ With (. sexpIso)
|
||
$ With (. Gyehoek.Sexp.prefixSugar "quote" Sexp.Quote sexpIso)
|
||
$ End
|
||
|
||
instance SexpIso Sexp where
|
||
sexpIso = match
|
||
$ With (\cons -> cons . Gyehoek.Sexp.todo)
|
||
$ With (\s -> s . symbol)
|
||
$ With (\lit -> lit . sexpIso)
|
||
$ End
|
||
|
||
instance SexpIso Define where
|
||
sexpIso = match
|
||
$ With (. defconst)
|
||
$ With (. defun)
|
||
$ End
|
||
where
|
||
defconst = list $ el (sym "define") >>> el symbol >>> el sexpIso
|
||
defun = list $ el (sym "define") >>> el args >>> rest sexpIso
|
||
args = list $ el symbol >>> rest symbol
|
||
|
||
instance SexpIso Exp where
|
||
sexpIso = match
|
||
$ With (. Gyehoek.Sexp.let_ symbol sexpIso sexpIso)
|
||
$ With (. sexpIso)
|
||
$ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
|
||
$ With (. sexpIso)
|
||
$ With (. if_)
|
||
$ With (. sexpIso)
|
||
$ With (. lam)
|
||
$ With (. symbol)
|
||
$ With (\app -> app . list (el sexpIso >>> rest sexpIso))
|
||
$ End
|
||
where
|
||
if_ = list $ el (sym "if") >>> el sexpIso >>> el sexpIso >>> el sexpIso
|
||
lam = list
|
||
( el (sym "lambda")
|
||
>>> el (sexpIso @(List Name))
|
||
>>> el sexpIso )
|