{-# options_haddock prune #-}
module Exon.Quote where
import Language.Haskell.Meta.Parse (parseExpWithExts)
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 (exonProcess, exonProcessWith)
import Exon.Class.ToSegment (toSegment)
import Exon.Data.RawSegment (RawSegment (AutoExpSegment, ExpSegment, StringSegment, WsSegment))
import qualified Exon.Data.Segment as Segment
import Exon.Parse (parse, parseWs)
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 =>
Bool ->
String ->
m (NonEmpty RawSegment)
segmentsQ :: forall (m :: * -> *).
QOrIO m =>
Bool -> String -> m (NonEmpty RawSegment)
segmentsQ Bool
_ String
"" =
forall e (m :: * -> *) a. (ToString e, MonadFail m) => e -> m a
exonError (String
"empty quasiquote" :: String)
segmentsQ Bool
whitespace String
s =
(if Bool
whitespace then String -> Either Text [RawSegment]
parseWs else 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 [TH.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 =
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 [Extension] -> String -> Either (Int, Int, String) Exp
parseExpWithExts [Extension]
exts String
s of
Left (Int
_, Int
_, String
err) -> forall e (m :: * -> *) a. (ToString e, MonadFail m) => e -> m a
exonError String
err
Right Exp
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
e
reifySegments ::
QOrIO m =>
Bool ->
NonEmpty RawSegment ->
m (NonEmpty Exp)
reifySegments :: forall (m :: * -> *).
QOrIO m =>
Bool -> NonEmpty RawSegment -> m (NonEmpty Exp)
reifySegments Bool
unsafe NonEmpty RawSegment
segs = do
Exp
expCon <- forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e|Segment.Expression|]
Exp
expToSegment <- forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e|toSegment|]
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 | Bool
unsafe -> do
Exp
e <- forall (m :: * -> *). QOrIO m => String -> m Exp
reifyExp String
s
pure (Exp -> Exp -> Exp
AppE Exp
expCon (Exp -> Exp -> Exp
AppE Exp
expToSegment Exp
e))
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)
AutoExpSegment String
s -> do
Exp
e <- forall (m :: * -> *). QOrIO m => String -> m Exp
reifyExp String
s
pure (Exp -> Exp -> Exp
AppE Exp
expCon (Exp -> Exp -> Exp
AppE Exp
expToSegment Exp
e))
WsSegment String
s ->
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e|Segment.Whitespace s|]
quoteExpWith ::
QOrIO m =>
Maybe (Q TH.Exp, Q TH.Exp) ->
Bool ->
Bool ->
String ->
m Exp
quoteExpWith :: forall (m :: * -> *).
QOrIO m =>
Maybe (Q Exp, Q Exp) -> Bool -> Bool -> String -> m Exp
quoteExpWith Maybe (Q Exp, Q Exp)
wrapper Bool
whitespace Bool
unsafe String
code = do
NonEmpty RawSegment
raw <- forall (m :: * -> *).
QOrIO m =>
Bool -> String -> m (NonEmpty RawSegment)
segmentsQ Bool
whitespace String
code
Exp
hseg :| [Exp]
segs <- forall (m :: * -> *).
QOrIO m =>
Bool -> NonEmpty RawSegment -> m (NonEmpty Exp)
reifySegments Bool
unsafe NonEmpty RawSegment
raw
Exp
conc <- forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [e|exonProcess|] forall {m :: * -> *}. Quote m => (m Exp, m Exp) -> m Exp
wrapped Maybe (Q Exp, Q Exp)
wrapper
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))))
where
wrapped :: (m Exp, m Exp) -> m Exp
wrapped (m Exp
wrap, m Exp
unwrap) = do
[e|exonProcessWith ($wrap) $(unwrap)|]
quoteExp ::
QOrIO m =>
Bool ->
Bool ->
String ->
m Exp
quoteExp :: forall (m :: * -> *). QOrIO m => Bool -> Bool -> String -> m Exp
quoteExp =
forall (m :: * -> *).
QOrIO m =>
Maybe (Q Exp, Q Exp) -> Bool -> Bool -> String -> m Exp
quoteExpWith forall a. Maybe a
Nothing
quoteSegments ::
QOrIO m =>
String ->
m Exp
quoteSegments :: forall (m :: * -> *). QOrIO m => String -> m Exp
quoteSegments String
code = do
NonEmpty RawSegment
raw <- forall (m :: * -> *).
QOrIO m =>
Bool -> String -> m (NonEmpty RawSegment)
segmentsQ Bool
True String
code
Exp
hseg :| [Exp]
segs <- forall (m :: * -> *).
QOrIO m =>
Bool -> NonEmpty RawSegment -> m (NonEmpty Exp)
reifySegments Bool
False NonEmpty RawSegment
raw
Exp
consE <- forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e|(:|)|]
pure (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)))
exonWith ::
Maybe (Q TH.Exp, Q TH.Exp) ->
Bool ->
Bool ->
QuasiQuoter
exonWith :: Maybe (Q Exp, Q Exp) -> Bool -> Bool -> QuasiQuoter
exonWith Maybe (Q Exp, Q Exp)
wrapper Bool
whitespace Bool
unsafe =
(String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter (forall (m :: * -> *).
QOrIO m =>
Maybe (Q Exp, Q Exp) -> Bool -> Bool -> String -> m Exp
quoteExpWith Maybe (Q Exp, Q Exp)
wrapper Bool
whitespace Bool
unsafe) (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 =
Maybe (Q Exp, Q Exp) -> Bool -> Bool -> QuasiQuoter
exonWith forall a. Maybe a
Nothing Bool
False Bool
False
exun :: QuasiQuoter
exun :: QuasiQuoter
exun =
Maybe (Q Exp, Q Exp) -> Bool -> Bool -> QuasiQuoter
exonWith forall a. Maybe a
Nothing Bool
False Bool
True
exonws :: QuasiQuoter
exonws :: QuasiQuoter
exonws =
Maybe (Q Exp, Q Exp) -> Bool -> Bool -> QuasiQuoter
exonWith forall a. Maybe a
Nothing Bool
True Bool
False
exonSegments :: QuasiQuoter
exonSegments :: QuasiQuoter
exonSegments =
(String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter forall (m :: * -> *). QOrIO m => String -> m Exp
quoteSegments (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)