{-# options_haddock prune #-}
module Exon.Quote where
import Language.Haskell.Exts (
Extension,
ParseMode (extensions),
ParseResult (ParseFailed, ParseOk),
defaultParseMode,
parseExpWithMode,
parseExtension,
)
import Language.Haskell.Meta (toExp)
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH (Exp (AppE, InfixE, ListE), Q, extsEnabled, runQ)
import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter))
import Language.Haskell.TH.Syntax (Quasi)
import Exon.Class.Exon (ExonDefault, KeepWhitespace, concatSegments)
import Exon.Data.RawSegment (RawSegment (ExpSegment, StringSegment, WsSegment))
import qualified Exon.Data.Segment as Segment
import Exon.Parse (parse)
exonError ::
ToString e =>
MonadFail m =>
e ->
m a
exonError :: forall e (m :: * -> *) a. (ToString e, MonadFail m) => e -> m a
exonError e
err =
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Exon: " forall a. Semigroup a => a -> a -> a
<> forall a. ToString a => a -> String
toString e
err)
segmentsQ ::
QOrIO m =>
String ->
m (NonEmpty RawSegment)
segmentsQ :: forall (m :: * -> *). QOrIO m => String -> m (NonEmpty RawSegment)
segmentsQ String
"" =
forall e (m :: * -> *) a. (ToString e, MonadFail m) => e -> m a
exonError (String
"empty interpolation" :: String)
segmentsQ String
s =
String -> Either Text [RawSegment]
parse String
s forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall a b. a -> (a -> b) -> b
& \case
Right (Just NonEmpty RawSegment
segs) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty RawSegment
segs
Right Maybe (NonEmpty RawSegment)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> RawSegment
StringSegment String
""))
Left Text
err -> forall e (m :: * -> *) a. (ToString e, MonadFail m) => e -> m a
exonError Text
err
class Quasi m => QOrIO (m :: Type -> Type) where
fileExtensions :: m [Extension]
instance QOrIO IO where
fileExtensions :: IO [Extension]
fileExtensions =
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
instance QOrIO Q where
fileExtensions :: Q [Extension]
fileExtensions =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Extension
parseExtension forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. (Show a, IsString b) => a -> b
show)) Q [Extension]
extsEnabled
reifyExp ::
QOrIO m =>
String ->
m Exp
reifyExp :: forall (m :: * -> *). QOrIO m => String -> m Exp
reifyExp String
s = do
[Extension]
exts <- forall (m :: * -> *). QOrIO m => m [Extension]
fileExtensions
case ParseMode -> String -> ParseResult (Exp SrcSpanInfo)
parseExpWithMode ParseMode
defaultParseMode { extensions :: [Extension]
extensions = [Extension]
exts } String
s of
ParseFailed SrcLoc
_ String
err -> forall e (m :: * -> *) a. (ToString e, MonadFail m) => e -> m a
exonError String
err
ParseOk Exp SrcSpanInfo
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. ToExp a => a -> Exp
toExp Exp SrcSpanInfo
e)
reifySegments ::
QOrIO m =>
NonEmpty RawSegment ->
m (NonEmpty Exp)
reifySegments :: forall (m :: * -> *).
QOrIO m =>
NonEmpty RawSegment -> m (NonEmpty Exp)
reifySegments NonEmpty RawSegment
segs = do
Exp
expCon <- forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e|Segment.Expression|]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for NonEmpty RawSegment
segs \case
StringSegment String
s ->
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e|Segment.String s|]
ExpSegment String
s -> do
Exp
e <- forall (m :: * -> *). QOrIO m => String -> m Exp
reifyExp String
s
pure (Exp -> Exp -> Exp
AppE Exp
expCon Exp
e)
WsSegment String
s ->
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e|Segment.Whitespace s|]
quoteExpWith ::
QOrIO m =>
Q TH.Type ->
String ->
m Exp
quoteExpWith :: forall (m :: * -> *). QOrIO m => Q Type -> String -> m Exp
quoteExpWith Q Type
tag String
code = do
NonEmpty RawSegment
raw <- forall (m :: * -> *). QOrIO m => String -> m (NonEmpty RawSegment)
segmentsQ String
code
Exp
hseg :| [Exp]
segs <- forall (m :: * -> *).
QOrIO m =>
NonEmpty RawSegment -> m (NonEmpty Exp)
reifySegments NonEmpty RawSegment
raw
Exp
conc <- forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e|concatSegments @($tag)|]
Exp
consE <- forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e|(:|)|]
pure (Exp -> Exp -> Exp
AppE Exp
conc (Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (forall a. a -> Maybe a
Just Exp
hseg) Exp
consE (forall a. a -> Maybe a
Just ([Exp] -> Exp
ListE [Exp]
segs))))
quoteExp ::
QOrIO m =>
String ->
m Exp
quoteExp :: forall (m :: * -> *). QOrIO m => String -> m Exp
quoteExp =
forall (m :: * -> *). QOrIO m => Q Type -> String -> m Exp
quoteExpWith [t|ExonDefault|]
exonWith :: Q TH.Type -> QuasiQuoter
exonWith :: Q Type -> QuasiQuoter
exonWith Q Type
tag =
(String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter (forall (m :: * -> *). QOrIO m => Q Type -> String -> m Exp
quoteExpWith Q Type
tag) (forall a. String -> String -> Q a
err String
"pattern") (forall a. String -> String -> Q a
err String
"type") (forall a. String -> String -> Q a
err String
"decl")
where
err :: String -> String -> Q a
err :: forall a. String -> String -> Q a
err String
tpe String
_ =
forall e (m :: * -> *) a. (ToString e, MonadFail m) => e -> m a
exonError (String
"Cannot quote " forall a. Semigroup a => a -> a -> a
<> String
tpe)
exon :: QuasiQuoter
exon :: QuasiQuoter
exon =
Q Type -> QuasiQuoter
exonWith [t|ExonDefault|]
exonws :: QuasiQuoter
exonws :: QuasiQuoter
exonws =
Q Type -> QuasiQuoter
exonWith [t|KeepWhitespace|]