+149
-4
@@ -4,6 +4,8 @@
|
||||
{-# LANGUAGE OverloadedLabels #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskellQuotes #-}
|
||||
{-# LANGUAGE OrPatterns #-}
|
||||
module Gyehoek.Sexp
|
||||
( let_
|
||||
, sexp
|
||||
@@ -25,11 +27,18 @@ module Gyehoek.Sexp
|
||||
, encodePretty
|
||||
, UglySexpIso(..)
|
||||
, AsSexpIso(..)
|
||||
, parseSexpsWithPos
|
||||
, parseSexpWithPos
|
||||
, parseSexp
|
||||
, sx
|
||||
, sxs
|
||||
, makeSx
|
||||
, makeSxs
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Language.SexpGrammar as Sexp hiding (List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty)
|
||||
import Language.SexpGrammar as Sexp hiding (toSexp, List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty)
|
||||
import Language.SexpGrammar qualified as Sexp
|
||||
import Language.Sexp qualified as S
|
||||
import Language.SexpGrammar.Generic
|
||||
@@ -37,7 +46,8 @@ 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.List.NonEmpty qualified as NE
|
||||
import Data.List (List, groupBy)
|
||||
import Data.Text.Encoding
|
||||
import Data.Either (either)
|
||||
import GHC.Generics (Generic)
|
||||
@@ -47,10 +57,16 @@ 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 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)
|
||||
import qualified Data.Text as T
|
||||
import qualified Control.Category
|
||||
import Data.Data (Data, Typeable, cast)
|
||||
import Language.Haskell.TH.Syntax (lift, Lift)
|
||||
|
||||
|
||||
sexp :: SexpIso a => Iso' a Text
|
||||
@@ -78,9 +94,23 @@ encodePrettyWith g =
|
||||
(_Right %~ decodeUtf8 . view strict) . Sexp.encodePrettyWith g
|
||||
|
||||
parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a)
|
||||
parseSexps f = marshal . SexpLoc.parseSexps f . view lazy . encodeUtf8
|
||||
parseSexps f = marshal . SL.parseSexps f . view lazy . encodeUtf8
|
||||
where marshal = join . traverseOf (_Right . each) (fromSexp sexpIso)
|
||||
|
||||
parseSexp :: SexpIso a => FilePath -> Text -> Either String a
|
||||
parseSexp f = marshal . SL.parseSexp f . view lazy . encodeUtf8
|
||||
where marshal = join . traverseOf _Right (fromSexp sexpIso)
|
||||
|
||||
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) (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 (fromSexp g)
|
||||
|
||||
nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
|
||||
nonEmptyGrammar = IGB.Iso
|
||||
(\((x:|xs) :- t) -> reverse xs :- x :- t)
|
||||
@@ -183,3 +213,118 @@ 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)
|
||||
|
||||
makeSxs :: Data b => SexpGrammar a -> (List a -> b) -> QuasiQuoter
|
||||
makeSxs g f = QuasiQuoter
|
||||
{ quoteExp = \str -> do
|
||||
pos <- getPos
|
||||
case parseSexpsWithPos g pos (T.pack str) of
|
||||
Left e -> fail e
|
||||
Right xs -> dataToExpQ (const Nothing) (f xs)
|
||||
, quotePat = undefined
|
||||
, quoteType = undefined
|
||||
, quoteDec = undefined
|
||||
}
|
||||
|
||||
toSexp :: SexpIso a => a -> Sexp
|
||||
toSexp = either error id . Sexp.toSexp sexpIso
|
||||
|
||||
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
|
||||
|
||||
metaSexp :: Sexp.Sexp -> Maybe ExpQ
|
||||
metaSexp (Unquote x) =
|
||||
Just [| toSexp $(varE (mkName (T.unpack x))) |]
|
||||
metaSexp (SL.ParenList xs)
|
||||
| (_:_) <- xs ^.. each . _UnquoteSplicing
|
||||
= Just [| SL.ParenList (mconcat $(listE spans)) |]
|
||||
where
|
||||
spans = xs
|
||||
& groupBy \cases
|
||||
(UnquoteSplicing _) _ -> False
|
||||
_ (UnquoteSplicing _) -> False
|
||||
_ _ -> True
|
||||
& fmap \case
|
||||
[UnquoteSplicing x] -> varE (mkName (T.unpack x))
|
||||
x -> lift x
|
||||
metaSexp _ = Nothing
|
||||
|
||||
-- 뻘짓뻘짓뻘짓뻘짓뻘짓
|
||||
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 [|Fix|] (lift1 inner)
|
||||
|
||||
instance (Lift1 f, Lift1 g) => Lift1 (SL.Compose f g) where
|
||||
liftLift l (SL.Compose fga) = [|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.Modified $(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
|
||||
|
||||
extQ :: (Typeable a, Typeable b) => (a -> r) -> (b -> r) -> a -> r
|
||||
extQ f g a = maybe (f a) g (cast a)
|
||||
|
||||
makeSx :: Data a => SexpGrammar a -> QuasiQuoter
|
||||
makeSx g = QuasiQuoter
|
||||
{ quoteExp = \str -> do
|
||||
pos <- getPos
|
||||
case parseSexpWithPos g pos (T.pack str) of
|
||||
Left e -> fail e
|
||||
Right x -> dataToExpQ (const Nothing `extQ` metaSexp) x
|
||||
, quotePat = undefined
|
||||
, quoteType = undefined
|
||||
, quoteDec = undefined
|
||||
}
|
||||
|
||||
sxs = makeSxs (sexpIso @Sexp) id
|
||||
sx = makeSx (sexpIso @Sexp)
|
||||
|
||||
Reference in New Issue
Block a user