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
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
renderFuncQ :: Text -> ExpQ
renderFuncQ :: Text -> ExpQ
renderFuncQ Text
mode =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
Name -> Exp
VarE 'renderWithMode
Exp -> Exp -> Exp
`AppE`
Name -> Exp
VarE (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"rmode'" forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
mode)
finalConvertFuncQ :: ExpQ
finalConvertFuncQ :: ExpQ
finalConvertFuncQ = forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just (Name -> Exp
VarE 'fromString)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id Exp -> Exp -> Exp
AppE Maybe Exp
fromStringF (Lit -> Exp
LitE forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL 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 -> forall a. Maybe a
Nothing
PreviewLevel
PreviewExact -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
[ Text
"Interpolated text will look like:\n"
, forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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 forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap InterpolatedString
istr \case
IpString Text
txt -> String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ String -> String
showInvisibles (Text -> String
T.unpack Text
txt)
IpInt IntData
_ -> Text
"..."
, Text
"<end>\n"
]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> Q ()
reportError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) Maybe Text
msg
simpleValueInterpolator :: ValueInterpolator
simpleValueInterpolator :: ValueInterpolator
simpleValueInterpolator = (Text -> ExpQ) -> ValueInterpolator
ValueInterpolator \Text
txt -> do
let varNameTxt :: Text
varNameTxt = Text -> Text
T.strip Text
txt
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isAllowedChar Text
varNameTxt) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Only passing sole variables is allowed by this interpolator"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Bool
T.null Text
varNameTxt) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Empty placeholder"
String -> Q (Maybe Name)
lookupValueName (Text -> String
T.unpack Text
varNameTxt) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Name
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Variable '" forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
varNameTxt forall a. Semigroup a => a -> a -> a
<> String
"' is not in scope"
Just Name
varName -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Exp
VarE Name
varName)
where
isAllowedChar :: Char -> Bool
isAllowedChar Char
c =
Bool -> Bool
not (Char -> Bool
isSpace Char
c) Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
'$' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
'.'
tickedValueInterpolator :: ValueInterpolator
tickedValueInterpolator :: ValueInterpolator
tickedValueInterpolator = (Text -> ExpQ) -> ValueInterpolator
ValueInterpolator
\Text
txt -> ValueInterpolator -> Text -> ExpQ
runValueInterpolator ValueInterpolator
simpleValueInterpolator (Text
"i'" forall a. Semigroup a => a -> a -> a
<> Text
txt)
simpleInvisibleCharsPreview :: InvisibleCharsPreview
simpleInvisibleCharsPreview :: InvisibleCharsPreview
simpleInvisibleCharsPreview = (String -> String) -> InvisibleCharsPreview
InvisibleCharsPreview String -> String
go
where
go :: String -> String
go = \case
Char
' ' : String
s ->
Char
'·' forall a. a -> [a] -> [a]
: String -> String
go String
s
Char
'\n' : String
s ->
Char
'⤶' forall a. a -> [a] -> [a]
: Char
'\n' forall a. a -> [a] -> [a]
: String -> String
go String
s
Char
'\t' : String
s -> Char
'→' forall a. a -> [a] -> [a]
: String -> String
go String
s
Char
c : String
s -> Char
c forall a. a -> [a] -> [a]
: String -> String
go String
s
[] -> []