Statements.hs

module Text.HPaco.Readers.Paco.Statements
    ( statements, statement
    )
where

import Control.Monad
import Control.Monad.IO.Class
import Control.Applicative ((<$>), (<*>), some)
import System.IO.Strict
import System.FilePath
import System.IO (withFile, IOMode (ReadMode))
import Text.HPaco.Readers.Paco.Basics
import Text.HPaco.Readers.Paco.ParserInternals
import Text.HPaco.Readers.Paco.Expressions
import Text.HPaco.Readers.Paco.Include
import Text.HPaco.Readers.Common hiding (Parser)
import Text.HPaco.AST.AST
import Text.HPaco.AST.Statement
import Text.HPaco.AST.Expression
import Text.Parsec.Pos (SourcePos, sourceLine, sourceColumn, sourceName)
import qualified Text.HPaco.Readers.Capo.Statements as CapoStatements

statements :: Parser [Statement]
statements =
    concat `liftM` many statementPair
    where statementPair = do
                l <- lineNumberStatement
                s <- statement
                return [l,s]

statement :: Parser Statement
statement = try ifStatement
            <|> try withStatement
            <|> try switchStatement
            <|> try inlineCapoStatement
            <|> try forStatement
            <|> try defStatement
            <|> try callStatement
            <|> try literalBlock
            <|> try commentStatement
            <|> try includeStatement
            <|> try interpolateStatement
            <|> try newlineStatement
            <|> try escapeSequenceStatement
            <|> try rawTextStatement

lineNumberStatement :: Parser Statement
lineNumberStatement = do
    pos <- getPosition
    return $ SourcePositionStatement (sourceName pos) (sourceLine pos)

commentStatement :: Parser Statement
commentStatement = do
    (markL, markR) <- pfCommentMarkers . psFlavor <$> getState
    string markL
    manyTill
        (tryDiscard commentStatement <|> tryDiscard anyChar)
        (try $ string markR)
    return NullStatement

literalBlock :: Parser Statement
literalBlock =
    simpleTag "literal" >>
    PrintStatement . StringLiteral <$>
        manyTill anyChar (try $ simpleTag "endliteral")

includeStatement :: Parser Statement
includeStatement = do
    (basename, innerContext) <- complexTag "include" inner
    performInclude basename innerContext
    where
        inner :: Parser (String, Maybe (String, Expression))
        inner = do
            basename <- path
            ss_
            innerContext <- optionMaybe $ try (ss_ >> string "with" >> ss_ >> letPair)
            return (basename, innerContext)


interpolateStatement :: Parser Statement
interpolateStatement = do
    (markL, markR) <- pfInterpolationMarkers . psFlavor <$> getState
    string markL
    em <- option (Just EscapeHTML) escapeMode
    ss_
    expr <- expression
    ss_
    string markR
    let expr' = maybe
                    expr
                    (\m -> EscapeExpression m expr)
                    em
    return $ PrintStatement $ expr'

rawTextStatement :: Parser Statement
rawTextStatement = do
    chrs <- (:) <$> anyChar <*> manyTill anyChar delimiters
    return $ PrintStatement $ StringLiteral chrs
    where
        delimiters = do
            (leftInterpolation, _) <- pfInterpolationMarkers . psFlavor <$> getState
            (leftComment, _) <- pfCommentMarkers . psFlavor <$> getState
            (leftTag, _) <- pfTagMarkers . psFlavor <$> getState
            lookAhead . some . mapM (try . string) $ [ leftTag, leftComment, leftInterpolation, "\n" ]
            return ()

newlineStatement :: Parser Statement
newlineStatement = do
    char '\n'
    ss_
    return $ PrintStatement $ StringLiteral "\n"

escapeSequenceStatement :: Parser Statement
escapeSequenceStatement = do
    char '\\'
    c <- anyChar
    case c of
        '\n' -> return NullStatement
        otherwise -> return $ PrintStatement $ StringLiteral [ '\\', c ]

ifStatement :: Parser Statement
ifStatement = do
        cond <- complexTag "if" expression
        trueStmts <- statements
        let trueBranch = StatementSequence trueStmts
        falseBranch <- option NullStatement $ try elseBranch
        simpleTag "endif"
        return $ IfStatement cond trueBranch falseBranch
        where elseBranch =
                do
                    simpleTag "else"
                    stmts <- statements
                    return . StatementSequence $ stmts

inlineCapoStatement :: Parser Statement
inlineCapoStatement = do
    simpleTag "capo"
    stmts <- CapoStatements.statements
    simpleTag "endcapo"
    return $ StatementSequence stmts

withStatement :: Parser Statement
withStatement = withOrForStatement (\(n,v) -> LetStatement n v) "with" letPairs

forStatement :: Parser Statement
forStatement = withOrForStatement (\(k, n, v) -> ForStatement k n v) "for" forDefs

withOrForStatement :: (a -> Statement -> Statement) -> String -> Parser [a] -> Parser Statement
withOrForStatement ctor keyword innerP = do
    lets <- complexTag keyword innerP
    stmts <- statements
    simpleTag $ "end" ++ keyword
    return $ foldr ctor (StatementSequence stmts) lets

letPairs :: Parser [(String, Expression)]
letPairs = manySepBy (try letPair) (try $ char ',')

forDefs :: Parser [(Maybe String, String, Expression)]
forDefs = manySepBy (try forDef) (try $ char ',')

letPair :: Parser (String, Expression)
letPair = do
    ss_
    expr <- expression
    ss_
    ident <- option "." $ try $ char ':' >> ss_ >> identifier
    ss_
    return (ident, expr)

forDef :: Parser (Maybe String, String, Expression)
forDef = try forTriple <|> forPair

forPair :: Parser (Maybe String, String, Expression)
forPair = do
    (ident, expr) <- letPair
    return (Nothing, ident, expr)

forTriple :: Parser (Maybe String, String, Expression)
forTriple = do
    ss_
    expr <- expression
    ss_
    char ':'
    ss_
    key <- identifier
    ss_
    doFlip <- option False $ flip
    ss_
    val <- identifier
    ss_
    if doFlip
        then return (Just val, key, expr)
        else return (Just key, val, expr)
    where
        flip = try fwdArr <|> try revArr
        fwdArr = string "->" >> return False
        revArr = string "<-" >> return True

switchStatement :: Parser Statement
switchStatement = do
    masterExpr <- complexTag "switch" expression
    ss_
    branches <- many switchBranch
    ss_
    simpleTag "endswitch"
    return $ SwitchStatement masterExpr branches
    where switchBranch = do
            ss_
            switchExpr <- complexTag "case" expression
            stmts <- statements
            simpleTag "endcase"
            ss_
            return (switchExpr, StatementSequence stmts)

defStatement :: Parser Statement
defStatement = do
    name <- complexTag "def" identifier
    body <- statements
    simpleTag "enddef"
    addDef name $ StatementSequence body
    return NullStatement

callStatement :: Parser Statement
callStatement = do
    name <- complexTag "call" identifier
    optional $ char '\n'
    return $ CallStatement name

simpleTag tag = complexTag tag (return ())

complexTag tag inner =
    let go = do
            (markL, markR) <- pfTagMarkers . psFlavor <$> getState
            string markL
            ss_
            string tag
            ss_
            i <- inner
            ss_
            string markR
            return i
        standalone = do
            assertStartOfLine
            ss_
            v <- go
            char '\n'
            return v

    in try standalone <|> try go

escapeMode :: Parser (Maybe EscapeMode)
escapeMode = (char '!' >> return Nothing)
          <|> (char '@' >> return (Just EscapeURL))