{-# OPTIONS -fno-warn-missing-signatures #-}

--
-- (c) 2012 Wei Ke
--      license:          GPL-3
--      license-file:     LICENSE
--
-- |
-- The "RgParser" module defines the /rCOSg/ grammar and parser,
-- and the functions to invoke the parser.
--
module RgParser ( parsePrg'String
                , parsePrg'File
                , parseCmd'String
                )

where

import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language( javaStyle )

import ErrMsg
import RgAS

parsePrg'String :: String -> ErrMsg Program'
parsePrg'String input =
        case parse program' "" input of
            Left err    -> Err (show err)
            Right prg'  -> OK prg'

parsePrg'File :: FilePath -> IO (ErrMsg Program')
parsePrg'File file =
        do  r <- parseFromFile program' file
            case r of
                Left err    -> return (Err (show err))
                Right prg'  -> return (OK prg')
                                 
parseCmd'String :: String -> ErrMsg Cmd
parseCmd'String input =
        case parse (whiteSpace >> cmdList) "" input of
            Left err -> Err (show err)
            Right c' -> OK c'

{-  grammar

    rCOS/g grammar
    
    program'        ::= {top-level} main-meth {top-level}
    top-level       ::= f-decl | c-decl
    main-meth       ::= `main' `{' [typing-list `;'] {cmd} `}'
    f-decl          ::= `fun' `(' [type-expr-list] `)' `->' type-expr
    c-decl          ::= `class' [x-spec-list] [ext-d] `{' {attr-def | meth-def} `}'
    cmd-block       ::= `{' {cmd} `}'
    type-expr-list  ::= type-expr {`,' type-expr}
    type-expr       ::= `Int' | `Bool' | `Txt' 
                      | `&' IDENT | `&' `(' ident-list `)'
                      | IDENT [sst]
    x-spec-list     ::= `<' x-spec {`,' x-spec} `>'
    ext-d           ::= `ext.' type-expr
    attr-def        ::= [visib] typing `;'
    meth-def        ::= IDENT `(' [typing-list] `)' cmd-block
    cmd             ::= prim-cmd `;'
                      | `if' `(' expr `)' cmd `else' cmd
                      | `while' `(' expr `)' cmd
                      | cmd-block
    ident-list      ::= IDENT {`,' IDENT}
    sst             ::= `<' ssti {`,' ssti} `>'
    x-spec          ::= IDENT [`ext.' type-expr] [`impl.' type-expr]
    visib           ::= `pub.' | `prot.' | `priv.'
    typing          ::= type-expr IDENT
    typing-list     ::= typing {`,' typing}
    prim-cmd        ::= `skip'
                      | `print' [expr-list] [`,']
                      | `var' typing-list 
                      | `end' ident-list 
                      | type-expr `.' `new' `(' expr `)'
                      | expr `:=' expr 
                      | expr `.' IDENT `(' expr-list `:' ident-cast-list `:' expr-list `)'
    expr            ::= atom-expr {`.' IDENT}
                      | type-cast expr
    ssti            ::= IDENT `:-' type-expr
    expr-list       ::= expr {`,' expr}
    atom-expr       ::= `self' | `null' | `_'
                      | INT-LIT | BOOL-LIT | STRING-LIT
                      | IDENT `(' [expr-list] `)'
    ident-cast-list ::= ident-cast {`,' ident-cast}
    type-cast       ::= `(' type-expr `)'
    ident-cast      ::= IDENT [type-cast]
    
-}

data TopLevel = TLF Fun 
              | TLC Cdecl
              
data Member = MA Adef
            | MM Mdef

program' = 
    do
        whiteSpace
        tls1 <- many topLevel
        mm <- mainm
        tls2 <- many topLevel
        eof
        let tls = tls1 ++ tls2
        return (Program' [f | TLF f <- tls] [c | TLC c <- tls] mm) 
    
topLevel =  
        fdecl
    <|> cdecl
       
fdecl = do
            reserved "fun"
            idn <- identifier
            tes <- parens (commaSep typeExpr)
            _ <- symbol "->"
            te <- typeExpr
            _ <- semi
            return (TLF (Fun idn tes te))

cdecl = do
            reserved "class"
            cl <- className
            xspecs <- xspecList cl
            ext <- extd
            mems <- braces (many member)
            return (TLC (Cdecl cl xspecs ext [adef | MA adef <- mems] [mdef | MM mdef <- mems]))
            
className = identifier >>= \idn -> return (U_ idn) 
            
xspecList cl = option [] (angles (commaSep1 (xspec cl)))
    
extd =  option Nothing (do 
            reserved "ext."
            te <- typeExpr
            return (Just te))
    
member = 
        do
            (vis, tp) <- try (do 
                    v <- visibility 
                    t <- typing
                    return (v, t))
            _ <- semi
            return (MA (Adef vis tp))
    <|> do
            idn <- identifier
            tps <- parens typingList
            k <- braces cmdList
            return (MM (Mdef (A_ idn) tps k))
            
xspec cl =
        do
            idn <- identifier
            scnstr <- option Nothing (do
                    reserved "ext."
                    te <- typeExpr
                    return (Just te))
            mcnstr <- option Nothing (do
                    reserved "impl."
                    te <- typeExpr
                    return (Just te))
            return (XSpec (X_ cl idn) scnstr mcnstr)

visibility =
        (reserved "pub." >> return Pub)
    <|> (reserved "priv." >> return Priv)
    <|> (reserved "prot." >> return Prot)
    <|> return Pub

mainm = do
            reserved "main"
            braces (do
                tps <- option [] (do
                    tps <- try typingList1
                    _ <- semi
                    return tps)
                k <- cmdList
                return (Mainm tps k))

typingList1 = commaSep1 typing

typingList = commaSep typing

typing = 
        do
            te <- typeExpr
            idn <- identifier
            return (Typing te (A_ idn))
    
typeExpr =  
        (reserved "Int" >> return (TP INT))
    <|> (reserved "Bool" >> return (TP BOOL))
    <|> (reserved "Txt" >> return (TP TXT))
    <|> do
            (_, tes) <- tryNextParens (symbol "&") (commaSep1 typeExpr)
            return (TCn tes)
    <|> do 
            _ <- symbol "&"
            te <- typeExpr
            return (TCn [te])
    <|> do
            (cl, sst) <- tryNextAngles className (\cl' -> commaSep1 (sstItem cl'))
            return (TCj cl sst)
    <|> do
            cl <- className
            return (TC cl)

sstItem cl = 
        do
            idn <- identifier
            _ <- symbol ":-"
            te <- typeExpr
            return (TX (X_ cl idn) :- te)

primCmd =   
        (reserved "skip" >> return Skip)
    <|> do
            reserved "print"
            eps <- commaSepEnd expr
            c <- option "" comma
            return (Print (c == "") eps)
    <|> do
            reserved "var"
            tps <- typingList1
            return (Decl tps)
    <|> do
            reserved "end"
            idns <- commaSep1 identifier
            return (End [A_ idn | idn <- idns])
    <|> do
            te <- tryNextSymbol typeExpr (dot >> reserved "new")
            ep <- parens expr
            return (New te ep)
    <|> do
            ep1 <- tryNextSymbol expr (symbol ":=")
            ep2 <- expr
            return (Assign ep1 ep2)
    <|> do
            ep <- expr
            _ <- dot
            idn <- identifier
            (eps1, idns, cas, eps2) <- parens argList
            return (Invk ep (A_ idn) eps1 [A_ idn' | idn' <- idns] cas eps2)
            
cmd =   braces cmdList
    <|> do
            reserved "if"
            ep <- parens expr
            k1 <- cmd
            reserved "else"
            k2 <- cmd
            return (If ep k1 k2)
    <|> do
            reserved "while"
            ep <- parens expr
            k <- cmd
            return (While ep k)
    <|> do
            k <- primCmd
            _ <- semi
            return k
            
cmdList = 
        do
            ks <- many cmd
            return (seqCmd ks)
            
argList =
        do 
            eps1 <- commaSep1 expr
            _ <- colon
            idncas <- commaSep1 parCast
            let (idns, cas) = unzip idncas
            _ <- colon
            eps2 <- commaSep1 expr
            return (eps1, idns, cas, eps2)
    <|> return ([], [], [], [])
    
parCast = 
        do
            idn <- identifier
            cast <- option Nothing (parens typeExpr >>= \te -> return (Just te))
            return (idn, cast) 
           
expr =  try (do
            ep <- atomExpr
            _ <- dot
            idns <- dotSepIds1
            return (seqAttr ep [A_ idn | idn <- idns]))
    <|> try (do
            te <- parens typeExpr
            ep <- expr
            return (Cast te ep))
    <|> atomExpr
            
atomExpr =
        (reserved "self" >> return Self)
    <|> (reserved "null" >> return (Lit VNull))
    <|> (reserved "_" >> return Wild)
    <|> (reserved "false" >> return (Lit (VBool False)))
    <|> (reserved "true" >> return (Lit (VBool True)))
    <|> do
            i <- integer
            return (Lit (VInt i))
    <|> do
            s <- stringLiteral
            return (Lit (VTxt s))
    <|> do
            (idn, eps) <- tryNextParens identifier (commaSep expr)
            return (App (Fun idn [] (TP WILD)) eps)
    <|> do
            idn <- identifier
            return (Var (A_ idn))
    <|> parens expr 

dotSepIds1 = 
        do
            idn <- identifier
            notFollowedBy (symbol "(")           
            idns <- try (do
                    _ <- dot
                    dotSepIds1)
                <|> return []
            return (idn:idns)    
    
           
seqCmd []     = Skip
seqCmd [k]    = k
seqCmd (k:ks) = k `Seq` seqCmd ks
       
seqAttr ep las = foldl (\ep' la -> Attr ep' la) ep las

tryNextSymbol p sym = try (do
            r <- p
            _ <- sym
            return r) 
        
tryNextBetweenQuali p1 open p2 close = do
            r1 <- tryNextSymbol p1 open 
            r2 <- p2 r1
            _ <- close
            return (r1, r2)

tryNextBetween p1 open p2 close = tryNextBetweenQuali p1 open (\_ -> p2) close
        
tryNextParens p1 p2 = tryNextBetween p1 (symbol "(") p2 (symbol ")")    
tryNextAngles p1 p2 = tryNextBetweenQuali p1 (symbol "<") p2 (symbol ">")

commaSepEnd p =
        do
            r <- try p
            rs <- tail0
            return (r:rs)
    <|> return []
    
    where
    
    tail0 = do
                r <- try (comma >> p)
                rs <- tail0
                return (r:rs)
        <|> return []
           
-----------------------------------------------------------
-- The lexer
-----------------------------------------------------------
lexer     = P.makeTokenParser rgDef

rgDef  = javaStyle
          { P.reservedNames  = [ "Int", "Bool", "Txt"
                               , "true", "false", "null", "_", "self"
                               , "fun", "class", "ext.", "impl.", "main"
                               , "pub.", "priv.", "prot."
                               , "skip", "var", "end", "new"
                               , "if", "else", "while"
                               , "print"
                               ]
          , P.identLetter    = alphaNum <|> oneOf "_'"
          , P.nestedComments = True
          }

parens          = P.parens lexer    
braces          = P.braces lexer    
angles          = P.angles lexer    
commaSep        = P.commaSep lexer    
commaSep1       = P.commaSep1 lexer    
whiteSpace      = P.whiteSpace lexer    
symbol          = P.symbol lexer    
identifier      = P.identifier lexer    
reserved        = P.reserved lexer    
integer         = P.integer lexer    
stringLiteral   = P.stringLiteral lexer
semi            = P.semi lexer
dot             = P.dot lexer
colon           = P.colon lexer
comma           = P.comma lexer

--
-- end of RgParser
--
-- --$Id: RgParser.hs 1182 2012-11-12 10:11:40Z wke@IPM.EDU.MO $