{-#LANGUAGE TupleSections #-}
{-#LANGUAGE OverloadedStrings #-}
{-#LANGUAGE ScopedTypeVariables #-}
{-#LANGUAGE DeriveGeneric #-}
{-#LANGUAGE FlexibleInstances #-}
{-#LANGUAGE MultiParamTypeClasses #-}
-- | Ginger parser.
module Text.Ginger.Parse
( parseGinger
, parseGingerFile
, parseGinger'
, parseGingerFile'
, ParserError (..)
, ParserOptions (..)
, mkParserOptions
, Delimiters (..)
, defDelimiters
, formatParserError
, IncludeResolver
, Source, SourceName
, SourcePos (..)
, sourceName
, sourceLine
, sourceColumn
, setSourceName
)
where

import Text.Parsec ( ParseError (..)
                   , SourcePos (..)
                   , SourceName (..)
                   , sourceName
                   , sourceLine
                   , sourceColumn
                   , setSourceName
                   , ParsecT
                   , runParserT
                   , try, lookAhead
                   , manyTill, oneOf, string, notFollowedBy, between, sepBy
                   , eof, space, spaces, anyChar, noneOf, char
                   , choice, option, optionMaybe
                   , unexpected
                   , digit
                   , getState, modifyState, putState
                   , (<?>)
                   , getPosition
                   )
import Text.Parsec.Error ( errorMessages
                         , errorPos
                         , showErrorMessages
                         )
import Text.Ginger.AST
import Text.Ginger.Html ( unsafeRawHtml )
import Text.Ginger.GVal (GVal, ToGVal (..), dict, (~>))

import Control.Monad (when)
import Control.Monad.Reader ( ReaderT
                            , runReaderT
                            , ask, asks
                            )
import Control.Monad.Trans.Class ( lift )
import Control.Applicative
import Control.Exception (Exception)
import GHC.Generics
import Safe ( readMay )

import Data.Text (Text)
import Data.Maybe ( fromMaybe, catMaybes, listToMaybe )
import Data.Scientific ( Scientific )
import qualified Data.Text as Text
import Data.List ( foldr, nub, sort )
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Default ( Default (..) )
import Data.Monoid ( (<>) )
import Data.Char (isSpace)

import System.FilePath ( takeDirectory, (</>) )
import Text.Printf ( printf )

-- | Input type for the parser (source code).
type Source = String

-- | Used to resolve includes. Ginger will call this function whenever it
-- encounters an {% include %}, {% import %}, or {% extends %} directive.
-- If the required source code is not available, the resolver should return
-- @Nothing@, else @Just@ the source.
type IncludeResolver m = SourceName -> m (Maybe Source)

instance ToGVal m SourcePos where
    toGVal p =
        dict [ "name" ~> sourceName p
             , "line" ~> sourceLine p
             , "column" ~> sourceColumn p
             ]

-- | Error information for Ginger parser errors.
data ParserError =
    ParserError
        { peErrorMessage :: String -- ^ Human-readable error message
        , peSourcePosition :: Maybe SourcePos
        }
        deriving (Show, Generic)

instance Exception ParserError where

-- | Formats a parser errror into something human-friendly.
-- If template source code is not provided, only the line and column numbers
-- and the error message are printed. If template source code is provided,
-- the offending source line is also printed, with a caret (@^@) marking the
-- exact location of the error.
formatParserError :: Maybe String -- ^ Template source code (not filename)
                  -> ParserError -- ^ Error to format
                  -> String
formatParserError tplSrc e =
    let sourceLocation = do
            pos <- peSourcePosition e
            return $ printf "%s:%i:%i\n"
                (sourceName pos)
                (sourceLine pos)
                (sourceColumn pos)
        markerLines = do
            sourceLines <- lines <$> tplSrc
            pos <- peSourcePosition e
            let lineNum = sourceLine pos
            offendingLine <- listToMaybe . drop (pred lineNum) $ sourceLines
            let offendingColumn = sourceColumn pos
            return . unlines $
                [ offendingLine
                , (replicate (pred offendingColumn) ' ') <> "^"
                ]

    in unlines . catMaybes $
        [ sourceLocation
        , markerLines
        , Just (peErrorMessage e)
        ]

-- | Helper function to create a Ginger parser error from a Parsec error.
fromParsecError :: ParseError -> ParserError
fromParsecError e =
    ParserError
        (dropWhile (== '\n') .
            showErrorMessages
            "or"
            "unknown parse error"
            "expecting"
            "unexpected"
            "end of input"
            $ errorMessages e)
        (Just $ errorPos e)

-- | Parse Ginger source from a file. Both the initial template and all
-- subsequent includes are loaded through the provided 'IncludeResolver'. A
-- consequence of this is that if you pass a \"null resolver\" (like `const
-- (return Nothing)`), this function will always fail.
parseGingerFile :: forall m. Monad m
                => IncludeResolver m
                -> SourceName
                -> m (Either ParserError (Template SourcePos))
parseGingerFile resolver sourceName =
    parseGingerFile' opts sourceName
    where
        opts :: ParserOptions m
        opts =
            (mkParserOptions resolver)
                { poSourceName = Just sourceName }

-- | Parse Ginger source from memory. The initial template is taken directly
-- from the provided 'Source', while all subsequent includes are loaded through
-- the provided 'IncludeResolver'.
parseGinger :: forall m. Monad m
            => IncludeResolver m
            -> Maybe SourceName
            -> Source
            -> m (Either ParserError (Template SourcePos))
parseGinger resolver sourceName source =
    parseGinger' opts source
    where
        opts :: ParserOptions m
        opts =
            (mkParserOptions resolver)
                { poSourceName = sourceName }

-- | Parse Ginger source from a file. Flavor of 'parseGingerFile' that takes
-- additional 'ParserOptions'.
parseGingerFile' :: Monad m => ParserOptions m -> SourceName -> m (Either ParserError (Template SourcePos))
parseGingerFile' opts' fn = do
    let opts = opts' { poSourceName = Just fn }
    let resolve = poIncludeResolver opts
    srcMay <- resolve fn
    case srcMay of
        Nothing -> return . Left $
            ParserError
                { peErrorMessage = "Template source not found: " ++ fn
                , peSourcePosition = Nothing
                }
        Just src -> parseGinger' opts src

-- | Parse Ginger source from memory. Flavor of 'parseGinger' that takes
-- additional 'ParserOptions'.
parseGinger' :: Monad m => ParserOptions m -> Source -> m (Either ParserError (Template SourcePos))
parseGinger' opts src = do
    result <-
        runReaderT
            ( runParserT
                (templateP `before` eof)
                defParseState { psDelimiters = poDelimiters opts }
                (fromMaybe "<<unknown>>" $ poSourceName opts)
                src
            )
            opts
    case result of
        Right t -> return . Right $ t
        Left e -> return . Left $ fromParsecError e


-- | Delimiter configuration.
data Delimiters
    = Delimiters
        { delimOpenInterpolation :: String
        , delimCloseInterpolation :: String
        , delimOpenTag :: String
        , delimCloseTag :: String
        , delimOpenComment :: String
        , delimCloseComment :: String
        }

-- | Default delimiter configuration: @{{ }}@ for interpolation, @{% %}@ for
-- tags, @{# #}@ for comments.
defDelimiters :: Delimiters
defDelimiters
    = Delimiters
        { delimOpenInterpolation = "{{"
        , delimCloseInterpolation = "}}"
        , delimOpenTag = "{%"
        , delimCloseTag = "%}"
        , delimOpenComment = "{#"
        , delimCloseComment = "#}"
        }

data ParserOptions m
    = ParserOptions
        { -- | How to load templates / includes
          poIncludeResolver :: IncludeResolver m
          -- | Current source file name, if any
        , poSourceName :: Maybe SourceName
          -- | Disable newline stripping
        , poKeepTrailingNewline :: Bool
          -- | Enable auto-stripping of @{% block %}@s
        , poLStripBlocks :: Bool
          -- | Enable auto-trimming of @{% block %}@s
        , poTrimBlocks :: Bool
          -- | Interpolation, tag, and comment delimiters
        , poDelimiters :: Delimiters
        }

-- | Default parser options for a given resolver
mkParserOptions :: Monad m => IncludeResolver m -> ParserOptions m
mkParserOptions resolver =
    ParserOptions
        { poIncludeResolver = resolver
        , poSourceName = Nothing
        , poKeepTrailingNewline = False
        , poLStripBlocks = False
        , poTrimBlocks = False
        , poDelimiters = defDelimiters
        }

data ParseState
    = ParseState
        { psBlocks :: HashMap VarName (Block SourcePos)
        , psStripIndent :: String
        , psDelimiters :: Delimiters
        }

defParseState :: ParseState
defParseState =
    ParseState
        { psBlocks = HashMap.empty
        , psStripIndent = ""
        , psDelimiters = defDelimiters
        }

type Parser m a = ParsecT String ParseState (ReaderT (ParserOptions m) m) a

ignore :: Monad m => m a -> m ()
ignore = (>> return ())

ifFlag :: Monad m => (ParserOptions m -> Bool) -> Parser m () -> Parser m () -> Parser m ()
ifFlag flag yes no = do
    cond <- asks flag
    if cond then yes else no

whenFlag :: Monad m => (ParserOptions m -> Bool) -> Parser m () -> Parser m ()
whenFlag flag yes = do
    cond <- asks flag
    when cond yes

unlessFlag :: Monad m => (ParserOptions m -> Bool) -> Parser m () -> Parser m ()
unlessFlag flag no = do
    cond <- asks flag
    when (not cond) no

getResolver :: Monad m => Parser m (IncludeResolver m)
getResolver = asks poIncludeResolver

include :: Monad m => SourceName -> Parser m (Statement SourcePos)
include sourceName =
  PreprocessedIncludeS
    <$> getPosition
    <*> includeTemplate sourceName

-- include sourceName = templateBody <$> includeTemplate sourceName

includeTemplate :: Monad m => SourceName -> Parser m (Template SourcePos)
includeTemplate sourceName = do
    resolver <- getResolver
    currentSource <- fromMaybe "" <$> asks poSourceName
    let includeSourceName = takeDirectory currentSource </> sourceName
    opts <- ask
    pres <- lift . lift $ parseGingerFile' opts includeSourceName
    case pres of
        Right t -> return t
        Left err -> fail (show err)

reduceStatements :: SourcePos -> [(Statement SourcePos)] -> (Statement SourcePos)
reduceStatements pos [] = NullS pos
reduceStatements pos [x] = x
reduceStatements pos xs = MultiS pos xs

templateP :: Monad m => Parser m (Template SourcePos)
templateP = derivedTemplateP <|> baseTemplateP

derivedTemplateP :: Monad m => Parser m (Template SourcePos)
derivedTemplateP = do
    pos <- getPosition
    parentName <- try (spaces >> fancyTagP "extends" stringLiteralP)
    parentTemplate <- includeTemplate parentName
    topLevelBlocks <- HashMap.fromList <$> many blockP
    nestedBlocks <- psBlocks <$> getState
    let blocks = topLevelBlocks <> nestedBlocks
    return
        Template
            { templateBody = NullS pos
            , templateParent = Just parentTemplate
            , templateBlocks = blocks
            }

baseTemplateP :: Monad m => Parser m (Template SourcePos)
baseTemplateP = do
    body <- statementsP
    blocks <- psBlocks <$> getState
    return
        Template
            { templateBody = body
            , templateParent = Nothing
            , templateBlocks = blocks
            }

isNullS (NullS _) = True
isNullS _ = False

statementsP :: Monad m => Parser m (Statement SourcePos)
statementsP = do
    pos <- getPosition
    reduceStatements pos . filter (not . isNullS) <$> many (try statementP)

scriptStatementsP :: Monad m => Parser m (Statement SourcePos)
scriptStatementsP = do
    spacesOrComment
    pos <- getPosition
    reduceStatements pos . filter (not . isNullS) <$>
        many (try scriptStatementP)


scriptStatementBlockP :: Monad m => Parser m (Statement SourcePos)
scriptStatementBlockP = do
    char '{'
    spacesOrComment
    inner <- scriptStatementsP
    char '}'
    spacesOrComment
    return inner

statementP :: Monad m => Parser m (Statement SourcePos)
statementP = interpolationStmtP
           <|> commentStmtP
           <|> tryCatchStmtP
           <|> ifStmtP
           <|> switchStmtP
           <|> setStmtP
           <|> forStmtP
           <|> includeP
           <|> macroStmtP
           <|> blockStmtP
           <|> callStmtP
           <|> scopeStmtP
           <|> indentStmtP
           <|> scriptStmtP
           <|> literalStmtP

scriptStatementP :: Monad m => Parser m (Statement SourcePos)
scriptStatementP = scriptStatementBlockP
                 <|> scriptEchoStmtP
                 <|> scriptIfStmtP
                 <|> scriptSwitchStmtP
                 <|> scriptSetStmtP
                 <|> scriptForStmtP
                 <|> scriptIncludeP
                 <|> scriptMacroStmtP
                 <|> scriptScopeStmtP
                 <|> scriptExprStmtP

interpolationStmtP :: Monad m => Parser m (Statement SourcePos)
interpolationStmtP = do
    pos <- getPosition
    try openInterpolationP
    spacesOrComment
    expr <- expressionP
    spacesOrComment
    closeInterpolationP
    return $ InterpolationS pos expr

scriptEchoStmtP :: Monad m => Parser m (Statement SourcePos)
scriptEchoStmtP = do
    pos <- getPosition
    try $ keyword "echo"
    spacesOrComment
    char '('
    expr <- expressionP
    spacesOrComment
    char ')'
    spacesOrComment
    char ';'
    spacesOrComment
    return $ InterpolationS pos expr

literalStmtP :: Monad m => Parser m (Statement SourcePos)
literalStmtP = do
    pos <- getPosition
    txt <- concat <$> manyTill literalCharsP endOfLiteralP

    case txt of
        [] -> unexpected "{{"
        _ -> return . LiteralS pos . unsafeRawHtml . Text.pack $ txt

literalCharsP :: Monad m => Parser m [Char]
literalCharsP = do
    dlims <- psDelimiters <$> getState
    let forbiddenChars =
          nub . sort $
            " \t\r\n" ++
            delimOpenInterpolation dlims ++
            delimOpenComment dlims ++
            delimOpenTag dlims
    (some $ noneOf forbiddenChars) <|>
      (fmap (:[]) literalNewlineP) <|>
      some space <|>
      (fmap (:[]) anyChar)

literalNewlineP :: Monad m => Parser m Char
literalNewlineP = do
    stripStr <- psStripIndent <$> getState
    char '\n'
    when (not $ null stripStr) (ignore . optional . try $ string stripStr)
    return '\n'

endOfLiteralP :: Monad m => Parser m ()
endOfLiteralP =
    (ignore . lookAhead . try $ openInterpolationP) <|>
    (ignore . lookAhead $ openTagP) <|>
    (ignore . lookAhead $ openCommentP) <|>
    eof

commentStmtP :: Monad m => Parser m (Statement SourcePos)
commentStmtP = do
    pos <- getPosition
    try openCommentP
    manyTill
        (   (noneOf "#" *> return ())
        <|> (try $ char '#' *> notFollowedBy (char '}'))
        )
        (try closeCommentP)
    return $ NullS pos

scriptCommentP :: Monad m => Parser m ()
scriptCommentP = do
    try $ char '#' *> notFollowedBy (char '}')
    manyTill anyChar endl
    spacesOrComment

spacesOrComment :: Monad m => Parser m ()
spacesOrComment = do
    many $ scriptCommentP <|> (oneOf " \t\r\n" *> return ())
    return ()

scriptExprStmtP :: Monad m => Parser m (Statement SourcePos)
scriptExprStmtP = do
    pos <- getPosition
    expr <- try $ expressionP
    char ';'
    spacesOrComment
    return $ ExpressionS pos expr

endl :: Monad m => Parser m Char
endl = char '\n' <|> (char '\r' >> char '\n')

scriptStmtP :: Monad m => Parser m (Statement SourcePos)
scriptStmtP =
    between
        (try $ simpleTagP "script")
        (simpleTagP "endscript")
        scriptStatementsP

ifStmtP :: Monad m => Parser m (Statement SourcePos)
ifStmtP = do
    pos <- getPosition
    condExpr <- fancyTagP "if" expressionP
    trueStmt <- statementsP
    falseStmt <- elifBranchP <|> elseBranchP <|> (NullS <$> getPosition)
    simpleTagP "endif"
    return $ IfS pos condExpr trueStmt falseStmt

elseBranchP :: Monad m => Parser m (Statement SourcePos)
elseBranchP = do
    try $ simpleTagP "else"
    statementsP

elifBranchP :: Monad m => Parser m (Statement SourcePos)
elifBranchP = do
    pos <- getPosition
    condExpr <- try $ fancyTagP "elif" expressionP
    trueStmt <- statementsP
    falseStmt <- elifBranchP <|> elseBranchP <|> (NullS <$> getPosition)
    -- No endif here: the parent {% if %} owns that one.
    return $ IfS pos condExpr trueStmt falseStmt

scriptIfStmtP :: Monad m => Parser m (Statement SourcePos)
scriptIfStmtP = do
    pos <- getPosition
    try $ keyword "if"
    spacesOrComment
    char '('
    condExpr <- expressionP
    spacesOrComment
    char ')'
    spacesOrComment
    trueStmt <- scriptStatementP
    spacesOrComment
    falseStmt <- scriptElifP <|> scriptElseP <|> (NullS <$> getPosition)
    return $ IfS pos condExpr trueStmt falseStmt

scriptElseP :: Monad m => Parser m (Statement SourcePos)
scriptElseP = do
    try $ keyword "else"
    spacesOrComment
    scriptStatementP

scriptElifP :: Monad m => Parser m (Statement SourcePos)
scriptElifP = do
    pos <- getPosition
    try $ keyword "elif"
    spacesOrComment
    char '('
    spacesOrComment
    condExpr <- expressionP
    spacesOrComment
    char ')'
    spacesOrComment
    trueStmt <- scriptStatementP
    spacesOrComment
    falseStmt <- scriptElifP <|> scriptElseP <|> (NullS <$> getPosition)
    return $ IfS pos condExpr trueStmt falseStmt

tryCatchStmtP :: Monad m => Parser m (Statement SourcePos)
tryCatchStmtP = do
    pos <- getPosition
    try $ simpleTagP "try"
    tryS <- statementsP
    catchesS <- many catchBranchP
    finallyS <- finallyBranchP <|> (NullS <$> getPosition)
    simpleTagP "endtry"
    return $ TryCatchS pos tryS catchesS finallyS

catchBranchP :: Monad m => Parser m (CatchBlock SourcePos)
catchBranchP = do
    (what, captureName) <- try $
        fancyTagP "catch" (try catchHeaderP <|> return (Nothing, Nothing))
    body <- statementsP
    return $ Catch what captureName body

suchThat :: Monad m => (a -> Bool) -> Parser m a -> Parser m a
suchThat p action = do
    val <- action
    if p val then return val else fail "Requirement not met"

catchHeaderP :: Monad m => Parser m (Maybe Text, Maybe VarName)
catchHeaderP = do
    spaces
    what <- catchWhatP
    spaces
    captureName <- catchCaptureP
    return $ (what, captureName)

catchWhatP :: Monad m => Parser m (Maybe Text)
catchWhatP =
    (Nothing <$ char '*') <|>
    (Just . Text.pack <$> try stringLiteralP) <|>
    (Just <$> try identifierP)

catchCaptureP :: Monad m => Parser m (Maybe VarName)
catchCaptureP = optionMaybe $ do
    try (string "as" >> notFollowedBy identCharP)
    spaces
    identifierP

finallyBranchP :: Monad m => Parser m (Statement SourcePos)
finallyBranchP = do
    try $ simpleTagP "finally"
    statementsP

-- TODO: try/catch/finally in script mode

switchStmtP :: Monad m => Parser m (Statement SourcePos)
switchStmtP = do
    pos <- getPosition
    pivotExpr <- try $ fancyTagP "switch" expressionP
    cases <- many switchCaseP
    def <- switchDefaultP <|> (NullS <$> getPosition)
    simpleTagP "endswitch"
    return $ SwitchS pos pivotExpr cases def

switchCaseP :: Monad m => Parser m ((Expression SourcePos), (Statement SourcePos))
switchCaseP = do
    cmpExpr <- try $ fancyTagP "case" expressionP
    body <- statementsP
    simpleTagP "endcase"
    return (cmpExpr, body)

switchDefaultP :: Monad m => Parser m (Statement SourcePos)
switchDefaultP = do
    try (simpleTagP "default") *> statementsP <* simpleTagP "enddefault"

scriptSwitchStmtP :: Monad m => Parser m (Statement SourcePos)
scriptSwitchStmtP = do
    pos <- getPosition
    try $ keyword "switch"
    spacesOrComment
    char '('
    spacesOrComment
    pivotExpr <- expressionP
    spacesOrComment
    char ')'
    spacesOrComment
    char '{'
    spacesOrComment
    cases <- many scriptSwitchCaseP
    def <- scriptSwitchDefaultP <|> (NullS <$> getPosition)
    spacesOrComment
    char '}'
    spacesOrComment
    return $ SwitchS pos pivotExpr cases def

scriptSwitchCaseP :: Monad m => Parser m ((Expression SourcePos), (Statement SourcePos))
scriptSwitchCaseP = do
    try $ keyword "case"
    spacesOrComment
    cmpExpr <- expressionP
    spacesOrComment
    char ':'
    spacesOrComment
    body <- scriptStatementP
    spacesOrComment
    return (cmpExpr, body)

scriptSwitchDefaultP :: Monad m => Parser m (Statement SourcePos)
scriptSwitchDefaultP = do
    try $ keyword "default"
    spacesOrComment
    char ':'
    spacesOrComment
    body <- scriptStatementP
    spacesOrComment
    return body

setStmtP :: Monad m => Parser m (Statement SourcePos)
setStmtP = do
    pos <- getPosition
    fancyTagP "set" (setStmtInnerP pos)

setStmtInnerP :: Monad m => SourcePos -> Parser m (Statement SourcePos)
setStmtInnerP pos = do
    name <- identifierP
    spacesOrComment
    char '='
    spacesOrComment
    val <- expressionP
    spacesOrComment
    return $ SetVarS pos name val

scriptSetStmtP :: Monad m => Parser m (Statement SourcePos)
scriptSetStmtP = do
    pos <- getPosition
    try $ keyword "set"
    spacesOrComment
    name <- identifierP
    spacesOrComment
    char '='
    spacesOrComment
    val <- expressionP
    spacesOrComment
    char ';'
    spacesOrComment
    return $ SetVarS pos name val

defineBlock :: VarName -> Block SourcePos -> ParseState -> ParseState
defineBlock name block s =
    s { psBlocks = HashMap.insert name block (psBlocks s) }

blockStmtP :: Monad m => Parser m (Statement SourcePos)
blockStmtP = do
    pos <- getPosition
    (name, block) <- blockP
    modifyState (defineBlock name block)
    return $ BlockRefS pos name

blockP :: Monad m => Parser m (VarName, (Block SourcePos))
blockP = do
    name <- fancyTagP "block" identifierP
    body <- statementsP
    fancyTagP "endblock" (optional $ string (Text.unpack name) >> spacesOrComment)
    return (name, Block body)

macroStmtP :: Monad m => Parser m (Statement SourcePos)
macroStmtP = do
    pos <- getPosition
    (name, args) <- try $ fancyTagP "macro" macroHeadP
    body <- statementsP
    fancyTagP "endmacro" (optional $ string (Text.unpack name) >> spacesOrComment)
    return $ DefMacroS pos name (Macro args body)

scriptMacroStmtP :: Monad m => Parser m (Statement SourcePos)
scriptMacroStmtP = do
    pos <- getPosition
    try $ keyword "macro"
    spacesOrComment
    name <- identifierP
    spacesOrComment
    args <- option [] $ groupP "(" ")" identifierP
    spacesOrComment
    body <- scriptStatementP
    spacesOrComment
    return $ DefMacroS pos name (Macro args body)

macroHeadP :: Monad m => Parser m (VarName, [VarName])
macroHeadP = do
    name <- identifierP
    spacesOrComment
    args <- option [] $ groupP "(" ")" identifierP
    spacesOrComment
    return (name, args)

-- {% call (foo) bar(baz) %}quux{% endcall %}
--
-- is the same as:
--
-- {% scope %}
-- {% macro __lambda(foo) %}quux{% endmacro %}
-- {% set caller = __lambda %}
-- {{ bar(baz) }}
-- {% endscope %]
callStmtP :: Monad m => Parser m (Statement SourcePos)
callStmtP = do
    pos <- getPosition
    (callerArgs, call) <- try $ fancyTagP "call" callHeadP
    body <- statementsP
    simpleTagP "endcall"
    return (
        ScopedS pos (
            MultiS pos
                [ DefMacroS pos "caller" (Macro callerArgs body)
                , InterpolationS pos call
                ]))

callHeadP :: Monad m => Parser m ([Text], (Expression SourcePos))
callHeadP = do
    callerArgs <- option [] $ groupP "(" ")" identifierP
    spacesOrComment
    call <- expressionP
    spacesOrComment
    return (callerArgs, call)

scopeStmtP :: Monad m => Parser m (Statement SourcePos)
scopeStmtP =
    ScopedS
        <$> getPosition
        <*> between
            (try $ simpleTagP "scope")
            (simpleTagP "endscope")
            statementsP

indentStmtP :: Monad m => Parser m (Statement SourcePos)
indentStmtP = do
    pos <- getPosition
    indentExpr <- try $ fancyTagP "indent" indentHeadP
    preIndent <- many (oneOf " \t")
    oldState <- getState
    modifyState $ \state ->
        state { psStripIndent = preIndent }
    body <- statementsP
    putState oldState
    simpleTagP "endindent"
    return $ IndentS pos indentExpr body

indentHeadP :: Monad m => Parser m (Expression SourcePos)
indentHeadP =
    (expressionP <|> (StringLiteralE <$> getPosition <*> pure "  ")) <* spacesOrComment

scriptScopeStmtP :: Monad m => Parser m (Statement SourcePos)
scriptScopeStmtP = do
    pos <- getPosition
    try $ keyword "scope"
    spacesOrComment
    ScopedS pos <$> scriptStatementP

forStmtP :: Monad m => Parser m (Statement SourcePos)
forStmtP = do
    pos <- getPosition
    (iteree, varNameVal, varNameIndex) <- fancyTagP "for" forHeadP
    body <- statementsP
    elseBranchMay <- optionMaybe $ do
        try $ simpleTagP "else"
        statementsP
    simpleTagP "endfor"
    let forLoop = ForS pos varNameIndex varNameVal iteree body
    return $ maybe
        forLoop
        (IfS pos iteree forLoop)
        elseBranchMay

scriptForStmtP :: Monad m => Parser m (Statement SourcePos)
scriptForStmtP = do
    pos <- getPosition
    try $ keyword "for"
    spacesOrComment
    char '('
    (iteree, varNameVal, varNameIndex) <- forHeadP
    spacesOrComment
    char ')'
    spacesOrComment
    body <- scriptStatementP
    elseBranchMay <- optionMaybe $ do
        try $ keyword "else"
        spacesOrComment
        scriptStatementP
    let forLoop = ForS pos varNameIndex varNameVal iteree body
    return $ maybe
        forLoop
        (IfS pos iteree forLoop)
        elseBranchMay

includeP :: Monad m => Parser m (Statement SourcePos)
includeP = do
    sourceName <- fancyTagP "include" stringLiteralP
    include sourceName

scriptIncludeP :: Monad m => Parser m (Statement SourcePos)
scriptIncludeP = do
    try $ keyword "include"
    spacesOrComment
    char '('
    sourceName <- stringLiteralP
    spacesOrComment
    char ')'
    spacesOrComment
    char ';'
    spacesOrComment
    include sourceName

forHeadP :: Monad m => Parser m ((Expression SourcePos), VarName, Maybe VarName)
forHeadP =
    (try forHeadInP <|> forHeadAsP) <* optional (keyword "recursive" >>spacesOrComment)

forIteratorP :: Monad m => Parser m (VarName, Maybe VarName)
forIteratorP = try forIndexedIteratorP <|> try forSimpleIteratorP <?> "iteration variables"

forIndexedIteratorP :: Monad m => Parser m (VarName, Maybe VarName)
forIndexedIteratorP = do
    indexIdent <- identifierP
    spacesOrComment
    char ','
    spacesOrComment
    varIdent <- identifierP
    spacesOrComment
    return (varIdent, Just indexIdent)

forSimpleIteratorP :: Monad m => Parser m (VarName, Maybe VarName)
forSimpleIteratorP = do
    varIdent <- identifierP
    spacesOrComment
    return (varIdent, Nothing)

forHeadInP :: Monad m => Parser m ((Expression SourcePos), VarName, Maybe VarName)
forHeadInP = do
    (varIdent, indexIdent) <- forIteratorP
    spacesOrComment
    keyword "in"
    spacesOrComment
    iteree <- expressionP
    return (iteree, varIdent, indexIdent)

forHeadAsP :: Monad m => Parser m ((Expression SourcePos), VarName, Maybe VarName)
forHeadAsP = do
    iteree <- expressionP
    spacesOrComment
    keyword "as"
    spacesOrComment
    (varIdent, indexIdent) <- forIteratorP
    return (iteree, varIdent, indexIdent)

fancyTagP :: Monad m => String -> Parser m a -> Parser m a
fancyTagP tagName =
    between
        (try $ do
            openTagP
            keyword tagName
            spacesOrComment)
        closeTagP

simpleTagP :: Monad m => String -> Parser m ()
simpleTagP tagName = openTagP >> string tagName >> closeTagP

openInterpolationP :: Monad m => Parser m ()
openInterpolationP =
    delimOpenInterpolation . psDelimiters <$> getState >>= openP

closeInterpolationP :: Monad m => Parser m ()
closeInterpolationP =
    delimCloseInterpolation . psDelimiters <$> getState >>= closeP

openCommentP :: Monad m => Parser m ()
openCommentP =
    delimOpenComment . psDelimiters <$> getState >>= openP

closeCommentP :: Monad m => Parser m ()
closeCommentP =
    delimCloseComment . psDelimiters <$> getState >>= closeP

openTagP :: Monad m => Parser m ()
openTagP =
    delimOpenTag . psDelimiters <$> getState >>= openP

closeTagP :: Monad m => Parser m ()
closeTagP = do
    delimCloseTag . psDelimiters <$> getState >>= closeP
    unlessFlag poKeepTrailingNewline
        (ignore . optional $ literalNewlineP)

openP :: Monad m => String -> Parser m ()
openP c = try (openWP c)
        <|> try (openFWP c)
        <|> try (openNWP c)

openWP :: Monad m => String -> Parser m ()
openWP c = ignore $ do
    spaces
    string $ c ++ "-"
    spacesOrComment

openFWP :: Monad m => String -> Parser m ()
openFWP c = ignore $ do
    string $ c ++ "+"
    spacesOrComment


openNWP :: Monad m => String -> Parser m ()
openNWP c = ignore $ do
    whenFlag poLStripBlocks spaces
    string c
    notFollowedBy $ oneOf "+-"
    spacesOrComment

closeP :: Monad m => String -> Parser m ()
closeP c = try (closeWP c)
         <|> try (closeFWP c)
         <|> try (closeNWP c)

closeWP :: Monad m => String -> Parser m ()
closeWP c = ignore $ do
    spacesOrComment
    string $ '-':c
    spaces

closeFWP :: Monad m => String -> Parser m ()
closeFWP c = ignore $ do
    spacesOrComment
    string $ '+':c

closeNWP :: Monad m => String -> Parser m ()
closeNWP c = ignore $ do
    spacesOrComment
    string c
    whenFlag poTrimBlocks spaces

expressionP :: Monad m => Parser m (Expression SourcePos)
expressionP = lambdaExprP <|> ternaryExprP

lambdaExprP :: Monad m => Parser m (Expression SourcePos)
lambdaExprP = do
    pos <- getPosition
    argNames <- try $ do
        char '('
        spacesOrComment
        argNames <- sepBy (spacesOrComment>> identifierP) (try $ spacesOrComment>> char ',')
        char ')'
        spacesOrComment
        string "->"
        spacesOrComment
        return argNames
    body <- expressionP
    return $ LambdaE pos argNames body

operativeExprP :: forall m. Monad m => Parser m (Expression SourcePos) -> [ (String, Text) ] -> Parser m (Expression SourcePos)
operativeExprP operandP operators = do
    pos0 <- getPosition
    lhs <- operandP
    spacesOrComment
    tails <- many . try $ operativeTail pos0
    return $ foldl (flip ($)) lhs tails
    where
        opChars :: [Char]
        opChars = nub . sort . concatMap fst $ operators
        operativeTail :: SourcePos -> Parser m (Expression SourcePos -> Expression SourcePos)
        operativeTail pos0 = do
            pos <- getPosition
            funcName <-
                foldl (<|>) (fail "operator")
                    [ try (string op >> notFollowedBy (oneOf opChars)) >> return fn | (op, fn) <- operators ]
            spacesOrComment
            rhs <- operandP
            spacesOrComment
            return (\lhs -> CallE pos0 (VarE pos funcName) [(Nothing, lhs), (Nothing, rhs)])

ternaryExprP :: Monad m => Parser m (Expression SourcePos)
ternaryExprP = do
    pos <- getPosition
    expr1 <- booleanExprP
    spacesOrComment
    cTernaryTailP pos expr1 <|> pyTernaryTailP pos expr1 <|> return expr1

cTernaryTailP :: Monad m => SourcePos -> (Expression SourcePos) -> Parser m (Expression SourcePos)
cTernaryTailP pos condition = try $ do
    char '?'
    spacesOrComment
    yesBranch <- expressionP
    char ':'
    spacesOrComment
    noBranch <- expressionP
    return $ TernaryE pos condition yesBranch noBranch

pyTernaryTailP :: Monad m => SourcePos -> (Expression SourcePos) -> Parser m (Expression SourcePos)
pyTernaryTailP pos yesBranch = do
    keyword "if"
    spacesOrComment
    condition <- booleanExprP
    keyword "else"
    spacesOrComment
    noBranch <- expressionP
    return $ TernaryE pos condition yesBranch noBranch

booleanExprP :: Monad m => Parser m (Expression SourcePos)
booleanExprP =
    operativeExprP
        comparativeExprP
        [ ("or", "any")
        , ("||", "any")
        , ("and", "all")
        , ("&&", "all")
        ]

comparativeExprP :: Monad m => Parser m (Expression SourcePos)
comparativeExprP =
    operativeExprP
        additiveExprP
        [ ("==", "equals")
        , ("!=", "nequals")
        , (">=", "greaterEquals")
        , ("<=", "lessEquals")
        , (">", "greater")
        , ("<", "less")
        ]

additiveExprP :: Monad m => Parser m (Expression SourcePos)
additiveExprP =
    operativeExprP
        multiplicativeExprP
        [ ("+", "sum")
        , ("-", "difference")
        , ("~", "concat")
        ]

multiplicativeExprP :: Monad m => Parser m (Expression SourcePos)
multiplicativeExprP =
    operativeExprP
        postfixExprP
        [ ("*", "product")
        , ("//", "int_ratio")
        , ("/", "ratio")
        , ("%", "modulo")
        ]

postfixExprP :: Monad m => Parser m (Expression SourcePos)
postfixExprP = do
    pos <- getPosition
    base <- atomicExprP
    spacesOrComment
    postfixes <- many . try $ postfixP pos `before`spacesOrComment
    return $ foldl (flip ($)) base postfixes

postfixP :: Monad m => SourcePos -> Parser m ((Expression SourcePos) -> (Expression SourcePos))
postfixP pos = dotPostfixP pos
             <|> arrayAccessP
             <|> funcCallP
             <|> filterP
             <|> testExprP

dotPostfixP :: Monad m => SourcePos -> Parser m ((Expression SourcePos) -> (Expression SourcePos))
dotPostfixP pos = do
    char '.'
    spacesOrComment
    i <- StringLiteralE <$> getPosition <*> identifierP
    return $ \e -> MemberLookupE pos e i

arrayAccessP :: Monad m => Parser m ((Expression SourcePos) -> (Expression SourcePos))
arrayAccessP = do
    pos <- getPosition
    bracedP "[" "]" (inner pos)
    where
        inner pos = try (sliceInner pos) <|> indexInner pos
        sliceInner pos = do
            offset <- try expressionP <|> (NullLiteralE <$> getPosition)
            char ':'
            length <- try expressionP <|> (NullLiteralE <$> getPosition)
            return $ \e ->
                CallE
                    pos
                    (VarE pos "slice")
                    [ (Nothing, e)
                    , (Nothing, offset)
                    , (Nothing, length)
                    ]
        indexInner pos = do
            i <- expressionP
            return $ \e -> MemberLookupE pos e i

funcCallP :: Monad m => Parser m ((Expression SourcePos) -> (Expression SourcePos))
funcCallP = do
    pos <- getPosition
    args <- groupP "(" ")" funcArgP
    return $ \e -> CallE pos e args

funcArgP :: Monad m => Parser m (Maybe Text, (Expression SourcePos))
funcArgP = namedFuncArgP <|> positionalFuncArgP

namedFuncArgP :: Monad m => Parser m (Maybe Text, (Expression SourcePos))
namedFuncArgP = do
    name <- try $ identifierP `before` between spacesOrComment spacesOrComment (string "=")
    expr <- expressionP
    return (Just name, expr)

positionalFuncArgP :: Monad m => Parser m (Maybe Text, (Expression SourcePos))
positionalFuncArgP = try $ (Nothing,) <$> expressionP

filterP :: Monad m => Parser m ((Expression SourcePos) -> (Expression SourcePos))
filterP = do
    pos <- getPosition
    char '|'
    spacesOrComment
    func <- atomicExprP
    args <- option [] $ groupP "(" ")" funcArgP
    return $ \e -> CallE pos func ((Nothing, e):args)

testExprP :: Monad m => Parser m ((Expression SourcePos) -> (Expression SourcePos))
testExprP = do
    pos <- getPosition
    keyword "is"
    spacesOrComment
    funcName <- atomicExprP
    args <- choice [groupP "(" ")" funcArgP
                  , option [] $ funcArgP >>= (\a -> return [a])]
    return $ \e -> CallE pos (addIsPrefix funcName) ((Nothing, e):args)
    where
      addIsPrefix :: Expression a -> Expression a
      addIsPrefix expr = case expr of
                           (VarE a text) -> VarE a $ Text.append (Text.pack "is_") text
                           _ -> expr

atomicExprP :: Monad m => Parser m (Expression SourcePos)
atomicExprP = doExprP
            <|> parenthesizedExprP
            <|> objectExprP
            <|> listExprP
            <|> stringLiteralExprP
            <|> numberLiteralExprP
            <|> varExprP

parenthesizedExprP :: Monad m => Parser m (Expression SourcePos)
parenthesizedExprP =
    between
        (try . ignore $ char '(' >> spacesOrComment)
        (ignore $ char ')' >> spacesOrComment)
        expressionP

doExprP :: Monad m => Parser m (Expression SourcePos)
doExprP = do
    pos <- getPosition
    try $ keyword "do"
    spacesOrComment
    stmt <- scriptStatementP
    spacesOrComment
    return $ DoE pos stmt

listExprP :: Monad m => Parser m (Expression SourcePos)
listExprP =
    ListE
        <$> getPosition
        <*> groupP "[" "]" expressionP

objectExprP :: Monad m => Parser m (Expression SourcePos)
objectExprP = ObjectE
    <$> getPosition
    <*> groupP "{" "}" expressionPairP

expressionPairP :: Monad m => Parser m ((Expression SourcePos), (Expression SourcePos))
expressionPairP = do
    a <- expressionP
    spacesOrComment
    char ':'
    spacesOrComment
    b <- expressionP
    spacesOrComment
    return (a, b)

groupP :: Monad m => String -> String -> Parser m a -> Parser m [a]
groupP obr cbr inner =
    bracedP obr cbr
        (sepBy (inner `before` spacesOrComment) (try $ string "," `before` spacesOrComment))

bracedP :: Monad m => String -> String -> Parser m a -> Parser m a
bracedP obr cbr =
    between
        (try . ignore $ string obr >> spacesOrComment)
        (ignore $ string cbr >> spacesOrComment)

varExprP :: Monad m => Parser m (Expression SourcePos)
varExprP = do
    pos <- getPosition
    litName <- identifierP
    spacesOrComment
    return $ case litName of
        "True" -> BoolLiteralE pos True
        "true" -> BoolLiteralE pos True
        "False" -> BoolLiteralE pos False
        "false" -> BoolLiteralE pos False
        "null" -> NullLiteralE pos
        _ -> VarE pos litName

identifierP :: Monad m => Parser m Text
identifierP =
    Text.pack <$> (
    (:)
        <$> oneOf (['a'..'z'] ++ ['A'..'Z'] ++ ['_'])
        <*> many identCharP)

identCharP :: Monad m => Parser m Char
identCharP = oneOf (['a'..'z'] ++ ['A'..'Z'] ++ ['_'] ++ ['0'..'9'])

stringLiteralExprP :: Monad m => Parser m (Expression SourcePos)
stringLiteralExprP =
    StringLiteralE
      <$> getPosition
      <*> (Text.pack <$> stringLiteralP)

stringLiteralP :: Monad m => Parser m String
stringLiteralP = do
    d <- oneOf [ '\'', '\"' ]
    manyTill stringCharP (char d)

stringCharP :: Monad m => Parser m Char
stringCharP = do
    c1 <- anyChar
    case c1 of
        '\\' -> do
            c2 <- anyChar
            case c2 of
                'n' -> return '\n'
                'r' -> return '\r'
                'b' -> return '\b'
                'v' -> return '\v'
                '0' -> return '\0'
                't' -> return '\t'
                _ -> return c2
        _ -> return c1

numberLiteralExprP :: Monad m => Parser m (Expression SourcePos)
numberLiteralExprP = do
    pos <- getPosition
    str <- numberLiteralP
    let nMay :: Maybe Scientific
        nMay = readMay str
    case nMay of
        Just n -> return . NumberLiteralE pos $ n
        Nothing -> fail $ "Failed to parse " ++ str ++ " as a number"

numberLiteralP :: Monad m => Parser m String
numberLiteralP = do
    sign <- option "" $ string "-"
    integral <- string "0" <|> ((:) <$> oneOf ['1'..'9'] <*> many digit)
    fractional <- option "" $ (:) <$> char '.' <*> many digit
    return $ sign ++ integral ++ fractional

followedBy :: Monad m => m b -> m a -> m a
followedBy b a = a >>= \x -> b >> return x

before :: Monad m => m a -> m b -> m a
before = flip followedBy

keyword :: Monad m => String -> Parser m String
keyword kw = do
    string kw
    notFollowedBy identCharP
    return kw

-- vim: sw=4