144 lines
4.0 KiB
Haskell
144 lines
4.0 KiB
Haskell
{-# LANGUAGE PartialTypeSignatures #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE OverloadedLabels #-}
|
|
module Gyehoek.Sexp
|
|
( let_
|
|
, sexp
|
|
, nonempty
|
|
, nonEmptyGrammar
|
|
, encode
|
|
, decode
|
|
, parseSexps
|
|
, prefixSugar
|
|
, todo
|
|
, isoIso
|
|
, encodeWith
|
|
, decodeWith
|
|
, kappa
|
|
, lambda
|
|
, kappaKeyword
|
|
, lambdaKeyword
|
|
)
|
|
where
|
|
|
|
import Data.Text (Text)
|
|
import Language.SexpGrammar as Sexp hiding (List, encode, decode, encodeWith, decodeWith, iso)
|
|
import Language.SexpGrammar qualified as Sexp
|
|
import Language.Sexp qualified as S
|
|
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
|
|
import Data.Generics.Labels
|
|
import System.Process
|
|
import GHC.IO.Unsafe (unsafePerformIO)
|
|
import qualified Data.Text.IO as TIO
|
|
import Control.Monad (join)
|
|
import qualified Language.Sexp.Located as SexpLoc
|
|
import Data.Void (absurd)
|
|
|
|
|
|
sexp :: SexpIso a => Iso' a Text
|
|
sexp = iso
|
|
(either error id . encode)
|
|
(either error id . decode)
|
|
|
|
encode :: SexpIso a => a -> Either String Text
|
|
encode = encodeWith sexpIso
|
|
|
|
decode :: SexpIso a => Text -> Either String a
|
|
decode = decodeWith sexpIso
|
|
|
|
encodeWith :: SexpGrammar a -> a -> Either String Text
|
|
encodeWith g = (_Right %~ decodeUtf8 . view strict) . Sexp.encodeWith g
|
|
|
|
decodeWith :: SexpGrammar a -> Text -> Either String a
|
|
decodeWith g = Sexp.decodeWith g "FILE" . view lazy . encodeUtf8
|
|
|
|
parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a)
|
|
parseSexps f = marshal . SexpLoc.parseSexps f . view lazy . encodeUtf8
|
|
where marshal = join . traverseOf (_Right . each) (fromSexp sexpIso)
|
|
|
|
nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
|
|
nonEmptyGrammar = IGB.Iso
|
|
(\((x:|xs) :- t) -> reverse xs :- x :- t)
|
|
(\(xs :- x :- t) -> (x :| reverse xs) :- t)
|
|
|
|
nonempty :: SexpGrammar a -> SexpGrammar (NonEmpty a)
|
|
nonempty a =
|
|
list (el a >>> rest a) >>>
|
|
IG.flipped nonEmptyGrammar
|
|
|
|
let_
|
|
:: Text
|
|
-> (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_ kw name rhs e = list (el (sym kw) >>> 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 >>> _
|
|
]
|
|
|
|
-- | Define a sexp representation as either (⟨name⟩ ⟨e⟩) or '⟨e⟩.
|
|
prefixSugar
|
|
:: Text -> Prefix
|
|
-> Grammar Position (Sexp :- t') a
|
|
-> Grammar Position (Sexp :- t') a
|
|
prefixSugar name prefix e = coproduct
|
|
-- 'something
|
|
[ Sexp.prefixed prefix e
|
|
-- (quote something)
|
|
, list $ el (sym name) >>> el e
|
|
]
|
|
|
|
todo :: Grammar p (Sexp :- t) t'
|
|
todo = (IGB.Flip $ IGB.PartialIso absurd f) >>> IGB.PartialIso absurd g
|
|
where
|
|
f _ = Left $ unexpected "todo"
|
|
g _ = Left $ unexpected "todo"
|
|
|
|
kappa
|
|
:: (forall t. Grammar Position (Sexp :- t) (a :- t))
|
|
-> Grammar Position (Sexp :- List a :- t1) t2
|
|
-> Grammar Position (Sexp :- t1) t2
|
|
kappa name e = list $
|
|
el kappaKeyword
|
|
>>> el (list $ rest name)
|
|
>>> el e
|
|
|
|
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 lambdaKeyword
|
|
>>> el (list $ rest name)
|
|
>>> el e
|
|
|
|
isoIso :: Iso' s a -> Grammar p (s :- t) (a :- t)
|
|
isoIso l = Sexp.iso (view l) (review l)
|
|
|
|
kappaKeyword :: Grammar Position (Sexp :- t) t
|
|
kappaKeyword = coproduct [ sym "κ", sym "kappa" ]
|
|
|
|
lambdaKeyword :: Grammar Position (Sexp :- t) t
|
|
lambdaKeyword = coproduct [ sym "λ", sym "lambda" ]
|