module PascalParser (
    pascalUnit
    )
    where

import Text.Parsec
import Text.Parsec.Token
import Text.Parsec.Expr
import Control.Monad
import Data.Maybe
import Data.Char

import PascalBasics
import PascalUnitSyntaxTree

knownTypes :: [String]
knownTypes = ["shortstring", "ansistring", "char", "byte"]

pascalUnit :: Parsec String u PascalUnit
pascalUnit = do
    comments
    u <- choice [program, unit, systemUnit, redoUnit]
    comments
    return u

iD :: Parsec String u Identifier
iD = do
    i <- identifier pas
    comments
    when (i == "not") $ unexpected "'not' used as an identifier"
    return $ Identifier i BTUnknown

unit :: Parsec String u PascalUnit
unit = do
    string' "unit" >> comments
    name <- iD
    void $ semi pas
    comments
    int <- interface
    impl <- implementation
    comments
    return $ Unit name int impl Nothing Nothing


reference :: Parsec String u Reference
reference = buildExpressionParser table term <?> "reference"
    where
    term = comments >> choice [
        parens pas (liftM RefExpression expression >>= postfixes) >>= postfixes
        , try $ typeCast >>= postfixes
        , char' '@' >> liftM Address reference >>= postfixes
        , liftM SimpleReference iD >>= postfixes
        ] <?> "simple reference"

    table = [
        ]

    postfixes r = many postfix >>= return . foldl (flip ($)) r
    postfix = choice [
            parens pas (option [] parameters) >>= return . FunCall
          , char' '^' >> return Dereference
          , (brackets pas) (commaSep1 pas $ expression) >>= return . ArrayElement
          , (char' '.' >> notFollowedBy (char' '.')) >> liftM (flip RecordField) reference
        ]

    typeCast = do
        t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes
        e <- parens pas expression
        comments
        return $ TypeCast (Identifier t BTUnknown) e

varsDecl1, varsDecl :: Bool -> Parsec String u [TypeVarDeclaration]
varsDecl1 = varsParser sepEndBy1
varsDecl = varsParser sepEndBy

varsParser ::
    (Parsec String u TypeVarDeclaration
        -> Parsec String u String
        -> Parsec
            String u [TypeVarDeclaration])
    -> Bool
    -> Parsec
            String u [TypeVarDeclaration]
varsParser m endsWithSemi = do
    vs <- m (aVarDecl endsWithSemi) (semi pas)
    return vs

aVarDecl :: Bool -> Parsec String u TypeVarDeclaration
aVarDecl endsWithSemi = do
    isVar <- liftM (== Just "var") $
        if not endsWithSemi then
            optionMaybe $ choice [
                try $ string "var"
                , try $ string "const"
                , try $ string "out"
                ]
            else
                return Nothing
    comments
    ids <- do
        i <- (commaSep1 pas) $ (try iD <?> "variable declaration")
        char' ':'
        return i
    comments
    t <- typeDecl <?> "variable type declaration"
    comments
    initialization <- option Nothing $ do
        char' '='
        comments
        e <- initExpression
        comments
        return (Just e)
    return $ VarDeclaration isVar False (ids, t) initialization

constsDecl :: Parsec String u [TypeVarDeclaration]
constsDecl = do
    vs <- many1 (try (aConstDecl >>= \i -> semi pas >> return i) >>= \i -> comments >> return i)
    comments
    return vs
    where
    aConstDecl = do
        comments
        i <- iD
        t <- optionMaybe $ do
            char' ':'
            comments
            t <- typeDecl
            comments
            return t
        char' '='
        comments
        e <- initExpression
        comments
        return $ VarDeclaration False (isNothing t) ([i], fromMaybe (DeriveType e) t) (Just e)

typeDecl :: Parsec String u TypeDecl
typeDecl = choice [
    char' '^' >> typeDecl >>= return . PointerTo
    , try (string' "shortstring") >> return String
    , try (string' "string") >> optionMaybe (brackets pas $ integer pas) >> return String
    , try (string' "ansistring") >> optionMaybe (brackets pas $ integer pas) >> return AString
    , arrayDecl
    , recordDecl
    , setDecl
    , functionType
    , sequenceDecl >>= return . Sequence
    , try iD >>= return . SimpleType
    , rangeDecl >>= return . RangeType
    ] <?> "type declaration"
    where
    arrayDecl = do
        try $ do
            optional $ (try $ string' "packed") >> comments
            string' "array"
        comments
        r <- option [] $ do
            char' '['
            r <- commaSep pas rangeDecl
            char' ']'
            comments
            return r
        string' "of"
        comments
        t <- typeDecl
        if null r then
            return $ ArrayDecl Nothing t
            else
            return $ foldr (\a b -> ArrayDecl (Just a) b) (ArrayDecl (Just $ head r) t) (tail r)
    recordDecl = do
        try $ do
            optional $ (try $ string' "packed") >> comments
            string' "record"
        comments
        vs <- varsDecl True
        union <- optionMaybe $ do
            string' "case"
            comments
            void $ iD
            comments
            string' "of"
            comments
            many unionCase
        string' "end"
        return $ RecordType vs union
    setDecl = do
        try $ string' "set" >> void space
        comments
        string' "of"
        comments
        liftM Set typeDecl
    unionCase = do
        void $ try $ commaSep pas $ (void $ iD) <|> (void $ integer pas)
        char' ':'
        comments
        u <- parens pas $ varsDecl True
        char' ';'
        comments
        return u
    sequenceDecl = (parens pas) $ (commaSep pas) (iD >>= \i -> optional (spaces >> char' '=' >> spaces >> integer pas) >> return i)
    functionType = do
        fp <- try (string "function") <|> try (string "procedure")
        comments
        vs <- option [] $ parens pas $ varsDecl False
        comments
        ret <- if (fp == "function") then do
            char' ':'
            comments
            ret <- typeDecl
            comments
            return ret
            else
            return VoidType
        optional $ try $ char' ';' >> comments >> string' "cdecl"
        comments
        return $ FunctionType ret vs

typesDecl :: Parsec String u [TypeVarDeclaration]
typesDecl = many (aTypeDecl >>= \t -> comments >> return t)
    where
    aTypeDecl = do
        i <- try $ do
            i <- iD <?> "type declaration"
            comments
            char' '='
            return i
        comments
        t <- typeDecl
        comments
        void $ semi pas
        comments
        return $ TypeDeclaration i t

rangeDecl :: Parsec String u Range
rangeDecl = choice [
    try $ rangeft
    , iD >>= return . Range
    ] <?> "range declaration"
    where
    rangeft = do
    e1 <- initExpression
    string' ".."
    e2 <- initExpression
    return $ RangeFromTo e1 e2

typeVarDeclaration :: Bool -> Parsec String u [TypeVarDeclaration]
typeVarDeclaration isImpl = (liftM concat . many . choice) [
    varSection,
    constSection,
    typeSection,
    funcDecl,
    operatorDecl
    ]
    where

    fixInit v = concat $ map (\x -> case x of
                    VarDeclaration a b (ids, t) c ->
                        let typeId = (Identifier ((\(Identifier i _) -> i) (head ids) ++ "_tt") BTUnknown) in
                        let res =  [TypeDeclaration typeId t, VarDeclaration a b (ids, (SimpleType typeId)) c] in
                        case t of
                            RecordType _ _ -> res -- create a separated type declaration
                            ArrayDecl _ _ -> res
                            _ -> [x]
                    _ -> error ("checkInit:\n" ++ (show v))) v

    varSection = do
        try $ string' "var"
        comments
        v <- varsDecl1 True <?> "variable declaration"
        comments
        return $ fixInit v

    constSection = do
        try $ string' "const"
        comments
        c <- constsDecl <?> "const declaration"
        comments
        return $ fixInit c

    typeSection = do
        try $ string' "type"
        comments
        t <- typesDecl <?> "type declaration"
        comments
        return t

    operatorDecl = do
        try $ string' "operator"
        comments
        i <- manyTill anyChar space
        comments
        vs <- parens pas $ varsDecl False
        comments
        rid <- iD
        comments
        char' ':'
        comments
        ret <- typeDecl
        comments
        -- return ret
        -- ^^^^^^^^^^ wth was this???
        char' ';'
        comments
        forward <- liftM isJust $ optionMaybe (try (string' "forward;") >> comments)
        inline <- liftM (any (== "inline;")) $ many functionDecorator
        b <- if isImpl && (not forward) then
                liftM Just functionBody
                else
                return Nothing
        return $ [OperatorDeclaration i rid inline ret vs b]


    funcDecl = do
        fp <- try (string "function") <|> try (string "procedure")
        comments
        i <- iD
        vs <- option [] $ parens pas $ varsDecl False
        comments
        ret <- if (fp == "function") then do
            char' ':'
            comments
            ret <- typeDecl
            comments
            return ret
            else
            return VoidType
        char' ';'
        comments
        forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments)
        decorators <- many functionDecorator
        let inline = any (== "inline;") decorators
            overload = any (== "overload;") decorators
            external = any (== "external;") decorators
        -- TODO: don't mangle external functions names (and remove fpcrtl.h defines hacks)
        b <- if isImpl && (not forward) && (not external) then
                liftM Just functionBody
                else
                return Nothing
        return $ [FunctionDeclaration i inline overload external ret vs b]

    functionDecorator = do
        d <- choice [
            try $ string "inline;"
            , try $ caseInsensitiveString "cdecl;"
            , try $ string "overload;"
            , try $ string "export;"
            , try $ string "varargs;"
            , try (string' "external") >> comments >> iD >> comments >>
                optional (string' "name" >> comments >> stringLiteral pas) >> string' ";" >> return "external;"
            ]
        comments
        return d


program :: Parsec String u PascalUnit
program = do
    string' "program"
    comments
    name <- iD
    (char' ';')
    comments
    comments
    u <- uses
    comments
    tv <- typeVarDeclaration True
    comments
    p <- phrase
    comments
    char' '.'
    comments
    return $ Program name (Implementation u (TypesAndVars tv)) p

interface :: Parsec String u Interface
interface = do
    string' "interface"
    comments
    u <- uses
    comments
    tv <- typeVarDeclaration False
    comments
    return $ Interface u (TypesAndVars tv)

implementation :: Parsec String u Implementation
implementation = do
    string' "implementation"
    comments
    u <- uses
    comments
    tv <- typeVarDeclaration True
    string' "end."
    comments
    return $ Implementation u (TypesAndVars tv)

expression :: Parsec String u Expression
expression = do
    buildExpressionParser table term <?> "expression"
    where
    term = comments >> choice [
        builtInFunction expression >>= \(n, e) -> return $ BuiltInFunCall e (SimpleReference (Identifier n BTUnknown))
        , try (parens pas $ expression >>= \e -> notFollowedBy (comments >> char' '.') >> return e)
        , brackets pas (commaSep pas iD) >>= return . SetExpression
        , try $ integer pas >>= \i -> notFollowedBy (char' '.') >> (return . NumberLiteral . show) i
        , float pas >>= return . FloatLiteral . show
        , try $ integer pas >>= return . NumberLiteral . show
        , try (string' "_S" >> stringLiteral pas) >>= return . StringLiteral
        , try (string' "_P" >> stringLiteral pas) >>= return . PCharLiteral
        , stringLiteral pas >>= return . strOrChar
        , try (string' "#$") >> many hexDigit >>= \c -> comments >> return (HexCharCode c)
        , char' '#' >> many digit >>= \c -> comments >> return (CharCode c)
        , char' '$' >> many hexDigit >>=  \h -> comments >> return (HexNumber h)
        --, char' '-' >> expression >>= return . PrefixOp "-"
        , char' '-' >> reference >>= return . PrefixOp "-" . Reference
        , (try $ string' "not" >> notFollowedBy comments) >> unexpected "'not'"
        , try $ string' "nil" >> return Null
        , reference >>= return . Reference
        ] <?> "simple expression"

    table = [
          [  Prefix (reservedOp pas "not">> return (PrefixOp "not"))
           , Prefix (try (char' '-') >> return (PrefixOp "-"))]
           ,
          [  Infix (char' '*' >> return (BinOp "*")) AssocLeft
           , Infix (char' '/' >> return (BinOp "/")) AssocLeft
           , Infix (try (string' "div") >> return (BinOp "div")) AssocLeft
           , Infix (try (string' "mod") >> return (BinOp "mod")) AssocLeft
           , Infix (try (string' "in") >> return (BinOp "in")) AssocNone
           , Infix (try $ string' "and" >> return (BinOp "and")) AssocLeft
           , Infix (try $ string' "shl" >> return (BinOp "shl")) AssocLeft
           , Infix (try $ string' "shr" >> return (BinOp "shr")) AssocLeft
          ]
        , [  Infix (char' '+' >> return (BinOp "+")) AssocLeft
           , Infix (char' '-' >> return (BinOp "-")) AssocLeft
           , Infix (try $ string' "or" >> return (BinOp "or")) AssocLeft
           , Infix (try $ string' "xor" >> return (BinOp "xor")) AssocLeft
          ]
        , [  Infix (try (string' "<>") >> return (BinOp "<>")) AssocNone
           , Infix (try (string' "<=") >> return (BinOp "<=")) AssocNone
           , Infix (try (string' ">=") >> return (BinOp ">=")) AssocNone
           , Infix (char' '<' >> return (BinOp "<")) AssocNone
           , Infix (char' '>' >> return (BinOp ">")) AssocNone
          ]
        {-, [  Infix (try $ string' "shl" >> return (BinOp "shl")) AssocNone
             , Infix (try $ string' "shr" >> return (BinOp "shr")) AssocNone
          ]
        , [
             Infix (try $ string' "or" >> return (BinOp "or")) AssocLeft
           , Infix (try $ string' "xor" >> return (BinOp "xor")) AssocLeft
          ]-}
        , [
             Infix (char' '=' >> return (BinOp "=")) AssocNone
          ]
        ]
    strOrChar [a] = CharCode . show . ord $ a
    strOrChar a = StringLiteral a

phrasesBlock :: Parsec String u Phrase
phrasesBlock = do
    try $ string' "begin"
    comments
    p <- manyTill phrase (try $ string' "end" >> notFollowedBy alphaNum)
    comments
    return $ Phrases p

phrase :: Parsec String u Phrase
phrase = do
    o <- choice [
        phrasesBlock
        , ifBlock
        , whileCycle
        , repeatCycle
        , switchCase
        , withBlock
        , forCycle
        , (try $ reference >>= \r -> string' ":=" >> return r) >>= \r -> comments >> expression >>= return . Assignment r
        , builtInFunction expression >>= \(n, e) -> return $ BuiltInFunctionCall e (SimpleReference (Identifier n BTUnknown))
        , procCall
        , char' ';' >> comments >> return NOP
        ]
    optional $ char' ';'
    comments
    return o

ifBlock :: Parsec String u Phrase
ifBlock = do
    try $ string "if" >> notFollowedBy (alphaNum <|> char '_')
    comments
    e <- expression
    comments
    string' "then"
    comments
    o1 <- phrase
    comments
    o2 <- optionMaybe $ do
        try $ string' "else" >> void space
        comments
        o <- option NOP phrase
        comments
        return o
    return $ IfThenElse e o1 o2

whileCycle :: Parsec String u Phrase
whileCycle = do
    try $ string' "while"
    comments
    e <- expression
    comments
    string' "do"
    comments
    o <- phrase
    return $ WhileCycle e o

withBlock :: Parsec String u Phrase
withBlock = do
    try $ string' "with" >> void space
    comments
    rs <- (commaSep1 pas) reference
    comments
    string' "do"
    comments
    o <- phrase
    return $ foldr WithBlock o rs

repeatCycle :: Parsec String u Phrase
repeatCycle = do
    try $ string' "repeat" >> void space
    comments
    o <- many phrase
    string' "until"
    comments
    e <- expression
    comments
    return $ RepeatCycle e o

forCycle :: Parsec String u Phrase
forCycle = do
    try $ string' "for" >> void space
    comments
    i <- iD
    comments
    string' ":="
    comments
    e1 <- expression
    comments
    up <- liftM (== Just "to") $
            optionMaybe $ choice [
                try $ string "to"
                , try $ string "downto"
                ]
    --choice [string' "to", string' "downto"]
    comments
    e2 <- expression
    comments
    string' "do"
    comments
    p <- phrase
    comments
    return $ ForCycle i e1 e2 p up

switchCase :: Parsec String u Phrase
switchCase = do
    try $ string' "case"
    comments
    e <- expression
    comments
    string' "of"
    comments
    cs <- many1 aCase
    o2 <- optionMaybe $ do
        try $ string' "else" >> notFollowedBy alphaNum
        comments
        o <- many phrase
        comments
        return o
    string' "end"
    comments
    return $ SwitchCase e cs o2
    where
    aCase = do
        e <- (commaSep pas) $ (liftM InitRange rangeDecl <|> initExpression)
        comments
        char' ':'
        comments
        p <- phrase
        comments
        return (e, p)

procCall :: Parsec String u Phrase
procCall = do
    r <- reference
    p <- option [] $ (parens pas) parameters
    return $ ProcCall r p

parameters :: Parsec String u [Expression]
parameters = (commaSep pas) expression <?> "parameters"

functionBody :: Parsec String u (TypesAndVars, Phrase)
functionBody = do
    tv <- typeVarDeclaration True
    comments
    p <- phrasesBlock
    char' ';'
    comments
    return (TypesAndVars tv, p)

uses :: Parsec String u Uses
uses = liftM Uses (option [] u)
    where
        u = do
            string' "uses"
            comments
            ulist <- (iD >>= \i -> comments >> return i) `sepBy1` (char' ',' >> comments)
            char' ';'
            comments
            return ulist

initExpression :: Parsec String u InitExpression
initExpression = buildExpressionParser table term <?> "initialization expression"
    where
    term = comments >> choice [
        liftM (uncurry BuiltInFunction) $ builtInFunction initExpression
        , try $ brackets pas (commaSep pas $ initExpression) >>= return . InitSet
        , try $ parens pas (commaSep pas $ initExpression) >>= \ia -> when ((notRecord $ head ia) && (null $ tail ia)) mzero >> return (InitArray ia)
        , try $ parens pas (sepEndBy recField (char' ';' >> comments)) >>= return . InitRecord
        , parens pas initExpression
        , try $ integer pas >>= \i -> notFollowedBy (char' '.') >> (return . InitNumber . show) i
        , try $ float pas >>= return . InitFloat . show
        , try $ integer pas >>= return . InitNumber . show
        , stringLiteral pas >>= return . InitString
        , char' '#' >> many digit >>= \c -> comments >> return (InitChar c)
        , char' '$' >> many hexDigit >>= \h -> comments >> return (InitHexNumber h)
        , char' '@' >> initExpression >>= \c -> comments >> return (InitAddress c)
        , try $ string' "nil" >> return InitNull
        , try itypeCast
        , iD >>= return . InitReference
        ]

    notRecord (InitRecord _) = False
    notRecord _ = True

    recField = do
        i <- iD
        spaces
        char' ':'
        spaces
        e <- initExpression
        spaces
        return (i ,e)

    table = [
          [
             Prefix (char' '-' >> return (InitPrefixOp "-"))
            ,Prefix (try (string' "not") >> return (InitPrefixOp "not"))
          ]
        , [  Infix (char' '*' >> return (InitBinOp "*")) AssocLeft
           , Infix (char' '/' >> return (InitBinOp "/")) AssocLeft
           , Infix (try (string' "div") >> return (InitBinOp "div")) AssocLeft
           , Infix (try (string' "mod") >> return (InitBinOp "mod")) AssocLeft
           , Infix (try $ string' "and" >> return (InitBinOp "and")) AssocLeft
           , Infix (try $ string' "shl" >> return (InitBinOp "shl")) AssocNone
           , Infix (try $ string' "shr" >> return (InitBinOp "shr")) AssocNone
          ]
        , [  Infix (char' '+' >> return (InitBinOp "+")) AssocLeft
           , Infix (char' '-' >> return (InitBinOp "-")) AssocLeft
           , Infix (try $ string' "or" >> return (InitBinOp "or")) AssocLeft
           , Infix (try $ string' "xor" >> return (InitBinOp "xor")) AssocLeft
          ]
        , [  Infix (try (string' "<>") >> return (InitBinOp "<>")) AssocNone
           , Infix (try (string' "<=") >> return (InitBinOp "<=")) AssocNone
           , Infix (try (string' ">=") >> return (InitBinOp ">=")) AssocNone
           , Infix (char' '<' >> return (InitBinOp "<")) AssocNone
           , Infix (char' '>' >> return (InitBinOp ">")) AssocNone
           , Infix (char' '=' >> return (InitBinOp "=")) AssocNone
          ]
        {--, [  Infix (try $ string' "and" >> return (InitBinOp "and")) AssocLeft
           , Infix (try $ string' "or" >> return (InitBinOp "or")) AssocLeft
           , Infix (try $ string' "xor" >> return (InitBinOp "xor")) AssocLeft
          ]
        , [  Infix (try $ string' "shl" >> return (InitBinOp "shl")) AssocNone
           , Infix (try $ string' "shr" >> return (InitBinOp "shr")) AssocNone
          ]--}
        --, [Prefix (try (string' "not") >> return (InitPrefixOp "not"))]
        ]

    itypeCast = do
        --t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes
        t <- iD
        i <- parens pas initExpression
        comments
        return $ InitTypeCast t i

builtInFunction :: Parsec String u a -> Parsec String u (String, [a])
builtInFunction e = do
    name <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) builtin
    spaces
    exprs <- option [] $ parens pas $ option [] $ commaSep1 pas $ e
    spaces
    return (name, exprs)

systemUnit :: Parsec String u PascalUnit
systemUnit = do
    string' "system;"
    comments
    string' "type"
    comments
    t <- typesDecl
    string' "var"
    v <- varsDecl True
    return $ System (t ++ v)

redoUnit :: Parsec String u PascalUnit
redoUnit = do
    string' "redo;"
    comments
    string' "type"
    comments
    t <- typesDecl
    string' "var"
    v <- varsDecl True
    return $ Redo (t ++ v)