{-#LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
module Text.HPaco.Readers.Paco
    ( readPaco
    )
where

import Control.Monad
import Control.Monad.IO.Class
import Text.HPaco.Reader
import Text.HPaco.AST.AST
import Text.HPaco.AST.Statement
import Text.HPaco.AST.Expression
import Text.Parsec.Prim
import Text.Parsec.Char
import Text.Parsec.Combinator
import Text.Parsec.Pos (SourcePos, sourceLine, sourceColumn)
import Text.Parsec.String hiding (Parser)
import Text.Parsec.Error (ParseError)
import Control.Exception (throw, Exception)
import Data.Typeable
import System.IO (withFile, IOMode (ReadMode))
import System.IO.Strict
import System.FilePath

instance Exception ParseError
deriving instance Typeable ParseError

data PacoState = PacoState
                    { psBasePath :: FilePath
                    , psDefs :: [(String, Statement)]
                    , psIncludeExtension :: Maybe String
                    }

type Parser a = ParsecT String PacoState IO a

defaultPacoState :: PacoState
defaultPacoState = PacoState
                        { psBasePath = ""
                        , psDefs = []
                        , psIncludeExtension = Nothing
                        }

readPaco :: Reader
readPaco filename =
    let pstate = defaultPacoState
                    { psBasePath = takeDirectory filename
                    , psIncludeExtension = renull $ takeExtension filename
                    }
    in readPacoWithState pstate filename
    where renull "" = Nothing
          renull x = Just x

readPacoWithState :: PacoState -> Reader
readPacoWithState pstate filename src = do
    result <- runParserT document pstate filename src
    either
        throw
        return
        result

document :: Parser AST
document = do
    stmts <- many statement
    eof
    pstate <- getState
    return $ AST 
                { astRootStatement = StatementSequence stmts
                , astDefs = psDefs pstate
                }

-- Statement parsers

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

commentStatement :: Parser Statement
commentStatement = do
    string "{%--"
    manyTill
        (try (discard commentStatement) <|> discard anyChar)
        (try $ string "--%}")
    return NullStatement

includeStatement :: Parser Statement
includeStatement = do
    (basename, innerContext) <- complexTag "include" inner
    dirname <- psBasePath `liftM` getState
    extension <- psIncludeExtension `liftM` getState
    let fn0 = joinPath [ dirname, basename ]
    let fn = maybe fn0 (fillExtension fn0) extension
    src <- liftIO $ withFile fn ReadMode hGetContents
    subAst <- liftIO $ readPaco fn src
    let stmt = astRootStatement subAst
    return $ maybe stmt (\(ident, expr) -> LetStatement ident expr stmt) innerContext
    where
        path :: Parser String
        path = many1 $ try $ noneOf " \t\r\n%"

        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
    char '{'
    em <- option (Just EscapeHTML) escapeMode
    ss_
    expr <- expression
    ss_
    char '}'
    let expr' = maybe
                    expr
                    (\m -> EscapeExpression m expr)
                    em
    return $ PrintStatement $ expr'

rawTextStatement :: Parser Statement
rawTextStatement = do
    chrs <- many1 $ noneOf "{\\\n"
    return $ PrintStatement $ StringLiteral chrs

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 <- many statement
        let trueBranch = StatementSequence trueStmts
        falseBranch <- option NullStatement $ try elseBranch
        simpleTag "endif"
        return $ IfStatement cond trueBranch falseBranch
        where elseBranch =
                do
                    simpleTag "else"
                    stmts <- many statement
                    return . StatementSequence $ stmts

withStatement :: Parser Statement
withStatement = withOrForStatement LetStatement "with"

forStatement :: Parser Statement
forStatement = withOrForStatement ForStatement "for"

withOrForStatement :: (String -> Expression -> Statement -> Statement) -> String -> Parser Statement
withOrForStatement ctor keyword = do
    (ident, expr) <- complexTag keyword letPair
    stmts <- many $ try statement
    simpleTag $ "end" ++ keyword
    return $ ctor ident expr $ StatementSequence stmts

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

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 <- many statement
            simpleTag "endcase"
            ss_
            return (switchExpr, StatementSequence stmts)

defStatement :: Parser Statement
defStatement = do
    name <- complexTag "def" identifier
    body <- many statement
    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
            string "{%" 
            ss_ 
            string tag 
            ss_ 
            i <- inner
            ss_
            string "%}" 
            return i
        standalone = do
            assertStartOfLine
            ss_
            v <- go
            char '\n'
            return v

    in try standalone <|> try go


-- Expression parsers

expression = booleanExpression

booleanExpression =
    binaryExpression
        [("&&", OpBooleanAnd),
         ("||", OpBooleanOr),
         ("^^", OpBooleanXor)]
        setOperationExpression

setOperationExpression =
    binaryExpression
        [("in", OpInList),
         ("contains", Flipped OpInList)]
        comparativeExpression

comparativeExpression =
    binaryExpression
        [("==", OpEquals),
         ("!==", OpNotEquals),
         ("=", OpLooseEquals),
         ("!=", OpLooseNotEquals),
         (">=", OpNotLess),
         (">", OpGreater),
         ("<=", OpNotGreater),
         ("<", OpLess)]
        additiveExpression

additiveExpression =
    binaryExpression
        [("+", OpPlus), ("-", OpMinus)]
        multiplicativeExpression

multiplicativeExpression =
    binaryExpression
        [("*", OpMul), ("/", OpDiv), ("%", OpMod)]
        (try traditionalFunctionCallExpression <|> postfixExpression)

binaryExpression :: [(String, BinaryOperator)] -> (Parser Expression) -> Parser Expression
binaryExpression opMap innerParser = do
    let rem :: Parser (BinaryOperator, Expression)
        rem = do
            ss_
            opStr <- foldl1 (<|>) $ map (try . string . fst) opMap
            ss_
            let Just op = lookup opStr opMap
            e <- innerParser
            return (op, e)
    left <- innerParser
    right <- many $ try rem
    return $ foldl combine left right
    where
        combine :: Expression -> (BinaryOperator, Expression) -> Expression
        combine lhs (op, rhs) = BinaryExpression op lhs rhs

traditionalFunctionCallExpression = do
    char '$'
    args <- manySepBy (try expression) ss_
    return $ FunctionCallExpression (head args) (tail args)

postfixExpression = do
    left <- (try prefixExpression <|> simpleExpression)
    postfixes <- many postfix
    return $ foldl combine left postfixes
    where
        combine :: Expression -> (Expression -> Expression) -> Expression
        combine l f = f l

prefixExpression = do
    ss_
    operator <- unaryOperator
    ss_
    expr <- (try prefixExpression <|> simpleExpression)
    return $ UnaryExpression operator expr

unaryOperator = do
    let opMap = [("not", OpNot)]
    opStr <- foldl1 (<|>) $ map (try . string . fst) opMap
    let Just op = lookup opStr opMap
    return op
    
postfix = try memberAccessPostfix
        <|> try indexPostfix
        <|> try functionCallPostfix

memberAccessPostfix :: Parser (Expression -> Expression)
memberAccessPostfix = do
    char '.'
    expr <- StringLiteral `liftM` identifier
    return $ \l -> BinaryExpression OpMember l expr

indexPostfix :: Parser (Expression -> Expression)
indexPostfix = do
    ss_
    char '['
    e <- expression
    char ']'
    ss_
    return $ \l -> BinaryExpression OpMember l e

functionCallPostfix :: Parser (Expression -> Expression)
functionCallPostfix = do
    char '('
    args <- manySepBy (try expression) (try $ ss_ >> char ',' >> ss_)
    ss_
    char ')'
    return $ \l -> FunctionCallExpression l args

simpleExpression :: Parser Expression
simpleExpression  =  floatLiteral
                 <|> intLiteral
                 <|> stringLiteral
                 <|> listExpression
                 <|> alistExpression
                 <|> varRefExpr
                 <|> bracedExpression

bracedExpression :: Parser Expression
bracedExpression = do
    char '('
    ss_
    inner <- expression
    ss_
    char ')'
    return inner

listExpression :: Parser Expression
listExpression = do
    char '['
    ss_
    items <- manySepBy expression (ss_ >> char ',' >> ss_)
    ss_
    optional $ char ',' >> ss_
    char ']'
    return $ ListExpression items

alistExpression :: Parser Expression
alistExpression = do
    char '{'
    ss_
    items <- option [] $ try $ manySepBy elem $ char ','
    ss_
    optional $ char ',' >> ss_
    char '}'
    return $ AListExpression items
    where
        elem :: Parser (Expression, Expression)
        elem = do
            ss_
            key <- expression
            ss_ >> char ':' >> ss_
            value <- expression
            ss_
            return (key, value)

intLiteral :: Parser Expression
intLiteral = do
    sign <- option '+' $ oneOf "+-"
    str <- many1 digit
    let str' = if sign == '-' then sign:str else str
    return . IntLiteral . read $ str'

floatLiteral :: Parser Expression
floatLiteral = do
    str <- (try dpd <|> try pd)
    return . FloatLiteral . read $ str
    where
        dpd = do
            sign <- option '+' $ oneOf "+-"
            intpart <- many1 digit
            char '.'
            fracpart <- many digit
            let str = intpart ++ "." ++ fracpart
            return $ if sign == '-' then sign:str else str
        pd = do
            sign <- option '+' $ oneOf "+-"
            char '.'
            fracpart <- many1 digit
            let str = "0." ++ fracpart
            return $ if sign == '-' then sign:str else str

stringLiteral :: Parser Expression
stringLiteral = do
    str <- anyQuotedString
    return . StringLiteral $ str

varRefExpr :: Parser Expression
varRefExpr = do
    id <- (string "." <|> identifier)
    return $ VariableReference id

-- Parser state management

addDef :: String -> Statement -> Parser ()
addDef name value =
    modifyState (\s -> s { psDefs = ((name, value):psDefs s) })

resolveDef :: String -> Parser Statement
resolveDef name = do
    defs <- psDefs `liftM` getState
    let val = lookup name defs
    maybe
        (unexpected $ name ++ " is not defined.")
        return
        val

-- Auxiliary parsers

ss :: a -> Parser a
ss a = skipMany space >> return a

ss_ :: Parser ()
ss_ = ss ()

braces :: Parser a -> Parser a
braces inner = do
    char '{'
    ss_
    v <- inner
    ss_
    char '}'
    return v

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

identifier :: Parser String
identifier = do
    x <- letter <|> char '_'
    xs <- many $ letter <|> digit <|> char '_'
    return $ x:xs

anyQuotedString = singleQuotedString <|> doubleQuotedString

singleQuotedString = quotedString '\''
doubleQuotedString = quotedString '"'

quotedString qc = do
    char qc
    str <- many $ quotedStringChar qc
    char qc
    return str

quotedStringChar qc =
    try escapedChar
    <|> noneOf [qc]

escapedChar = do
    char '\\'
    c2 <- anyChar
    return $ case c2 of
                'n' -> '\n'
                'r' -> '\r'
                'b' -> '\b'
                't' -> '\t'
                otherwise -> c2

discard :: Parser a -> Parser ()
discard p = p >> return ()

manySepBy :: Parser a -> Parser b -> Parser [a]
manySepBy elem sep = do
    h <- try elem
    t <- many (try $ sep >> elem)
    return $ h:t

assertStartOfInput :: Parser ()
assertStartOfInput = do
    pos <- getPosition
    if sourceLine pos == 1 && sourceColumn pos == 1
        then return ()
        else unexpected "start of input"

assertStartOfLine :: Parser ()
assertStartOfLine = do
    pos <- getPosition
    if sourceColumn pos == 1
        then return ()
        else unexpected "start of line"

fillExtension :: FilePath -> String -> FilePath
fillExtension fp ext =
    let ext0 = takeExtension fp
    in if null ext0
        then replaceExtension fp ext
        else fp