78 lines
2.2 KiB
Haskell
78 lines
2.2 KiB
Haskell
{-# LANGUAGE PartialTypeSignatures #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module Gyehoek.Sexp
|
|
( let_
|
|
, sexp
|
|
, nonempty
|
|
, nonEmptyGrammar
|
|
, encode
|
|
, decode
|
|
)
|
|
where
|
|
|
|
import Data.Text (Text)
|
|
import Language.SexpGrammar as Sexp hiding (List, encode, decode, iso)
|
|
import Language.SexpGrammar qualified as Sexp
|
|
import Language.SexpGrammar.Generic
|
|
import Data.InvertibleGrammar.Base qualified as IGB
|
|
import Data.InvertibleGrammar qualified as IG
|
|
import Data.InvertibleGrammar.Base ((:-)((:-)))
|
|
import Data.List.NonEmpty (NonEmpty ((:|)))
|
|
import Data.List (List)
|
|
import Data.Text.Encoding
|
|
import Data.Either (either)
|
|
import GHC.Generics (Generic)
|
|
import Control.Lens
|
|
|
|
|
|
sexp :: SexpIso a => Iso' a Text
|
|
sexp = iso
|
|
(either error id . encode)
|
|
(either error id . decode)
|
|
|
|
encode :: SexpIso a => a -> Either String Text
|
|
encode = (_Right %~ decodeUtf8 . view strict) . Sexp.encode
|
|
|
|
decode :: SexpIso a => Text -> Either String a
|
|
decode = Sexp.decode . view lazy . encodeUtf8
|
|
|
|
nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
|
|
nonEmptyGrammar = IGB.Iso
|
|
(\((x:|xs) :- t) -> xs :- x :- t)
|
|
(\(xs :- x :- t) -> (x:|xs) :- t)
|
|
|
|
nonempty :: SexpGrammar a -> SexpGrammar (NonEmpty a)
|
|
nonempty a =
|
|
list (el a >>> rest a) >>>
|
|
IG.flipped nonEmptyGrammar
|
|
|
|
let_
|
|
:: (forall t. Grammar Position (Sexp :- t) (a :- t))
|
|
-> (forall t. Grammar Position (Sexp :- t) (b :- t))
|
|
-> Grammar Position (Sexp :- (NonEmpty (a, b) :- t1)) t2
|
|
-> Grammar Position (Sexp :- t1) t2
|
|
let_ name rhs e = list (el (sym "let") >>> el bindings >>> el e)
|
|
where
|
|
-- bindings :: Grammar Position (Sexp :- _) (List (_, _) :- _)
|
|
bindings = nonempty binding
|
|
binding :: Grammar Position (Sexp :- t) ((_, _) :- t)
|
|
binding = list (el name >>> el rhs) >>> pair
|
|
|
|
data DotList a = MkDotList (NonEmpty a) a
|
|
deriving (Show, Generic)
|
|
|
|
dotlist :: (forall t. Grammar Position (Sexp :- t) (a :- t)) -> _
|
|
dotlist x = list $ rest $ coproduct
|
|
[ x >>> _
|
|
]
|
|
|
|
lambda
|
|
:: (forall t. Grammar Position (Sexp :- t) (a :- t))
|
|
-> Grammar Position (Sexp :- List a :- t1) t2
|
|
-> Grammar Position (Sexp :- t1) t2
|
|
lambda name e = list $
|
|
el (sym "lambda")
|
|
>>> el (list $ rest name)
|
|
>>> el e
|