438 lines
13 KiB
Haskell
438 lines
13 KiB
Haskell
{-# LANGUAGE PartialTypeSignatures #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE OverloadedLabels #-}
|
|
{-# LANGUAGE DerivingVia #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# LANGUAGE TemplateHaskellQuotes #-}
|
|
{-# LANGUAGE OrPatterns #-}
|
|
module Gyehoek.Sexp
|
|
( let_
|
|
, sexp
|
|
, nonempty
|
|
, nonEmptyGrammar
|
|
, encode
|
|
, decode
|
|
, parseSexps
|
|
, prefixSugar
|
|
, todo
|
|
, isoIso
|
|
, encodeWith
|
|
, decodeWith
|
|
, kappa
|
|
, lambda
|
|
, kappaKeyword
|
|
, lambdaKeyword
|
|
, encodePrettyWith
|
|
, encodePretty
|
|
, UglySexpIso(..)
|
|
, AsSexpIso(..)
|
|
, SpliceSexp(..)
|
|
, parseSexpsWithPos
|
|
, parseSexpWithPos
|
|
, parseSexp
|
|
, sx
|
|
, sxs
|
|
, makeSx
|
|
, makeSxs
|
|
, makeSx'
|
|
, toSexp
|
|
, fromSexp
|
|
, stripLocation
|
|
, format
|
|
, equivalent
|
|
, encodeOrShow
|
|
)
|
|
where
|
|
|
|
import Data.Text (Text)
|
|
import Language.SexpGrammar as Sexp hiding (toSexp, List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty, fromSexp)
|
|
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.NonEmpty qualified as NE
|
|
import Data.List (List, groupBy)
|
|
import Data.Text.Encoding
|
|
import Data.Either (either)
|
|
import GHC.Generics (Generic)
|
|
import Control.Lens hiding (para)
|
|
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 SL
|
|
import Data.Void (absurd, Void)
|
|
import Data.Coerce (coerce)
|
|
import qualified Data.Map
|
|
import Language.Haskell.TH.Quote
|
|
import Language.Haskell.TH (Quote, location, Loc (..), ExpQ, varE, mkName, listE, Exp, appE, conE, Q, Code, unTypeCode)
|
|
import qualified Data.Text as T
|
|
import qualified Control.Category
|
|
import Data.Data (Data (..), Typeable, cast)
|
|
import Language.Haskell.TH.Syntax (lift, Lift, liftData)
|
|
import GHC.IsList (fromList)
|
|
import Data.Functor.Foldable (cata, para, embed)
|
|
import Data.Functor.Classes (Show1(..))
|
|
import Data.Vector (Vector)
|
|
import Numeric.Natural (Natural)
|
|
import Data.Maybe (fromMaybe)
|
|
import Control.Applicative (Alternative((<|>)))
|
|
import Debug.Pretty.Simple
|
|
import qualified Data.Vector as V
|
|
import qualified Data.Vector.Strict
|
|
import Data.Function (on)
|
|
import Data.String (IsString (fromString))
|
|
|
|
|
|
sexp :: SexpIso a => Iso' a Text
|
|
sexp = iso
|
|
(either error id . encode)
|
|
(either error id . decode)
|
|
|
|
format :: Sexp -> Text
|
|
format = decodeUtf8 . view strict . SL.format
|
|
|
|
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
|
|
|
|
encodePretty :: SexpIso a => a -> Either String Text
|
|
encodePretty = encodePrettyWith sexpIso
|
|
|
|
decodeWith :: SexpGrammar a -> Text -> Either String a
|
|
decodeWith g = Sexp.decodeWith g "FILE" . view lazy . encodeUtf8
|
|
|
|
encodePrettyWith :: SexpGrammar a -> a -> Either String Text
|
|
encodePrettyWith g =
|
|
(_Right %~ decodeUtf8 . view strict) . Sexp.encodePrettyWith g
|
|
|
|
parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a)
|
|
parseSexps f = marshal . SL.parseSexps f . view lazy . encodeUtf8
|
|
where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp sexpIso)
|
|
|
|
parseSexp :: SexpIso a => FilePath -> Text -> Either String a
|
|
parseSexp f = marshal . SL.parseSexp f . view lazy . encodeUtf8
|
|
where marshal = join . traverseOf _Right (Sexp.fromSexp sexpIso)
|
|
|
|
readSexpWithPos :: Position -> Text -> Either String Sexp
|
|
readSexpWithPos pos = SL.parseSexpWithPos pos . view lazy . encodeUtf8
|
|
|
|
readSexpsWithPos :: Position -> Text -> Either String (List Sexp)
|
|
readSexpsWithPos pos = SL.parseSexpsWithPos pos . view lazy . encodeUtf8
|
|
|
|
parseSexpsWithPos :: SexpGrammar a -> Position -> Text -> Either String (List a)
|
|
parseSexpsWithPos g pos =
|
|
marshal . SL.parseSexpsWithPos pos . view lazy . encodeUtf8
|
|
where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp g)
|
|
|
|
parseSexpWithPos :: SexpGrammar a -> Position -> Text -> Either String a
|
|
parseSexpWithPos g pos =
|
|
marshal . SL.parseSexpWithPos pos . view lazy . encodeUtf8
|
|
where marshal = join . traverseOf _Right (Sexp.fromSexp g)
|
|
|
|
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" ]
|
|
|
|
|
|
|
|
class UglySexpIso a where
|
|
uglySexpIso :: SexpGrammar a
|
|
|
|
newtype AsSexpIso a = AsSexpIso a
|
|
newtype AsUglySexpIso a = AsUglySexpIso a
|
|
|
|
asSexpIso :: Grammar p (a :- t) (AsSexpIso a :- t)
|
|
asSexpIso = Sexp.iso AsSexpIso (\(AsSexpIso x) -> x)
|
|
|
|
instance UglySexpIso a => SexpIso (AsUglySexpIso a) where
|
|
sexpIso = uglySexpIso @a >>> Sexp.iso coerce coerce
|
|
|
|
instance SexpIso a => UglySexpIso (AsSexpIso a) where
|
|
uglySexpIso = sexpIso >>> Sexp.iso (\x -> AsSexpIso x) (\(AsSexpIso x) -> x)
|
|
|
|
-- why not work
|
|
-- deriving via AsSexpIso Text instance UglySexpIso Text
|
|
|
|
instance UglySexpIso Text where uglySexpIso = sexpIso
|
|
instance UglySexpIso Integer where uglySexpIso = sexpIso
|
|
instance UglySexpIso Int where uglySexpIso = sexpIso
|
|
instance UglySexpIso Bool where uglySexpIso = sexpIso
|
|
instance UglySexpIso Double where uglySexpIso = sexpIso
|
|
instance UglySexpIso () where uglySexpIso = sexpIso
|
|
|
|
instance SexpIso Sexp where
|
|
sexpIso = Control.Category.id
|
|
|
|
-- evil ass orphan instances
|
|
deriving instance (Data a, Data e) => Data (SL.LocatedBy a e)
|
|
deriving instance Data SL.Atom
|
|
deriving instance Data SL.Prefix
|
|
deriving instance Data SL.Position
|
|
deriving instance (Data e) => Data (SL.SexpF e)
|
|
|
|
|
|
-- Quasiquoter
|
|
|
|
getPos = do
|
|
Loc {loc_filename,loc_start} <- location
|
|
pure $ SL.Position loc_filename (fst loc_start) (snd loc_start)
|
|
|
|
fromSexp :: SexpIso a => Sexp -> a
|
|
fromSexp = either error id . Sexp.fromSexp sexpIso
|
|
|
|
fromSexp' :: SexpGrammar a -> Sexp -> a
|
|
fromSexp' g = either error id . Sexp.fromSexp g
|
|
|
|
toSexp :: SexpIso a => a -> Sexp
|
|
toSexp = either error id . Sexp.toSexp sexpIso
|
|
|
|
toSexps :: (Foldable f, SexpIso a) => f a -> List Sexp
|
|
toSexps = foldMap \x -> [toSexp x]
|
|
|
|
pattern Unquote x =
|
|
SL.Modified Hash (SL.BraceList [SL.Symbol x])
|
|
pattern UnquoteSplicing x =
|
|
SL.Modified Hash (SL.Modified Hash (SL.BraceList [SL.Symbol x]))
|
|
|
|
_UnquoteSplicing :: Prism' Sexp.Sexp Text
|
|
_UnquoteSplicing = prism'
|
|
UnquoteSplicing
|
|
(\case { UnquoteSplicing x -> Just x ; _ -> Nothing })
|
|
|
|
instance Each Sexp Sexp Sexp Sexp where
|
|
each k (SL.ParenList xs) = SL.ParenList <$> traverse k xs
|
|
each k (SL.BracketList xs) = SL.BracketList <$> traverse k xs
|
|
each k (SL.BraceList xs) = SL.BraceList <$> traverse k xs
|
|
each _ e@(SL.Atom _; SL.Modified _ _) = pure e
|
|
|
|
stripLocation :: Sexp -> Sexp
|
|
stripLocation = cata \case
|
|
SL.Compose (a SL.:< e) ->
|
|
SL.Fix . SL.Compose $ SL.dummyPos SL.:< e
|
|
|
|
-- | @('==')@ for 'Sexp's modulo source location — return true if the
|
|
-- two sexps are equal in all but 'Position' fields.
|
|
equivalent :: Sexp -> Sexp -> Bool
|
|
equivalent = (==) `on` stripLocation
|
|
|
|
instance SexpIso Natural where
|
|
sexpIso = Sexp.integer >>> Sexp.partialOsi f g
|
|
where
|
|
f n | n < 0 = Left $ Sexp.unexpected "negative"
|
|
<> Sexp.expected "natural"
|
|
| otherwise = Right $ fromIntegral n
|
|
g n = fromIntegral n
|
|
|
|
class SpliceSexp a where
|
|
spliceSexp :: a -> List Sexp
|
|
|
|
instance SexpIso a => SpliceSexp (Data.Vector.Strict.Vector a) where
|
|
spliceSexp = toSexps
|
|
|
|
instance SexpIso a => SpliceSexp (Vector a) where
|
|
spliceSexp = toSexps
|
|
|
|
instance SexpIso a => SpliceSexp (List a) where
|
|
spliceSexp = toSexps
|
|
|
|
instance SpliceSexp Sexp where
|
|
spliceSexp = toListOf each
|
|
|
|
unquoteSplicingRecursive :: List Sexp.Sexp -> ExpQ
|
|
unquoteSplicingRecursive xs = [| mconcat $(spans) |]
|
|
where
|
|
spans = xs
|
|
& groupBy \cases
|
|
(UnquoteSplicing _) _ -> False
|
|
_ (UnquoteSplicing _) -> False
|
|
_ _ -> True
|
|
& fmap \case
|
|
-- [e@(Unquote _)] ->
|
|
-- case unquote e of
|
|
-- Just x -> [| [$(x)] |]
|
|
-- Nothing -> error "unreachable"
|
|
[UnquoteSplicing x] ->
|
|
[| spliceSexp $(varE (mkName (T.unpack x))) |]
|
|
es -> listE $ unquoteRecursive <$> es
|
|
& listE
|
|
|
|
unquoteRecursive :: Sexp.Sexp -> ExpQ
|
|
unquoteRecursive = \case
|
|
Unquote x -> [| toSexp $(varE (mkName (T.unpack x))) |]
|
|
SL.ParenList xs -> [|SL.ParenList $(unquoteSplicingRecursive xs)|]
|
|
e -> liftData e
|
|
|
|
_ParenList :: Prism' Sexp (List Sexp)
|
|
_ParenList = prism' SL.ParenList \case
|
|
SL.ParenList xs -> Just xs
|
|
_ -> Nothing
|
|
|
|
metaSexps :: List Sexp.Sexp -> Maybe ExpQ
|
|
metaSexps = Just . unquoteSplicingRecursive
|
|
|
|
metaSexp :: Sexp.Sexp -> Maybe ExpQ
|
|
metaSexp = Just . unquoteRecursive
|
|
|
|
-- 뻘짓뻘짓뻘짓뻘짓뻘짓
|
|
class Lift1 f where
|
|
liftLift :: Quote m => (a -> m Exp) -> f a -> m Exp
|
|
|
|
lift1 :: (Lift1 f, Lift a, Quote m) => f a -> m Exp
|
|
lift1 = liftLift lift
|
|
|
|
instance Lift1 f => Lift (SL.Fix f) where
|
|
lift (SL.Fix inner) = appE [|SL.Fix|] (lift1 inner)
|
|
|
|
instance (Lift1 f, Lift1 g) => Lift1 (SL.Compose f g) where
|
|
liftLift l (SL.Compose fga) = [|SL.Compose $(liftLift (liftLift l) fga)|]
|
|
|
|
instance Lift a => Lift1 (SL.LocatedBy a) where
|
|
liftLift l (a SL.:< e) = [|(SL.:<) $(lift a) $(l e)|]
|
|
|
|
instance Lift1 List where
|
|
liftLift l xs = listE $ l <$> xs
|
|
|
|
instance Lift1 SL.SexpF where
|
|
liftLift l = \case
|
|
SL.AtomF a -> [|SL.AtomF $(lift a)|]
|
|
SL.ParenListF es -> [|SL.ParenListF $(liftLift l es)|]
|
|
SL.BracketListF es -> [|SL.BracketListF $(liftLift l es)|]
|
|
SL.BraceListF es -> [|SL.BraceListF $(liftLift l es)|]
|
|
SL.ModifiedF p e -> [|SL.ModifiedF $(lift p) $(l e)|]
|
|
|
|
-- deriving instance Lift a => Lift (SL.SexpF a)
|
|
deriving instance Lift SL.Atom
|
|
deriving instance Lift SL.Position
|
|
deriving instance Lift SL.Prefix
|
|
|
|
encodeOrShow :: (SexpIso a, Show a, IsString s) => a -> s
|
|
encodeOrShow a = fromString case encode a of
|
|
Left _ -> show a
|
|
Right e -> T.unpack e
|
|
|
|
extQ :: (Typeable a, Typeable b) => (a -> r) -> (b -> r) -> a -> r
|
|
extQ f g a = maybe (f a) g (cast a)
|
|
|
|
makeSxs :: Data r => Code Q (List Sexp -> r) -> QuasiQuoter
|
|
makeSxs f = QuasiQuoter
|
|
{ quoteExp = \str -> do
|
|
pos <- getPos
|
|
case readSexpsWithPos pos (T.pack str) of
|
|
Left e -> fail e
|
|
Right xs -> [| $(unTypeCode f) $e |]
|
|
where
|
|
e = dataToExpQ
|
|
(const Nothing `extQ` metaSexp `extQ` metaSexps)
|
|
xs
|
|
, quotePat = undefined
|
|
, quoteType = undefined
|
|
, quoteDec = undefined
|
|
}
|
|
|
|
-- | An untyped variant of 'makeSx', useful when the user function is
|
|
-- polymorphic in its return value.
|
|
makeSx' :: ExpQ -> QuasiQuoter
|
|
makeSx' f = QuasiQuoter
|
|
{ quoteExp = \str -> do
|
|
pos <- getPos
|
|
case readSexpWithPos pos (T.pack str) of
|
|
Left e -> fail e
|
|
Right x -> [| $f $e |]
|
|
where
|
|
e = dataToExpQ
|
|
(const Nothing `extQ` metaSexp `extQ` metaSexps)
|
|
x
|
|
, quotePat = undefined
|
|
, quoteType = undefined
|
|
, quoteDec = undefined
|
|
}
|
|
|
|
makeSx :: Data r => Code Q (Sexp -> r) -> QuasiQuoter
|
|
makeSx = makeSx' . unTypeCode
|
|
|
|
sxs = makeSxs [||id||]
|
|
sx = makeSx [||id||]
|