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

        ]