module CustomInterpolation.TH where

import CustomInterpolation.Config (InterpolationConfig (..), Interpolator (..))
import CustomInterpolation.Parser (StringPart (..), parseInterpolations)
import Language.Haskell.TH (Exp, Q, appE, listE)
import Language.Haskell.TH.Quote (QuasiQuoter (..))
import Text.Parsec (ParseError)

-- | Create a new 'QuasiQuoter' that interpolates strings as specified by the given 'InterpolationConfig'.
interpolateQQ :: InterpolationConfig a -> QuasiQuoter
interpolateQQ :: forall a. InterpolationConfig a -> QuasiQuoter
interpolateQQ InterpolationConfig a
interpolation =
  QuasiQuoter
    { quoteExp :: String -> Q Exp
quoteExp = forall a. InterpolationConfig a -> String -> Q Exp
interpolate InterpolationConfig a
interpolation,
      quotePat :: String -> Q Pat
quotePat = forall a. HasCallStack => String -> a
error String
"not used",
      quoteType :: String -> Q Type
quoteType = forall a. HasCallStack => String -> a
error String
"not used",
      quoteDec :: String -> Q [Dec]
quoteDec = forall a. HasCallStack => String -> a
error String
"not used"
    }

-- | Interpolate a string as specified by the given 'InterpolationConfig'.
interpolate :: InterpolationConfig a -> String -> Q Exp
interpolate :: forall a. InterpolationConfig a -> String -> Q Exp
interpolate defaultConfig :: InterpolationConfig a
defaultConfig@InterpolationConfig {[Interpolator a]
handlers :: forall a. InterpolationConfig a -> [Interpolator a]
handlers :: [Interpolator a]
handlers, ([a], Q Exp) -> Q Exp
finalize :: forall a. InterpolationConfig a -> ([a], Q Exp) -> Q Exp
finalize :: ([a], Q Exp) -> Q Exp
finalize} String
str = do
  ([a], Q Exp)
res <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. String -> ParseError -> Q a
parsingError String
str) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. InterpolationConfig a -> [StringPart a] -> ([a], Q Exp)
concatParts InterpolationConfig a
defaultConfig) (forall a.
[Interpolator a] -> String -> Either ParseError [StringPart a]
parseInterpolations [Interpolator a]
handlers String
str)
  ([a], Q Exp) -> Q Exp
finalize ([a], Q Exp)
res

{- | Concatenate the literals and interpolated parts of a list of 'StringPart's.
The interpolations may also each return some value which gets accumulated as a list in the first output.
-}
concatParts :: InterpolationConfig a -> [StringPart a] -> ([a], Q Exp)
concatParts :: forall a. InterpolationConfig a -> [StringPart a] -> ([a], Q Exp)
concatParts InterpolationConfig {Char -> Char
escape :: forall a. InterpolationConfig a -> Char -> Char
escape :: Char -> Char
escape} [StringPart a]
ps = ([a]
otherData, Q Exp
concatenatedE)
  where
    concatenatedE :: Q Exp
concatenatedE = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|concat|] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [Q Exp]
stringListE
    ([a]
otherData, [Q Exp]
stringListE) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a}. StringPart a -> ([a], [Q Exp]) -> ([a], [Q Exp])
step ([], []) [StringPart a]
ps
    step :: StringPart a -> ([a], [Q Exp]) -> ([a], [Q Exp])
step StringPart a
subExpr ([a]
ds, [Q Exp]
qs) = case StringPart a
subExpr of
      Lit String
str -> ([a]
ds, [|str|] forall a. a -> [a] -> [a]
: [Q Exp]
qs)
      Esc Char
c -> let c' :: Char
c' = Char -> Char
escape Char
c in ([a]
ds, [|[c']|] forall a. a -> [a] -> [a]
: [Q Exp]
qs)
      Anti Interpolator {Q Exp -> (a, Q Exp)
handler :: forall a. Interpolator a -> Q Exp -> (a, Q Exp)
handler :: Q Exp -> (a, Q Exp)
handler} Q Exp
expr -> (\(a
d, Q Exp
q) -> (a
d forall a. a -> [a] -> [a]
: [a]
ds, Q Exp
q forall a. a -> [a] -> [a]
: [Q Exp]
qs)) forall a b. (a -> b) -> a -> b
$ Q Exp -> (a, Q Exp)
handler Q Exp
expr

parsingError :: String -> ParseError -> Q a
parsingError :: forall a. String -> ParseError -> Q a
parsingError String
expStr ParseError
parseError =
  forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
    String
"Failed to parse interpolated expression in string: "
      forall a. Semigroup a => a -> a -> a
<> String
expStr
      forall a. Semigroup a => a -> a -> a
<> String
"\n"
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ParseError
parseError