{-# LANGUAGE NamedFieldPuns, RecordWildCards, TemplateHaskell, FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-}

-- | Interpolated here docs
module Data.String.Here.Interpolated (i, iTrim, template) where

import Control.Applicative hiding ((<|>))
import Control.Monad
import Control.Monad.State

import Data.Char
import Data.Maybe
import Data.Monoid
import Data.String
import Data.Typeable

import Language.Haskell.Meta
import Language.Haskell.TH
import Language.Haskell.TH.Quote

import Text.Parsec
import Text.Parsec.Prim
import Text.Parsec.String

import Data.String.Here.Internal

data StringPart = Lit String | Esc Char | Anti (Q Exp)

data HsChompState = HsChompState { HsChompState -> QuoteState
quoteState :: QuoteState
                                 , HsChompState -> Int
braceCt :: Int
                                 , HsChompState -> String
consumed :: String
                                 , HsChompState -> Bool
prevCharWasIdentChar :: Bool
                                 }

data QuoteState = None | Single EscapeState | Double EscapeState

data EscapeState = Escaped | Unescaped

-- | Quote a here doc with embedded antiquoted expressions
--
-- Any expression occurring between @${@ and @}@ (for which the type must have
-- 'Show' and 'Typeable' instances) will be interpolated into the quoted
-- string.
--
-- Characters preceded by a backslash are treated literally. This enables the
-- inclusion of the literal substring @${@ within your quoted text by writing
-- it as @\\${@. The literal sequence @\\${@ may be written as @\\\\${@.
i :: QuasiQuoter
i :: QuasiQuoter
i = QuasiQuoter {quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
quoteInterp}

-- | Like 'i', but with leading and trailing whitespace trimmed
iTrim :: QuasiQuoter
iTrim :: QuasiQuoter
iTrim = QuasiQuoter {quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
quoteInterp forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
trim}

-- | Quote the contents of a file as with 'i'
--
-- This enables usage as a simple template engine
template :: QuasiQuoter
template :: QuasiQuoter
template = QuasiQuoter -> QuasiQuoter
quoteDependentFile QuasiQuoter
i

quoteInterp :: String -> Q Exp
quoteInterp :: String -> Q Exp
quoteInterp String
s = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> ParseError -> Q Exp
handleError String
s) [StringPart] -> Q Exp
combineParts (String -> Either ParseError [StringPart]
parseInterp String
s)

handleError :: String -> ParseError -> Q Exp
handleError :: String -> ParseError -> Q Exp
handleError 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. [a] -> [a] -> [a]
++ String
expStr
    forall a. [a] -> [a] -> [a]
++ String
"\n"
    forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ParseError
parseError

combineParts :: [StringPart] -> Q Exp
combineParts :: [StringPart] -> Q Exp
combineParts = forall {m :: * -> *}. Quote m => [m Exp] -> m Exp
combine forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map StringPart -> Q Exp
toExpQ
  where
    toExpQ :: StringPart -> Q Exp
toExpQ (Lit String
s) = forall (m :: * -> *). Quote m => String -> m Exp
stringE String
s
    toExpQ (Esc Char
c) = forall (m :: * -> *). Quote m => String -> m Exp
stringE [Char
c]
    toExpQ (Anti Q Exp
expq) = [|toString $expq|]
    combine :: [m Exp] -> m Exp
combine [] = forall (m :: * -> *). Quote m => String -> m Exp
stringE String
""
    combine [m Exp]
parts = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\m Exp
subExpr m Exp
acc -> [|$subExpr <> $acc|]) [m Exp]
parts

toString :: (Show a, Typeable a, Typeable b, IsString b) => a -> b
toString :: forall a b. (Show a, Typeable a, Typeable b, IsString b) => a -> b
toString a
x = forall a. a -> Maybe a -> a
fromMaybe (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show a
x) (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
x)

parseInterp :: String -> Either ParseError [StringPart]
parseInterp :: String -> Either ParseError [StringPart]
parseInterp = forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parser [StringPart]
p_interp String
""

p_interp :: Parser [StringPart]
p_interp :: Parser [StringPart]
p_interp = forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill Parser StringPart
p_stringPart forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof

p_stringPart :: Parser StringPart
p_stringPart :: Parser StringPart
p_stringPart = Parser StringPart
p_anti forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser StringPart
p_esc forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser StringPart
p_lit

p_anti :: Parser StringPart
p_anti :: Parser StringPart
p_anti = Q Exp -> StringPart
Anti forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parser String
p_antiOpen) Parser String
p_antiClose Parser (Q Exp)
p_antiExpr

p_antiOpen :: Parser String
p_antiOpen :: Parser String
p_antiOpen = forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"${"

p_antiClose :: Parser String
p_antiClose :: Parser String
p_antiClose = forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"}"

p_antiExpr :: Parser (Q Exp)
p_antiExpr :: Parser (Q Exp)
p_antiExpr = Parser String
p_untilUnbalancedCloseBrace
         forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadFail m => String -> m a
fail (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String Exp
parseExp

p_untilUnbalancedCloseBrace :: Parser String
p_untilUnbalancedCloseBrace :: Parser String
p_untilUnbalancedCloseBrace = forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT HsChompState (ParsecT String () Identity) String
go forall a b. (a -> b) -> a -> b
$ QuoteState -> Int -> String -> Bool -> HsChompState
HsChompState QuoteState
None Int
0 String
"" Bool
False
  where
    go :: StateT HsChompState (ParsecT String () Identity) String
go = do
      Char
c <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar
      forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \st :: HsChompState
st@HsChompState {String
consumed :: String
consumed :: HsChompState -> String
consumed} -> HsChompState
st {consumed :: String
consumed = Char
cforall a. a -> [a] -> [a]
:String
consumed}
      HsChompState {Bool
Int
String
QuoteState
prevCharWasIdentChar :: Bool
consumed :: String
braceCt :: Int
quoteState :: QuoteState
prevCharWasIdentChar :: HsChompState -> Bool
consumed :: HsChompState -> String
braceCt :: HsChompState -> Int
quoteState :: HsChompState -> QuoteState
..} <- forall s (m :: * -> *). MonadState s m => m s
get
      let next :: StateT HsChompState (ParsecT String () Identity) String
next = forall {m :: * -> *}. MonadState HsChompState m => Char -> m ()
setIdentifierCharState Char
c forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT HsChompState (ParsecT String () Identity) String
go
      case QuoteState
quoteState of
        QuoteState
None -> case Char
c of
          Char
'{' -> forall {m :: * -> *}. MonadState HsChompState m => Int -> m ()
incBraceCt Int
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT HsChompState (ParsecT String () Identity) String
next
          Char
'}' | Int
braceCt forall a. Ord a => a -> a -> Bool
> Int
0 -> forall {m :: * -> *}. MonadState HsChompState m => Int -> m ()
incBraceCt (-Int
1) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT HsChompState (ParsecT String () Identity) String
next
              | Bool
otherwise -> forall {u}. StateT HsChompState (ParsecT String u Identity) ()
stepBack forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail String
consumed)
          Char
'\'' -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
prevCharWasIdentChar (forall {m :: * -> *}.
MonadState HsChompState m =>
QuoteState -> m ()
setQuoteState forall a b. (a -> b) -> a -> b
$ EscapeState -> QuoteState
Single EscapeState
Unescaped)
               forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT HsChompState (ParsecT String () Identity) String
next
          Char
'"' -> forall {m :: * -> *}.
MonadState HsChompState m =>
QuoteState -> m ()
setQuoteState (EscapeState -> QuoteState
Double EscapeState
Unescaped) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT HsChompState (ParsecT String () Identity) String
next
          Char
_ -> StateT HsChompState (ParsecT String () Identity) String
next
        Single EscapeState
Unescaped -> do case Char
c of Char
'\\' -> forall {m :: * -> *}.
MonadState HsChompState m =>
QuoteState -> m ()
setQuoteState (EscapeState -> QuoteState
Single EscapeState
Escaped)
                                         Char
'\'' -> forall {m :: * -> *}.
MonadState HsChompState m =>
QuoteState -> m ()
setQuoteState QuoteState
None
                                         Char
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                               StateT HsChompState (ParsecT String () Identity) String
next
        Single EscapeState
Escaped -> forall {m :: * -> *}.
MonadState HsChompState m =>
QuoteState -> m ()
setQuoteState (EscapeState -> QuoteState
Single EscapeState
Unescaped) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT HsChompState (ParsecT String () Identity) String
next
        Double EscapeState
Unescaped -> do case Char
c of Char
'\\' -> forall {m :: * -> *}.
MonadState HsChompState m =>
QuoteState -> m ()
setQuoteState (EscapeState -> QuoteState
Double EscapeState
Escaped)
                                         Char
'"' -> forall {m :: * -> *}.
MonadState HsChompState m =>
QuoteState -> m ()
setQuoteState QuoteState
None
                                         Char
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                               StateT HsChompState (ParsecT String () Identity) String
next
        Double EscapeState
Escaped -> forall {m :: * -> *}.
MonadState HsChompState m =>
QuoteState -> m ()
setQuoteState (EscapeState -> QuoteState
Double EscapeState
Unescaped) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT HsChompState (ParsecT String () Identity) String
next
    stepBack :: StateT HsChompState (ParsecT String u Identity) ()
stepBack = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
      forall s u (m :: * -> *).
(State s u -> State s u) -> ParsecT s u m (State s u)
updateParserState
        (\State String u
s -> State String u
s {statePos :: SourcePos
statePos = SourcePos -> Int -> SourcePos
incSourceColumn (forall s u. State s u -> SourcePos
statePos State String u
s) (-Int
1)})
        forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput
        forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) s u. Monad m => s -> ParsecT s u m ()
setInput forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'}'forall a. a -> [a] -> [a]
:)
    incBraceCt :: Int -> m ()
incBraceCt Int
n = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \st :: HsChompState
st@HsChompState {Int
braceCt :: Int
braceCt :: HsChompState -> Int
braceCt} ->
      HsChompState
st {braceCt :: Int
braceCt = Int
braceCt forall a. Num a => a -> a -> a
+ Int
n}
    setQuoteState :: QuoteState -> m ()
setQuoteState QuoteState
qs = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \HsChompState
st -> HsChompState
st {quoteState :: QuoteState
quoteState = QuoteState
qs}
    setIdentifierCharState :: Char -> m ()
setIdentifierCharState Char
c = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \HsChompState
st ->
      HsChompState
st
        {prevCharWasIdentChar :: Bool
prevCharWasIdentChar = forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Char -> Bool
isLetter Char
c, Char -> Bool
isDigit Char
c, Char
c forall a. Eq a => a -> a -> Bool
== Char
'_', Char
c forall a. Eq a => a -> a -> Bool
== Char
'\'']}

p_esc :: Parser StringPart
p_esc :: Parser StringPart
p_esc = Char -> StringPart
Esc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\\' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar)

p_lit :: Parser StringPart
p_lit :: Parser StringPart
p_lit = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> StringPart
Lit forall a b. (a -> b) -> a -> b
$
  forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (forall {u} {end}.
ParsecT String u Identity end -> ParsecT String u Identity String
litCharTil forall a b. (a -> b) -> a -> b
$ forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead Parser String
p_antiOpen forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"\\"))
    forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall {u} {end}.
ParsecT String u Identity end -> ParsecT String u Identity String
litCharTil forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
  where litCharTil :: ParsecT String u Identity end -> ParsecT String u Identity String
litCharTil = forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf [Char
'\\']