module PascalParser where

import Text.Parsec

import Text.Parsec.Char

import Text.Parsec.Token

import Text.Parsec.Language

import Text.Parsec.Expr

import Text.Parsec.Prim

import Text.Parsec.Combinator

import Text.Parsec.String

import Control.Monad

import Data.Maybe

import PascalBasics

data PascalUnit =

    Program Identifier Implementation Phrase

    | Unit Identifier Interface Implementation (Maybe Initialize) (Maybe Finalize)

    deriving Show

data Interface = Interface Uses TypesAndVars

    deriving Show

data Implementation = Implementation Uses TypesAndVars

    deriving Show

data Identifier = Identifier String

    deriving Show

data TypesAndVars = TypesAndVars [TypeVarDeclaration]

    deriving Show

data TypeVarDeclaration = TypeDeclaration Identifier TypeDecl

    | VarDeclaration Bool ([Identifier], TypeDecl) (Maybe InitExpression)

    | FunctionDeclaration Identifier TypeDecl [TypeVarDeclaration] (Maybe (TypesAndVars, Phrase))

    | OperatorDeclaration String Identifier TypeDecl [TypeVarDeclaration] (Maybe (TypesAndVars, Phrase))

    deriving Show

data TypeDecl = SimpleType Identifier

    | RangeType Range

    | Sequence [Identifier]

    | ArrayDecl (Maybe Range) TypeDecl

    | RecordType [TypeVarDeclaration] (Maybe [[TypeVarDeclaration]])

    | PointerTo TypeDecl

    | String Integer

    | Set TypeDecl

    | FunctionType TypeDecl [TypeVarDeclaration]

    | UnknownType

    deriving Show

data Range = Range Identifier

           | RangeFromTo InitExpression InitExpression

    deriving Show

data Initialize = Initialize String

    deriving Show

data Finalize = Finalize String

    deriving Show

data Uses = Uses [Identifier]

    deriving Show

data Phrase = ProcCall Reference [Expression]

        | IfThenElse Expression Phrase (Maybe Phrase)

        | WhileCycle Expression Phrase

        | RepeatCycle Expression [Phrase]

        | ForCycle Identifier Expression Expression Phrase

        | WithBlock Reference Phrase

        | Phrases [Phrase]

        | SwitchCase Expression [([InitExpression], Phrase)] (Maybe Phrase)

        | Assignment Reference Expression

        | NOP

    deriving Show

data Expression = Expression String

    | BuiltInFunCall [Expression] Reference

    | PrefixOp String Expression

    | PostfixOp String Expression

    | BinOp String Expression Expression

    | StringLiteral String

    | CharCode String

    | HexCharCode String

    | NumberLiteral String

    | FloatLiteral String

    | HexNumber String

    | Reference Reference

    | SetExpression [Identifier]

    | Null

    deriving Show

data Reference = ArrayElement [Expression] Reference

    | FunCall [Expression] Reference

    | TypeCast Identifier Reference

    | SimpleReference Identifier

    | Dereference Reference

    | RecordField Reference Reference

    | Address Reference

    deriving Show

data InitExpression = InitBinOp String InitExpression InitExpression

    | InitPrefixOp String InitExpression

    | InitReference Identifier

    | InitArray [InitExpression]

    | InitRecord [(Identifier, InitExpression)]

    | InitFloat String

    | InitNumber String

    | InitHexNumber String

    | InitString String

    | InitChar String

    | BuiltInFunction String [InitExpression]

    | InitSet [Identifier]

    | InitNull

    deriving Show

knownTypes = ["shortstring"]

pascalUnit = do

    comments

    u <- choice [program, unit]

    comments

    return u

iD = do

    i <- liftM Identifier (identifier pas)

    comments

    return i

unit = do

    string "unit" >> comments

    name <- iD

    semi pas

    comments

    int <- interface

    impl <- implementation

    comments

    return $ Unit name int impl Nothing Nothing

reference = buildExpressionParser table term <?> "reference"

    where

    term = comments >> choice [

        parens pas (reference >>= postfixes) >>= postfixes

        , typeCast >>= postfixes

        , char '@' >> liftM Address reference >>= postfixes

        , liftM SimpleReference iD >>= postfixes 

        ] <?> "simple reference"

    table = [ 

            [Infix (try (char '.' >> notFollowedBy (char '.')) >> return RecordField) AssocLeft]

        ]

    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

        ]

    typeCast = do

        t <- choice $ map (\s -> try $ caseInsensitiveString s >>= \i -> notFollowedBy alphaNum >> return i) knownTypes

        r <- parens pas reference

        comments

        return $ TypeCast (Identifier t) r

varsDecl1 = varsParser sepEndBy1    

varsDecl = varsParser sepEndBy

varsParser m endsWithSemi = do

    vs <- m (aVarDecl endsWithSemi) (semi pas)

    return vs

aVarDecl endsWithSemi = do

    unless endsWithSemi $

        optional $ choice [

            try $ string "var"

            , try $ string "const"

            , try $ string "out"

            ]

    comments

    ids <- do

        i <- (commaSep1 pas) $ (try iD <?> "variable declaration")

        char ':'

        return i

    comments

    t <- typeDecl <?> "variable type declaration"

    comments

    init <- option Nothing $ do

        char '='

        comments

        e <- initExpression

        comments

        return (Just e)

    return $ VarDeclaration False (ids, t) init

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 ([i], fromMaybe UnknownType t) (Just e)

typeDecl = choice [

    char '^' >> typeDecl >>= return . PointerTo

    , try (string "shortstring") >> return (String 255)

    , try (string "string") >> optionMaybe (brackets pas $ integer pas) >>= return . String . fromMaybe 255

    , arrayDecl

    , recordDecl

    , setDecl

    , functionType

    , sequenceDecl >>= return . Sequence

    , try (identifier pas) >>= return . SimpleType . Identifier

    , 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

            iD

            comments

            string "of"

            comments

            many unionCase

        string "end"

        return $ RecordType vs union

    setDecl = do

        try $ string "set" >> space

        comments

        string "of"

        comments

        liftM Set typeDecl

    unionCase = do

        try $ commaSep pas $ (iD >> return ()) <|> (integer pas >> return ())

        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 UnknownType

        optional $ try $ char ';' >> comments >> string "cdecl"

        comments

        return $ FunctionType ret vs

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

        semi pas

        comments

        return $ TypeDeclaration i t

rangeDecl = choice [

    try $ rangeft

    , iD >>= return . Range

    ] <?> "range declaration"

    where

    rangeft = do

    e1 <- initExpression

    string ".."

    e2 <- initExpression

    return $ RangeFromTo e1 e2

typeVarDeclaration isImpl = (liftM concat . many . choice) [

    varSection,

    constSection,

    typeSection,

    funcDecl,

    operatorDecl

    ]

    where

    varSection = do

        try $ string "var"

        comments

        v <- varsDecl1 True <?> "variable declaration"

        comments

        return v

    constSection = do

        try $ string "const"

        comments

        c <- constsDecl <?> "const declaration"

        comments

        return 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

        char ';'

        comments

        forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments)

        many functionDecorator

        b <- if isImpl && (not forward) then

                liftM Just functionBody

                else

                return Nothing

        return $ [OperatorDeclaration i rid 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 UnknownType

        char ';'

        comments

        forward <- liftM isJust $ optionMaybe (try (string "forward;") >> comments)

        many functionDecorator

        b <- if isImpl && (not forward) then

                liftM Just functionBody

                else

                return Nothing

        return $ [FunctionDeclaration i ret vs b]

    functionDecorator = choice [

        try $ string "inline;"

        , try $ string "cdecl;"

        , try $ string "overload;"

        , try (string "external") >> comments >> iD >> optional (string "name" >> comments >> stringLiteral pas)>> string ";"

        ] >> comments

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 = do

    string "interface"

    comments

    u <- uses

    comments

    tv <- typeVarDeclaration False

    comments

    return $ Interface u (TypesAndVars tv)

implementation = do

    string "implementation"

    comments

    u <- uses

    comments

    tv <- typeVarDeclaration True

    string "end."

    comments

    return $ Implementation u (TypesAndVars tv)

expression = buildExpressionParser table term <?> "expression"

    where

    term = comments >> choice [

        builtInFunction expression >>= \(n, e) -> return $ BuiltInFunCall e (SimpleReference (Identifier n))

        , parens pas $ expression 

        , brackets pas (commaSep pas iD) >>= return . SetExpression

        , try $ natural pas >>= \i -> notFollowedBy (char '.') >> (return . NumberLiteral . show) i

        , stringLiteral pas >>= return . StringLiteral

        , 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 "-"

        , try $ string "nil" >> return Null

        , reference >>= return . Reference

        ] <?> "simple expression"

    table = [ 

          [  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 (char '+' >> return (BinOp "+")) AssocLeft

           , Infix (char '-' >> return (BinOp "-")) AssocLeft

          ]

        , [Prefix (try (string "not") >> return (PrefixOp "not"))]

        , [  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 (char '=' >> return (BinOp "=")) AssocNone

          ]

        , [  Infix (try $ string "and" >> return (BinOp "and")) AssocLeft

           , Infix (try $ string "or" >> return (BinOp "or")) AssocLeft

           , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft

          ]

        , [  Infix (try $ string "shl" >> return (BinOp "shl")) AssocNone

           , Infix (try $ string "shr" >> return (BinOp "shr")) AssocNone

          ]

        ]

phrasesBlock = do

    try $ string "begin"

    comments

    p <- manyTill phrase (try $ string "end" >> notFollowedBy alphaNum)

    comments

    return $ Phrases p

phrase = do