-- |
-- NeatInterpolation provides a quasiquoter for producing strings
-- with a simple interpolation of input values.
-- It removes the excessive indentation from the input and
-- accurately manages the indentation of all lines of interpolated variables.
-- But enough words, the code shows it better.
--
-- Consider the following declaration:
--
-- > {-# LANGUAGE QuasiQuotes #-}
-- >
-- > import NeatInterpolation
-- > import Data.Text (Text)
-- >
-- > f :: Text -> Text -> Text
-- > f a b =
-- >   [text|
-- >     function(){
-- >       function(){
-- >         $a
-- >       }
-- >       return $b
-- >     }
-- >   |]
--
-- Executing the following:
--
-- > main = T.putStrLn $ f "1" "2"
--
-- will produce this (notice the reduced indentation compared to how it was
-- declared):
--
-- > function(){
-- >   function(){
-- >     1
-- >   }
-- >   return 2
-- > }
--
-- Now let's test it with multiline string parameters:
--
-- > main = T.putStrLn $ f
-- >   "{\n  indented line\n  indented line\n}"
-- >   "{\n  indented line\n  indented line\n}"
--
-- We get
--
-- > function(){
-- >   function(){
-- >     {
-- >       indented line
-- >       indented line
-- >     }
-- >   }
-- >   return {
-- >     indented line
-- >     indented line
-- >   }
-- > }
--
-- See how it neatly preserved the indentation levels of lines the
-- variable placeholders were at?
--
-- If you need to separate variable placeholder from the following text to
-- prevent treating the rest of line as variable name, use escaped variable:
--
-- > f name = [text|this_could_be_${name}_long_identifier|]
--
-- So
--
-- > f "one" == "this_could_be_one_long_identifier"
--
-- If you want to write something that looks like a variable but should be
-- inserted as-is, escape it with another @$@:
--
-- > f word = [text|$$my ${word} $${string}|]
--
-- results in
--
-- > f "funny" == "$my funny ${string}|]
module NeatInterpolation (text) where

import NeatInterpolation.Prelude

import Language.Haskell.TH
import Language.Haskell.TH.Quote hiding (quoteExp)

import NeatInterpolation.String
import NeatInterpolation.Parsing

import Data.Text (Text)
import qualified Data.Text as T


-- |
-- The quasiquoter.
text :: QuasiQuoter
text :: QuasiQuoter
text = (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter String -> Q Exp
quoteExp String -> Q Pat
forall (m :: * -> *) p a. MonadFail m => p -> m a
notSupported String -> Q Type
forall (m :: * -> *) p a. MonadFail m => p -> m a
notSupported String -> Q [Dec]
forall (m :: * -> *) p a. MonadFail m => p -> m a
notSupported where
  notSupported :: p -> m a
notSupported _ = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Quotation in this context is not supported"

indentQQPlaceholder :: Int -> Text -> Text
indentQQPlaceholder :: Int -> Text -> Text
indentQQPlaceholder indent :: Int
indent text :: Text
text = case Text -> [Text]
T.lines Text
text of
  head :: Text
head:tail :: [Text]
tail -> Text -> [Text] -> Text
T.intercalate (Char -> Text
T.singleton '\n') ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
               Text
head Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Text -> Text
T.replicate Int
indent (Char -> Text
T.singleton ' ') Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) [Text]
tail
  [] -> Text
text

quoteExp :: String -> Q Exp
quoteExp :: String -> Q Exp
quoteExp input :: String
input =
  case String -> Either ParseException [Line]
parseLines (String -> Either ParseException [Line])
-> String -> Either ParseException [Line]
forall a b. (a -> b) -> a -> b
$ String -> String
normalizeQQInput String
input of
    Left e :: ParseException
e -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ ParseException -> String
forall a. Show a => a -> String
show ParseException
e
    Right lines :: [Line]
lines -> Q Exp -> Q Type -> Q Exp
sigE (Q Exp -> Q Exp -> Q Exp
appE [|T.unlines|] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Line -> Q Exp) -> [Line] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Line -> Q Exp
lineExp [Line]
lines)
                        [t|Text|]

lineExp :: Line -> Q Exp
lineExp :: Line -> Q Exp
lineExp (Line indent :: Int
indent contents :: [LineContent]
contents) =
  case [LineContent]
contents of
    []  -> [| T.empty |]
    [x :: Item [LineContent]
x] -> LineContent -> Q Exp
toExp Item [LineContent]
LineContent
x
    xs :: [LineContent]
xs  -> Q Exp -> Q Exp -> Q Exp
appE [|T.concat|] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (LineContent -> Q Exp) -> [LineContent] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map LineContent -> Q Exp
toExp [LineContent]
xs
  where toExp :: LineContent -> Q Exp
toExp = Integer -> LineContent -> Q Exp
contentExp (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
indent)

contentExp :: Integer -> LineContent -> Q Exp
contentExp :: Integer -> LineContent -> Q Exp
contentExp _ (LineContentText text :: String
text) = Q Exp -> Q Exp -> Q Exp
appE [|T.pack|] (String -> Q Exp
stringE String
text)
contentExp indent :: Integer
indent (LineContentIdentifier name :: String
name) = do
  Maybe Name
valueName <- String -> Q (Maybe Name)
lookupValueName String
name
  case Maybe Name
valueName of
    Just valueName :: Name
valueName -> do
      Q Exp -> Q Exp -> Q Exp
appE
        (Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE 'indentQQPlaceholder) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Lit -> Q Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
integerL Integer
indent)
        (Name -> Q Exp
varE Name
valueName)
    Nothing -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ "Value `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ "` is not in scope"