module CppGrammar (translationUnit, runParser) where

import Control.Monad
import Debug.Trace

import CppToken
import CppAst
import CppGrammar.Utils

translationUnit = fmap concat $ many declaration

--- Declarations

type DeclarationParser = CppParser DeclarationMaker

-- p.103, 7. [dcl.dcl]
declaration :: CppParser [Declaration]
declaration = (oneOf $
    [match Semicolon >> return []
    ,functionDefinition
    ,blockDeclaration]
    ) >>= addDecls

-- p.145, 8.4:1 [dcl.fct.def]
functionDefinition =
    do declSpecs <- many1 declSpecifier
       -- TODO Why initDeclarator when =0 virtuals can't have bodies?
       decl <- initDeclarator
       body <- functionBody
       return [makeFunction (decl id declSpecs) body]

-- TODO Page/section reference
blockDeclaration = simpleDeclaration {- TODO ... -}

ap2 :: (Functor f) => a -> b -> f (a -> b -> c) -> f c
ap2 x y = fmap (\f -> f x y)

-- TODO Page/section reference
simpleDeclaration =
    do declSpecs <- many1 declSpecifier
       --declarations' <- sepBy (initDeclarator) (match Comma)
       --let declarations = map (\f -> f id declSpecs) declarations'
       --let declarations = (sequence declarations') id declSpecs
       
       -- from m1 (m2 DeclarationMaker)
       -- where m1 = CppParser, m2 = []
       -- into m1 (m2 Declaration)
       -- by applying id and declSpecs to each DeclarationMaker
       
       declarations <- fmap (ap2 id declSpecs) (sepBy initDeclarator $ match Comma)
       addExternals $ if hasExternal declSpecs then declarations
                                               else []
       match Semicolon
       return declarations

hasExternal tokens = elem (Reserved "extern") (map snd tokens)

-- p.104, 7.1:1 [dcl.spec]
declSpecifier = oneOf
    [storageClassSpecifier
    --TODO ,functionSpecifier
    ,reserved "friend"
    ,reserved "typedef"
    ,typeSpecifier]

-- p.105, 7.1.1:1 [dcl.stc]
storageClassSpecifier =
    oneOf $ map reserved $
        ["auto"
        ,"register"
        ,"static"
        ,"extern"
        ,"mutable"]

-- p.109, 7.1.5:1 [dcl.type]
{-
    TODO: A given declaration can only have a single typeSpecifier, except that
    - const or volatile can be combinated with other typeSpecifiers, but
      redundant cvQualifiers are only accepted when introduced by templates
      and/or typedefs
    - signed/unsigned and char/long/short/int
    - short/long and int
    - long and double

    TODO: At least one typeSpecifier is required per declaration
-}
typeSpecifier = oneOf $
    [simpleTypeSpecifier
    {- TODO ,classSpecifier
    ,enumSpecifier
    ,elaboratedTypeSpecifier-}
    ,cvQualifier]

-- p.110, 7.1.5.2:1 [dcl.type.simple]
simpleTypeSpecifier =
    oneOf $ map reserved $
        ["int"
        ,"void"
        ,"char"
        {- TODO And loads more -}]

-- p.131, 8:1 [dcl.decl]
initDeclarator =
    do decl <- declarator
       return decl
       --return (InitDeclarator decl NullExpr)

-- p.132, 8.1:1 [dcl.decl]
abstractDeclarator =
	genericDeclarator abstractDeclarator directAbstractDeclarator

abstractDeclaratorOpt :: DeclarationParser
abstractDeclaratorOpt =
	option
		(makeDeclarationMaker AbstractDeclarator)
		abstractDeclarator

-- p.131, 8:4 [dcl.decl]
declarator :: DeclarationParser
declarator =
	genericDeclarator declarator directDeclarator

-- p.132, 8.1:1 [dcl.name]
-- The difference between abstract and concrete direct declarators is
-- that the abstract doesn't take a declaratorId
directAbstractDeclarator :: DeclarationParser
directAbstractDeclarator =
    genDirDecl abstractDeclarator
        (return $ makeDeclarationMaker AbstractDeclarator)

-- p.131, 8:4 [dcl.decl]
directDeclarator =
	genDirDecl declarator declaratorId


genericDeclarator :: DeclarationParser -> DeclarationParser -> DeclarationParser
genericDeclarator decl directDecl = oneOf $
	[do	ptrOp <- ptrOperator
		d <- decl
		return (d . (ptrOp .))
	,directDecl]

{-
	Split the directDecl into a non-left-recursive version with an array and
	function parameter list tail, and break out the common parts between the
	abstract and non-abstract declarators.

    directDecl -> declId | directDecl (...) ... | directDecl [...] | (decl)

    directDecl -> declId | (decl) | declId dirDeclTail | (decl) dirDeclTail
    directDeclTail -> (parameterDeclarationClause) | [constantExpression]

-}
genDirDecl :: DeclarationParser -> DeclarationParser -> DeclarationParser
genDirDecl declRule declIdRule =
    do decl <- oneOf [parens (declRule), declIdRule]
       tailFun <- option id $ oneOf [functionDeclTail,arrayDeclTail]
       return (\f -> decl (tailFun . f))
    where functionDeclTail =
              do params <- parens parameterDeclarationClause
                 -- TODO exceptionSpecification
                 -- TODO cvQuals are only allowed on member functions!
                 --return $ cvQuals .
                 return $ (flip FunctionType) params
          arrayDeclTail =
              do size <- squares (option NullExpr constantExpression)
                 return $ ArrayOf size


-- p.132, 8:4 [dcl.decl]
ptrOperator :: CppParser (DeclType -> DeclType)
ptrOperator = oneOf
    [do match Asterix
        cvQuals <- many cvQualifier
        return (cvQualifyList cvQuals . PointerTo)
    {-,do match Ampersand
    	RefDeclarator
    ,do nns <- colonNestedNameSpecifierOpt
        match Asterix
        cvQualifierSeq >>= return . (MemberPtrDeclarator nns) -}]

-- p.132, 8.1:4 [dcl.decl]
cvQualifier = oneOf $ map reserved $ ["const", "volatile"]

-- p.132, 8.1:4 [dcl.decl]
declaratorId :: DeclarationParser
declaratorId = do
    ident <- oneOf $
        [identifier >>= return . DeclaratorId
    	{-,colonNestedNameSpecifier >> typeName-}]
    return (makeDeclarationMaker ident)

-- p.139, 8.3.5:1 [dcl.fct]
parameterDeclarationClause =
    parameterDeclarationList

-- p.139, 8.3.5:1 [dcl.fct]
parameterDeclarationList =
    sepBy parameterDeclaration (match Comma)

-- p.139, 8.3.5:1 [dcl.fct]
parameterDeclaration =
    do declSpecs <- many1 declSpecifier
       decl <- oneOf
          [initDeclarator
          ,abstractDeclaratorOpt]
       {-decl <- option decl $ do match Assignment
                                expr <- assignmentExpression
                                return (InitDeclarator decl expr)-}
       return (decl id declSpecs)

-- p.145, 8.4:1 [dcl.fct.def]
functionBody =
    compoundStatement


--- Statements

type StmtParser = CppParser Statement

statement :: StmtParser
statement =
    oneOf [jumpStatement,compoundStatement]

compoundStatement :: StmtParser
compoundStatement =
    {-withNewScope $-}
        braces (many statement) >>= return . CompoundStatement

jumpStatement = oneOf
	[returnStatement]
       -- TODO .. and more jump statements

returnStatement = do
    reserved "return"
    -- fmap ReturnStatement (expressionOpt `over` match Semicolon)
    exp <- expressionOpt
    match Semicolon
    return (ReturnStatement exp)


--- Expressions

expressionOpt :: CppParser Expression
expressionOpt = option NullExpr expression

expression :: CppParser Expression
expression = oneOf
	[stringConstant
	,integerConstant]
	
constantExpression = oneOf
	[stringConstant
	,integerConstant]

stringConstant = fmap (ConstantExpr . StringConstant) stringToken
integerConstant = fmap (ConstantExpr . IntegerConstant) integerToken