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 :: InterpolationConfig a -> QuasiQuoter
interpolateQQ InterpolationConfig a
interpolation =
  QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
    { quoteExp :: String -> Q Exp
quoteExp = InterpolationConfig a -> String -> Q Exp
forall a. InterpolationConfig a -> String -> Q Exp
interpolate InterpolationConfig a
interpolation,
      quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"not used",
      quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"not used",
      quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
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 :: 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 <- (ParseError -> Q ([a], Q Exp))
-> ([StringPart a] -> Q ([a], Q Exp))
-> Either ParseError [StringPart a]
-> Q ([a], Q Exp)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> ParseError -> Q ([a], Q Exp)
forall a. String -> ParseError -> Q a
parsingError String
str) (([a], Q Exp) -> Q ([a], Q Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([a], Q Exp) -> Q ([a], Q Exp))
-> ([StringPart a] -> ([a], Q Exp))
-> [StringPart a]
-> Q ([a], Q Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterpolationConfig a -> [StringPart a] -> ([a], Q Exp)
forall a. InterpolationConfig a -> [StringPart a] -> ([a], Q Exp)
concatParts InterpolationConfig a
defaultConfig) ([Interpolator a] -> String -> Either ParseError [StringPart a]
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 :: 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 = Q Exp -> Q Exp -> Q Exp
appE [|concat|] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
listE [Q Exp]
stringListE
    ([a]
otherData, [Q Exp]
stringListE) = (StringPart a -> ([a], [Q Exp]) -> ([a], [Q Exp]))
-> ([a], [Q Exp]) -> [StringPart a] -> ([a], [Q Exp])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr StringPart a -> ([a], [Q Exp]) -> ([a], [Q Exp])
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|] Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: [Q Exp]
qs)
      Esc Char
c -> let c' :: Char
c' = Char -> Char
escape Char
c in ([a]
ds, [|[c']|] Q Exp -> [Q Exp] -> [Q Exp]
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 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ds, Q Exp
q Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: [Q Exp]
qs)) ((a, Q Exp) -> ([a], [Q Exp])) -> (a, Q Exp) -> ([a], [Q Exp])
forall a b. (a -> b) -> a -> b
$ Q Exp -> (a, Q Exp)
handler Q Exp
expr

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