130 lines
3.6 KiB
Haskell
130 lines
3.6 KiB
Haskell
{-# LANGUAGE TemplateHaskell #-}
|
|
module Gyehoek.Sexp.QQ
|
|
( makeSxs
|
|
, makeSx
|
|
, makeSx'
|
|
, sx
|
|
, sxs
|
|
, QuasiQuoter
|
|
) where
|
|
|
|
import Data.Data (Typeable, cast)
|
|
import Gyehoek.Prelude
|
|
import Gyehoek.Sexp.Syntax
|
|
import Language.Haskell.TH
|
|
import qualified Data.Text as T
|
|
import Data.List (groupBy)
|
|
import Language.Haskell.TH.Syntax (liftData, Lift (lift))
|
|
import Gyehoek.Jalmot
|
|
import Gyehoek.Sexp.Grammar
|
|
import Control.Exception (throw)
|
|
import Language.Haskell.TH.Quote (QuasiQuoter(..))
|
|
import Language.Haskell.TH.Syntax (dataToExpQ)
|
|
import qualified Gyehoek.Sexp.Read as Read
|
|
import Text.Megaparsec.Pos (mkPos)
|
|
import Gyehoek.Lift1
|
|
import Data.Foldable (toList)
|
|
|
|
|
|
extQ :: (Typeable a, Typeable b) => (a -> r) -> (b -> r) -> a -> r
|
|
extQ f g a = maybe (f a) g (cast a)
|
|
|
|
spliceMeta :: (HasCallStack, DataIso a) => a -> List Datum
|
|
spliceMeta x =
|
|
case runPureEff . runJalmot . toData dataIso $ x of
|
|
Left (cs,e) -> throw $ MkAJalmotCS cs e
|
|
Right xs -> xs
|
|
|
|
meta :: (HasCallStack, DatumIso a) => a -> Datum
|
|
meta x =
|
|
case runPureEff . runJalmot . toDatum datumIso $ x of
|
|
Left (cs,e) -> throw $ MkAJalmotCS cs e
|
|
Right xs -> xs
|
|
|
|
unquoteSplicingRecursive :: List Datum -> ExpQ
|
|
unquoteSplicingRecursive xs = [| mconcat $(spans) |]
|
|
where
|
|
spans = xs
|
|
& groupBy \cases
|
|
(MetaSplice _) _ -> False
|
|
_ (MetaSplice _) -> False
|
|
_ _ -> True
|
|
& fmap \case
|
|
[MetaSplice x] ->
|
|
[| spliceMeta $(varE (mkName (T.unpack x))) |]
|
|
es -> listE $ unquoteRecursive <$> es
|
|
& listE
|
|
|
|
unquoteRecursive :: Datum -> ExpQ
|
|
unquoteRecursive = \case
|
|
Meta x -> [| meta $(varE (mkName (T.unpack x))) |]
|
|
a :< CompoundF x -> [| $(liftData a) :< CompoundF $c|]
|
|
where
|
|
c = case x of
|
|
ListF ind xs ->
|
|
[| ListF $(lift ind) $(unquoteSplicingRecursive xs) |]
|
|
VectorF xs ->
|
|
[| VectorF $(unquoteSplicingRecursive xs) |]
|
|
DotListF xs t ->
|
|
[| DotListF $(liftLift unquoteRecursive xs) $(unquoteRecursive t) |]
|
|
AbbrevF p t ->
|
|
[| AbbrevF $(lift p) $(unquoteRecursive t) |]
|
|
e -> liftData e
|
|
|
|
|
|
|
|
getPos :: Q SourcePos
|
|
getPos = do
|
|
Loc {loc_filename,loc_start} <- location
|
|
pure $ SourcePos
|
|
{ sourceName = loc_filename
|
|
, sourceLine = mkPos $ fst loc_start
|
|
, sourceColumn = mkPos $ snd loc_start
|
|
}
|
|
|
|
readq
|
|
:: (SourcePos -> Text -> Eff '[Jalmot, IOE] a)
|
|
-> String -> Q a
|
|
readq f s = do
|
|
pos <- getPos
|
|
liftIO . runJalmotIO . f pos . T.pack $ s
|
|
|
|
makeSxs :: Data r => Code Q (List Datum -> r) -> QuasiQuoter
|
|
makeSxs f = QuasiQuoter
|
|
{ quoteExp = \str -> do
|
|
xs <- readq Read.readStringWithPos str
|
|
let e = dataToExpQ
|
|
(const Nothing
|
|
`extQ` (Just . unquoteRecursive)
|
|
`extQ` (Just . unquoteSplicingRecursive))
|
|
xs
|
|
[| $(unTypeCode f) $e |]
|
|
, 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
|
|
x <- readq Read.readStringWithPos1 str
|
|
let e = dataToExpQ
|
|
(const Nothing
|
|
`extQ` (Just . unquoteRecursive)
|
|
`extQ` (Just . unquoteSplicingRecursive))
|
|
x
|
|
[| $f $e |]
|
|
, quotePat = undefined
|
|
, quoteType = undefined
|
|
, quoteDec = undefined
|
|
}
|
|
|
|
makeSx :: Data r => Code Q (Datum -> r) -> QuasiQuoter
|
|
makeSx = makeSx' . unTypeCode
|
|
|
|
sx, sxs :: QuasiQuoter
|
|
sxs = makeSxs [|| Prelude.id @(List Datum) ||]
|
|
sx = makeSx [|| Prelude.id @Datum ||]
|