{-# options_haddock prune #-}

-- |Description: Internal
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 (SkipWs (SkipWs), exonProcess, exonProcessWith, skipWs)
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 =
  String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Exon: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> e -> String
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
"" =
  String -> m (NonEmpty RawSegment)
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 Either Text [RawSegment]
-> (Either Text [RawSegment]
    -> Either Text (Maybe (NonEmpty RawSegment)))
-> Either Text (Maybe (NonEmpty RawSegment))
forall a b. a -> (a -> b) -> b
& ([RawSegment] -> Maybe (NonEmpty RawSegment))
-> Either Text [RawSegment]
-> Either Text (Maybe (NonEmpty RawSegment))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [RawSegment] -> Maybe (NonEmpty RawSegment)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty Either Text (Maybe (NonEmpty RawSegment))
-> (Either Text (Maybe (NonEmpty RawSegment))
    -> m (NonEmpty RawSegment))
-> m (NonEmpty RawSegment)
forall a b. a -> (a -> b) -> b
& \case
    Right (Just NonEmpty RawSegment
segs) -> NonEmpty RawSegment -> m (NonEmpty RawSegment)
forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty RawSegment
segs
    Right Maybe (NonEmpty RawSegment)
Nothing -> NonEmpty RawSegment -> m (NonEmpty RawSegment)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RawSegment -> NonEmpty RawSegment
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> RawSegment
StringSegment String
""))
    Left Text
err -> Text -> m (NonEmpty RawSegment)
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 =
    [Extension] -> IO [Extension]
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 <- m [Extension]
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) -> String -> m Exp
forall e (m :: * -> *) a. (ToString e, MonadFail m) => e -> m a
exonError String
err
    Right Exp
e -> Exp -> m Exp
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 <- Q Exp -> m Exp
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e|Segment.Expression|]
  Exp
expToSegment <- Q Exp -> m Exp
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e|toSegment|]
  NonEmpty RawSegment -> (RawSegment -> m Exp) -> m (NonEmpty Exp)
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 ->
      Q Exp -> m Exp
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e|Segment.String s|]
    ExpSegment String
s | Bool
unsafe -> do
      Exp
e <- String -> m Exp
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 <- String -> m Exp
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 <- String -> m Exp
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 ->
     Q Exp -> m Exp
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 <- Bool -> String -> m (NonEmpty RawSegment)
forall (m :: * -> *).
QOrIO m =>
Bool -> String -> m (NonEmpty RawSegment)
segmentsQ Bool
whitespace String
code
  Exp
hseg :| [Exp]
segs <- Bool -> NonEmpty RawSegment -> m (NonEmpty Exp)
forall (m :: * -> *).
QOrIO m =>
Bool -> NonEmpty RawSegment -> m (NonEmpty Exp)
reifySegments Bool
unsafe NonEmpty RawSegment
raw
  Exp
conc <- Q Exp -> m Exp
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ (Q Exp -> m Exp) -> Q Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> ((Q Exp, Q Exp) -> Q Exp) -> Maybe (Q Exp, Q Exp) -> Q Exp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [e|exonProcess|] (Q Exp, Q Exp) -> Q Exp
forall {m :: * -> *}. Quote m => (m Exp, m Exp) -> m Exp
wrapped Maybe (Q Exp, Q Exp)
wrapper
  Exp
consE <- Q Exp -> m Exp
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 (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
hseg) Exp
consE (Exp -> Maybe Exp
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 =
  Maybe (Q Exp, Q Exp) -> Bool -> Bool -> String -> m Exp
forall (m :: * -> *).
QOrIO m =>
Maybe (Q Exp, Q Exp) -> Bool -> Bool -> String -> m Exp
quoteExpWith Maybe (Q Exp, Q Exp)
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 <- Bool -> String -> m (NonEmpty RawSegment)
forall (m :: * -> *).
QOrIO m =>
Bool -> String -> m (NonEmpty RawSegment)
segmentsQ Bool
True String
code
  Exp
hseg :| [Exp]
segs <- Bool -> NonEmpty RawSegment -> m (NonEmpty Exp)
forall (m :: * -> *).
QOrIO m =>
Bool -> NonEmpty RawSegment -> m (NonEmpty Exp)
reifySegments Bool
False NonEmpty RawSegment
raw
  Exp
consE <- Q Exp -> m Exp
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e|(:|)|]
  pure (Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
hseg) Exp
consE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just ([Exp] -> Exp
ListE [Exp]
segs)))

-- |Constructor for a quasiquoter that wraps all segments with the first expression and unwraps the result with the
-- second.
--
-- This can be used to define quoters with custom logic by providing instances of any of the classes in
-- "Exon.Class.Exon" with the result type argument set to the wrapper type:
--
-- >>> import Exon.Class.Exon (ExonString (..))
-- >>> import Exon.Data.Segment (Segment(String))
-- >>> import qualified Data.Text.Lazy.Builder as Text
-- >>> newtype Nl = Nl Text deriving (Generic)
-- >>> getNl (Nl t) = t
-- >>> instance ExonString Nl Text.Builder where exonWhitespace _ = exonString @Nl "\n"
-- >>> exonnl = exonWith (Just ([e|Nl|], [e|getNl|])) True False
-- >>> [exonnl|one   two     three|]
-- "one\ntwo\nthree"
--
-- @since 0.2.0.0
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 (Maybe (Q Exp, Q Exp) -> Bool -> Bool -> String -> Q Exp
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 -> String -> Q Pat
forall a. String -> String -> Q a
err String
"pattern") (String -> String -> Q Type
forall a. String -> String -> Q a
err String
"type") (String -> String -> Q [Dec]
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
_ =
      String -> Q a
forall e (m :: * -> *) a. (ToString e, MonadFail m) => e -> m a
exonError (String
"Cannot quote " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
tpe)

-- |A quasiquoter that allows interpolation, concatenating the resulting segments with '(<>)' or a an arbitrary
-- user-defined implementation.
-- See the [introduction]("Exon") for details.
--
-- >>> [exon|write #{show (5 :: Int)} lines of ##{"code" :: ByteString}|] :: Text
-- "write 5 lines of code"
exon :: QuasiQuoter
exon :: QuasiQuoter
exon =
  Maybe (Q Exp, Q Exp) -> Bool -> Bool -> QuasiQuoter
exonWith Maybe (Q Exp, Q Exp)
forall a. Maybe a
Nothing Bool
False Bool
False

-- |Unsafe version of 'exon', allowing automatic conversion with the same splice brackets as matching types.
--
-- @since 1.0.0.0
exun :: QuasiQuoter
exun :: QuasiQuoter
exun =
  Maybe (Q Exp, Q Exp) -> Bool -> Bool -> QuasiQuoter
exonWith Maybe (Q Exp, Q Exp)
forall a. Maybe a
Nothing Bool
False Bool
True

-- |A variant of 'exon' that ignores all literal whitespace in the quote (not in interpolated expressions).
--
-- > [intron|x|] === skipWs [exonws|x|]
--
-- @since 1.0.0.0
intron :: QuasiQuoter
intron :: QuasiQuoter
intron =
  Maybe (Q Exp, Q Exp) -> Bool -> Bool -> QuasiQuoter
exonWith ((Q Exp, Q Exp) -> Maybe (Q Exp, Q Exp)
forall a. a -> Maybe a
Just ([e|SkipWs|], [e|skipWs|])) Bool
True Bool
False

-- |A variant of 'exon' that creates segments for each sequence of whitespace characters that can be processed
-- differently by 'Exon.ExonAppend', 'Exon.ExonSegment' or 'Exon.ExonString'.
--
-- @since 1.0.0.0
exonws :: QuasiQuoter
exonws :: QuasiQuoter
exonws =
  Maybe (Q Exp, Q Exp) -> Bool -> Bool -> QuasiQuoter
exonWith Maybe (Q Exp, Q Exp)
forall a. Maybe a
Nothing Bool
True Bool
False

-- |Internal debugging quoter that produces the raw segments.
--
-- @since 1.0.0.0
exonSegments :: QuasiQuoter
exonSegments :: QuasiQuoter
exonSegments =
  (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter String -> Q Exp
forall (m :: * -> *). QOrIO m => String -> m Exp
quoteSegments (String -> String -> Q Pat
forall a. String -> String -> Q a
err String
"pattern") (String -> String -> Q Type
forall a. String -> String -> Q a
err String
"type") (String -> String -> Q [Dec]
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
_ =
      String -> Q a
forall e (m :: * -> *) a. (ToString e, MonadFail m) => e -> m a
exonError (String
"Cannot quote " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
tpe)