-- |Description: Internal
module Exon.Quote where

import Data.Traversable (for)
import Language.Haskell.Exts (
  Extension,
  ParseMode (extensions),
  ParseResult (ParseFailed, ParseOk),
  defaultParseMode,
  parseExpWithMode,
  parseExtension,
  )
import Language.Haskell.Meta (toExp)
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, 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 :: 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 =>
  String ->
  m (NonEmpty RawSegment)
segmentsQ :: String -> m (NonEmpty RawSegment)
segmentsQ =
  String -> Either Text [RawSegment]
parse (String -> Either Text [RawSegment])
-> (Either Text [RawSegment] -> m (NonEmpty RawSegment))
-> String
-> m (NonEmpty RawSegment)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ([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 [RawSegment]
 -> Either Text (Maybe (NonEmpty RawSegment)))
-> (Either Text (Maybe (NonEmpty RawSegment))
    -> m (NonEmpty RawSegment))
-> Either Text [RawSegment]
-> m (NonEmpty RawSegment)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \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 [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 =
    ([Extension] -> [Extension]) -> Q [Extension] -> Q [Extension]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Extension -> Extension) -> [Extension] -> [Extension]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Extension
parseExtension (String -> Extension)
-> (Extension -> String) -> Extension -> Extension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Extension -> String
forall b a. (Show a, IsString b) => a -> b
show)) Q [Extension]
extsEnabled

reifyExp ::
  QOrIO m =>
  String ->
  m Exp
reifyExp :: String -> m Exp
reifyExp String
s = do
  [Extension]
exts <- m [Extension]
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 -> String -> m Exp
forall e (m :: * -> *) a. (ToString e, MonadFail m) => e -> m a
exonError String
err
    ParseOk Exp SrcSpanInfo
e -> Exp -> m Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp SrcSpanInfo -> Exp
forall a. ToExp a => a -> Exp
toExp Exp SrcSpanInfo
e)

reifySegments ::
  QOrIO m =>
  NonEmpty RawSegment ->
  m (NonEmpty Exp)
reifySegments :: NonEmpty RawSegment -> m (NonEmpty Exp)
reifySegments NonEmpty RawSegment
segs = do
  Exp
expCon <- Q Exp -> m Exp
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e|Segment.Expression|]
  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 -> 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)
    WsSegment String
s ->
     Q Exp -> m Exp
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e|Segment.Whitespace s|]

quoteExp ::
  QOrIO m =>
  String ->
  m Exp
quoteExp :: String -> m Exp
quoteExp String
code = do
  NonEmpty RawSegment
raw <- String -> m (NonEmpty RawSegment)
forall (m :: * -> *). QOrIO m => String -> m (NonEmpty RawSegment)
segmentsQ String
code
  Exp
hseg :| [Exp]
segs <- NonEmpty RawSegment -> m (NonEmpty Exp)
forall (m :: * -> *).
QOrIO m =>
NonEmpty RawSegment -> m (NonEmpty Exp)
reifySegments NonEmpty RawSegment
raw
  Exp
conc <- Q Exp -> m Exp
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e|concatSegments @ExonDefault|]
  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))))

-- |A quasiquoter that allows interpolation, concatenating the resulting segments monoidally.
--
-- >>> [exon|write #{show @Text (5 :: Int)} lines of code|] :: Text
-- "write 5 lines of code"
--
-- The default implementation for any non-stringly type uses 'IsString' to construct the literal segments and 'mappend'
-- to combine them, ignoring whitespace segments.
--
-- >>> newtype Part = Part Text deriving newtype (Show, Semigroup, Monoid, IsString)
--
-- >>> [exon|x #{Part "y"}z|] :: Part
-- Part "xyz"
--
-- This behavior can be customized by writing an instance of 'Exon.Exon'.
exon :: QuasiQuoter
exon :: QuasiQuoter
exon =
  (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter String -> Q Exp
forall (m :: * -> *). QOrIO m => String -> m Exp
quoteExp (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 :: 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)