112 lines
3.2 KiB
Haskell
112 lines
3.2 KiB
Haskell
{-# LANGUAGE PartialTypeSignatures #-}
|
||
{-# LANGUAGE TypeOperators #-}
|
||
{-# LANGUAGE OverloadedStrings #-}
|
||
{-# LANGUAGE OverloadedLabels #-}
|
||
module Gyehoek.Sexp
|
||
( let_
|
||
, sexp
|
||
, nonempty
|
||
, nonEmptyGrammar
|
||
, encode
|
||
, decode
|
||
, parseSexps
|
||
, prefixSugar
|
||
, todo
|
||
)
|
||
where
|
||
|
||
import Data.Text (Text)
|
||
import Language.SexpGrammar as Sexp hiding (List, encode, decode, 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 = (_Right %~ decodeUtf8 . view strict) . Sexp.encode
|
||
|
||
decode :: SexpIso a => Text -> Either String a
|
||
decode = Sexp.decode . 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_
|
||
:: (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 >>> _
|
||
]
|
||
|
||
-- | 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"
|
||
|
||
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
|