module NeatInterpolation (string, indentQQPlaceholder) where
import NeatInterpolation.Prelude
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import NeatInterpolation.String
import NeatInterpolation.Parsing
string :: QuasiQuoter
string = QuasiQuoter {quoteExp = quoteExprExp}
indentQQPlaceholder :: Int -> String -> String
indentQQPlaceholder indent text = case lines text of
head:tail -> intercalate "\n" $ head : map (replicate indent ' ' ++) tail
[] -> text
quoteExprExp :: String -> Q Exp
quoteExprExp input =
case parseLines $ normalizeQQInput input of
Left e -> fail $ show e
Right lines -> appE [|unlines|] $ linesExp lines
linesExp :: [Line] -> Q Exp
linesExp [] = [|([] :: [String])|]
linesExp (head : tail) =
(binaryOpE [|(:)|])
(lineExp head)
(linesExp tail)
lineExp :: Line -> Q Exp
lineExp (Line indent contents) =
msumExps $ map (contentExp $ fromIntegral indent) contents
contentExp :: Integer -> LineContent -> Q Exp
contentExp _ (LineContentText text) = stringE text
contentExp indent (LineContentIdentifier name) = do
valueName <- lookupValueName name
case valueName of
Just valueName -> do
Just indentQQPlaceholderName <- lookupValueName "indentQQPlaceholder"
appE
(appE (varE indentQQPlaceholderName) $ litE $ integerL indent)
(varE valueName)
Nothing -> fail $ "Value `" ++ name ++ "` is not in scope"
msumExps :: [Q Exp] -> Q Exp
msumExps = foldr (binaryOpE mappendE) memptyE
memptyE = [|mempty|]
mappendE = [|mappend|]
binaryOpE e = \a b -> e `appE` a `appE` b