-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>
--
-- SPDX-License-Identifier: MPL-2.0

-- | Producing TH splices for interpolation.
module Text.Interpolation.Nyan.Core.Internal.Splice where

import Control.Monad (forM, unless, when)
import Data.Char (isSpace)
import Data.String (fromString)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import Fmt (Builder, fmt)
import Language.Haskell.TH

import Text.Interpolation.Nyan.Core.Internal.Base
import Text.Interpolation.Nyan.Core.Internal.RMode

-- | Expression result of which can yet be somehow extended.
type ExtendableRes = (ExpQ -> ExpQ) -> ExpQ

-- | Build interpolated string into TH splice.

-- Note: one of things we aim at is concise produced code, as the user may
-- sometimes need to read what is being generated.
intSplice
  :: InterpolatorOptions
  -> (SwitchesOptions, InterpolatedString)
  -> ExpQ
intSplice :: InterpolatorOptions
-> (SwitchesOptions, InterpolatedString) -> ExpQ
intSplice InterpolatorOptions
iopts (SwitchesOptions
sopts, InterpolatedString
istr) = do
  Q ()
invokePreview
  if Bool -> Bool
not (SwitchesOptions -> Bool
monadic SwitchesOptions
sopts)
  then
    [| $finalConvertFuncQ $ mconcat
        $(ListE <$> forM istr \case
            IpString txt ->
              mkStrLiteralQ txt
            IpInt IntData{..} -> do
              [|$(renderFuncQ idMode)
                $(runValueInterpolator (valueInterpolator iopts) idCode)
                |]
          )
      |]
  else
    [| $finalConvertFuncQ . mconcat <$> sequenceA
        $(ListE <$> forM istr \case
            IpString txt ->
              [|pure $(mkStrLiteralQ txt)|]
            IpInt IntData{..} -> do
              [|$(renderFuncQ idMode) <$>
                $(runValueInterpolator (valueInterpolator iopts) idCode)
                |]
          )
      |]
  where
    -- Contains: render rmode'xxx
    renderFuncQ :: Text -> ExpQ
    renderFuncQ :: Text -> ExpQ
renderFuncQ Text
mode =
      Exp -> ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> ExpQ) -> Exp -> ExpQ
forall a b. (a -> b) -> a -> b
$
      Name -> Exp
VarE 'renderWithMode
        Exp -> Exp -> Exp
`AppE`
        Name -> Exp
VarE (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"rmode'" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
mode)

    -- Contains: fmt @Builder @ret
    finalConvertFuncQ :: ExpQ
    finalConvertFuncQ :: ExpQ
finalConvertFuncQ = Exp -> ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> ExpQ) -> Exp -> ExpQ
forall a b. (a -> b) -> a -> b
$ case SwitchesOptions -> ReturnType
returnType SwitchesOptions
sopts of
      ReturnType
AnyFromBuilder  -> Exp
fmtE
      ReturnType
ConcreteText    -> Exp
fmtE Exp -> Type -> Exp
`AppTypeE` Name -> Type
ConT ''Text
      ReturnType
ConcreteLText   -> Exp
fmtE Exp -> Type -> Exp
`AppTypeE` Name -> Type
ConT ''LT.Text
      ReturnType
ConcreteBuilder -> Name -> Exp
VarE 'id Exp -> Type -> Exp
`AppTypeE` Name -> Type
ConT ''Builder
      where
        fmtE :: Exp
fmtE = Name -> Exp
VarE 'fmt

    mkStrLiteralQ :: Text -> ExpQ
    mkStrLiteralQ :: Text -> ExpQ
mkStrLiteralQ Text
str = do
      Bool
haveOverloadedStrings <- Extension -> Q Bool
isExtEnabled Extension
OverloadedStrings
      let fromStringF :: Maybe Exp
fromStringF
            | Bool
haveOverloadedStrings = Maybe Exp
forall a. Maybe a
Nothing
            | Bool
otherwise = Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Name -> Exp
VarE 'fromString)
      Exp -> ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> ExpQ) -> Exp -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp) -> (Exp -> Exp -> Exp) -> Maybe Exp -> Exp -> Exp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Exp -> Exp
forall a. a -> a
id Exp -> Exp -> Exp
AppE Maybe Exp
fromStringF (Lit -> Exp
LitE (Lit -> Exp) -> (String -> Lit) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL (String -> Exp) -> String -> Exp
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
str)

    invokePreview :: Q ()
    invokePreview :: Q ()
invokePreview = do
      let msg :: Maybe Text
msg = case SwitchesOptions -> PreviewLevel
previewLevel SwitchesOptions
sopts of
            PreviewLevel
PreviewNone      -> Maybe Text
forall a. Maybe a
Nothing
            PreviewLevel
PreviewExact     -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
              [ Text
"Interpolated text will look like:\n"
              , ((IntPiece -> Text) -> InterpolatedString -> Text)
-> InterpolatedString -> (IntPiece -> Text) -> Text
forall a b c. (a -> b -> c) -> b -> a -> c
flip (IntPiece -> Text) -> InterpolatedString -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap InterpolatedString
istr \case
                  IpString Text
txt -> Text
txt
                  IpInt IntData
_      -> Text
"..."
              , Text
"\n"
              ]
            PreviewLevel
PreviewInvisible -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
              [ Text
"Interpolated text will look like:\n"
              , let showInvisibles :: String -> String
showInvisibles = InvisibleCharsPreview -> String -> String
replaceInvisibleChars (InterpolatorOptions -> InvisibleCharsPreview
invisibleCharsPreview InterpolatorOptions
iopts)
                in ((IntPiece -> Text) -> InterpolatedString -> Text)
-> InterpolatedString -> (IntPiece -> Text) -> Text
forall a b c. (a -> b -> c) -> b -> a -> c
flip (IntPiece -> Text) -> InterpolatedString -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap InterpolatedString
istr \case
                  IpString Text
txt -> String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String
showInvisibles (Text -> String
T.unpack Text
txt)
                  IpInt IntData
_      -> Text
"..."
              , Text
"<end>\n"
              ]

      -- We report as an error, not as a warning, because
      -- in normal circumstances the user wants to disable
      -- the preview immediately after checking, he/she
      -- probably do not want to build half of the project and
      -- then build it again after disabling the preview.
      --
      -- So we want to build the entire module, but do not go further.
      (Text -> Q ()) -> Maybe Text -> Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> Q ()
reportError (String -> Q ()) -> (Text -> String) -> Text -> Q ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) Maybe Text
msg

{- | Interpolates only strings containing single variable.

This allows for @{var}@-like interpolated values, no applications,
operators or other constructions are allowed.

-}
simpleValueInterpolator :: ValueInterpolator
simpleValueInterpolator :: ValueInterpolator
simpleValueInterpolator = (Text -> ExpQ) -> ValueInterpolator
ValueInterpolator \Text
txt -> do
  let varNameTxt :: Text
varNameTxt = Text -> Text
T.strip Text
txt
  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isAllowedChar Text
varNameTxt) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
    String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Only passing sole variables is allowed by this interpolator"
  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Bool
T.null Text
varNameTxt) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
    String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Empty placeholder"
  String -> Q (Maybe Name)
lookupValueName (Text -> String
T.unpack Text
varNameTxt) Q (Maybe Name) -> (Maybe Name -> ExpQ) -> ExpQ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Name
Nothing      -> String -> ExpQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$ String
"Variable '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
varNameTxt String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' is not in scope"
    Just Name
varName -> Exp -> ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Exp
VarE Name
varName)
  where
    isAllowedChar :: Char -> Bool
isAllowedChar Char
c =
      -- handling the most common things to remind the user that only variables
      -- are allowed;
      -- want to rather be too permissive than too restrictive
      Bool -> Bool
not (Char -> Bool
isSpace Char
c) Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'$' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.'

{- | This is a variation of 'simpleValueInterpolator' that requires all the
referred variables to start from a special @i'@ prefix.

One major issue with 'simpleValueInterpolator' is that, with it the user can
mistakenly pick a value from the wrong scope, for instance, a global value
instead of a local one.
This value interpolator tries to solve the issue by bringing the practice
to call the interpolator like

@
let renderedText =
      let i'value1 = ...
          i'value2 = ...
      in [int||Values are {value1} and {value2}]
@

and so interpolating only local declarations.

-}
tickedValueInterpolator :: ValueInterpolator
tickedValueInterpolator :: ValueInterpolator
tickedValueInterpolator = (Text -> ExpQ) -> ValueInterpolator
ValueInterpolator
  \Text
txt -> ValueInterpolator -> Text -> ExpQ
runValueInterpolator ValueInterpolator
simpleValueInterpolator (Text
"i'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txt)

-- | Marks the most common space-like characters.
simpleInvisibleCharsPreview :: InvisibleCharsPreview
simpleInvisibleCharsPreview :: InvisibleCharsPreview
simpleInvisibleCharsPreview = (String -> String) -> InvisibleCharsPreview
InvisibleCharsPreview String -> String
go
  where
    go :: String -> String
go = \case
      Char
' ' : String
s ->
        Char
'·' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
s
      Char
'\r' : Char
'\n' : String
s ->
        Char
'⤶' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'\r' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'\n' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
s
      Char
'\r' : String
s      ->
        Char
'⤶' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'\r' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
s
      Char
'\n' : String
s        ->
        Char
'⤶' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'\n' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
s

      -- It's a good question how to render tab.
      -- It may look like 2 spaces, or 8 spaces, depending on
      -- the machine where it is rendered.
      -- So my stance is that using Tab for text alignment should be avoided,
      -- and we better choose some symbol that /does not/ reflect the space
      -- potentially occupied by a tab.
      -- A use case that we aim at is e.g. using Tab in CSV; there we would
      -- just want to know that Tab is present, we don't care how Tab
      -- character affects the text appearance.
      Char
'\t' : String
s        -> Char
'→' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
s

      Char
c : String
s           -> Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
s
      []              -> []