module CParser where

import CLexer
import CPass
import CTree(SyType,syExists,syOpen,syClose,syInit,syInsertTypedef,syInsertSpecial
	    ,syEnableTypeSpecFlag,syDisableTypeSpecFlag
	    ,syEnableTypedefFlag,syDisableTypedefFlag,syCheckTypedefFlag)
import UU_Parsing
import CTypes
import IO
import IOExts
--import FiniteMap


-- We use a context sensitive parser here
-- we must do so in order to support the wierd typedef things
-- of ANSI C in a LL grammar
-- we have a state which has a list(in fact tree)
-- that has the currently parsed typedefs. If an identifier is
-- being parsed and it is in this list then it becomes a typedef token.
-- If a typedef is parsed when a declarator was expected, it becomes
-- a normal identifier. We have another list for that purpose.
-- There is a flag to say wether an identifier must be stored as typedef
-- (pEnable/DisableTypedefFlag)
-- and to avoid parsing problems like this
-- typedef int A;
-- int A; <- do you have two type specifiers or one type specifier and declarator?
-- for this we use pEnable/DisableTypeSpecFlag

data CTypesInp s = CTypesInp SyType [s]
type CParser = AnaParser CTypesInp Id

instance InputState CTypesInp Token where
 splitStateE st@(CTypesInp _  []     ) = Right' st
 splitStateE st@(CTypesInp env (s:ss)) = Left' (chckForTypedef s env) (CTypesInp env ss)
 splitState  st@(CTypesInp env (s:ss)) = (chckForTypedef s env, CTypesInp env ss)
 insertState s  (CTypesInp env    ss ) = CTypesInp env (s:ss)
 firstState     (CTypesInp _      [] ) = Nothing
 firstState     (CTypesInp _   (s:ss)) = Just s

chckForTypedef :: Token -> SyType -> Token
chckForTypedef tok@(Tok(TkIdent, h, s, i, fn)) a = if syExists a s 
						   then (Tok(TkTypedef, h, s, i, fn))
						   else tok
chckForTypedef t a = t

--------------------------------------------------------
-- Basic parsers defined in scanner were brought here
-- because of the CParser type
--------------------------------------------------------
-- additional note
-- parsers and functions ending in Loc gather file positions
-- information in addition to he data gathered by their counterparts

get_tok_val (Tok( _, _, s, _, _)) = s

get_tok_valLoc (Tok(_, _, s, (n1,n2), f)) = (s,(f,n1,n2))

gsym :: TokenType -> String -> String -> CParser Token String
gsym kind val val2 = get_tok_val <$> pSym (Tok(kind,val,val2,(0,0),0))

gsymLoc :: TokenType -> String -> String -> CParser Token (String,Pos)
gsymLoc kind val val2 = get_tok_valLoc <$> pSym (Tok(kind,val,val2,(0,0),0))


pKey  keyword  =   gsym TkKeyword   keyword   keyword
pKeyLoc  keyword  =   gsymLoc TkKeyword   keyword   keyword
pSpec s        =   gsym TkSymbol    [s]       [s]
pSpecLoc s     =   gsymLoc TkSymbol    [s]       [s]

pString        =   gsym TkString    ""        "?STR?"
pStringLoc     =   gsymLoc TkString    ""        "?STR?"
pChar          =   gsym TkChar      ""        "'chr'"
pCharLoc       =   gsymLoc TkChar      ""        "'chr'"
pUInt          =   gsym TkUInt      ""        "UInt"
pUIntLoc       =   gsymLoc TkUInt      ""        "UInt"
pULong         =   gsym TkULong     ""        "ULong"
pULongLoc      =   gsymLoc TkULong     ""        "ULong"
pInt           =   gsym TkInt       ""        "Int"
pIntLoc        =   gsymLoc TkInt       ""        "Int"
pLong          =   gsym TkLong      ""        "ULong"
pLongLoc       =   gsymLoc TkLong      ""        "ULong"
pFloat         =   gsym TkFloat     ""        "Float"
pFloatLoc      =   gsymLoc TkFloat     ""        "Float"
pDouble        =   gsym TkDouble    ""        "Double"
pDoubleLoc     =   gsymLoc TkDouble    ""        "Double"
pLDouble       =   gsym TkLDouble   ""        "LDouble"
pLDoubleLoc    =   gsymLoc TkLDouble   ""        "LDouble"

pIdent         =   gsym TkIdent     ""        "Id"
pIdentLoc         =   gsymLoc TkIdent     ""        "Id"
pTypedef       =   gsym TkTypedef   ""        "Id"
pTypedefLoc       =   gsymLoc TkTypedef   ""        "Id"

pComma  = pSpec ','
pSemi   = pSpec ';'
pOParen = pSpec '('
pCParen = pSpec ')'
pOBrack = pSpec '['
pCBrack = pSpec ']'
pOCurly = pSpec '{'
pCCurly = pSpec '}'

pCommas  = pListSep pComma
pSemics  = pListSep pSemi
pParens  = pPacked pOParen pCParen
pBracks  = pPacked pOBrack pCBrack
pCurly   = pPacked pOCurly pCCurly

pCurlyLoc p = f <$+ pSpecLoc '{' <*> p <* pSpec '}'
    where f l p = (p,l)

pCurlyLocScope p = f <$+ pPushScope (pSpecLoc '{') <*> p <* pPushScope (pSpec '}')
    where f l p = (p,l)

pParens_pCommas = pParens.pCommas
pBracks_pCommas = pBracks.pCommas
pCurly_pSemics  = pCurly .pSemics

-- Now comes the magic parser
-- The one that adds a typedef to the state
pSaver :: (t->String) -> CParser Token t -> CParser Token t
pSaver f p = pWrap
	     (\ instate ~r@(~(Id (ident, result)), steps) k
	      -> (instate, r, \ s@(CTypesInp env input) -> let r' = k (CTypesInp (syInsertTypedef env (f ident)) input) 
		                                           in if syCheckTypedefFlag env then r' else k s)
	     )
	     (error "pIdent") 
	     p

-- This is used to remove currently active typedefs
pRemover :: (t->String) -> CParser Token t -> CParser Token t
pRemover f p = pWrap
	       (\ instate ~r@(~(Id (ident, result)), steps) k
		-> (instate, r, \ (CTypesInp env input) -> let r' = k (CTypesInp (syInsertSpecial env (f ident)) input) in r')
	       ) 
	       (error "pIdent") 
	       p

-- It is a mix of pSaver and pRemover
pSaverRemover :: (t->String) -> CParser Token t -> CParser Token t
pSaverRemover f p = pWrap
		    (\ instate ~r@(~(Id (ident, result)), steps) k
		     -> (instate, r, \ (CTypesInp env input) -> let r' = k (CTypesInp (syInsertSpecial env (f ident)) input)
			                                            r'' = k (CTypesInp (syInsertTypedef env (f ident)) input)
                                                                in if syCheckTypedefFlag env then r'' else r')
	       ) 
	       (error "pIdent") 
	       p

-- State modification to inform wether a typespec has been parsed
pEnableTypeSpecFlag p = pWrap
			(\ instate r k
			 -> (instate, r, \ (CTypesInp env input) -> let r' = k (CTypesInp (syEnableTypeSpecFlag env) input) in r')
			)
			(\ instate r k
			 -> (instate, r, \ (CTypesInp env input) -> let r' = k (CTypesInp (syEnableTypeSpecFlag env) input) in r')
			)
			p

pDisableTypeSpecFlag p = pWrap
			 (\ instate r k
			  -> (instate, r, \ (CTypesInp env input) -> let r' = k (CTypesInp (syDisableTypeSpecFlag env) input) in r')
			 )
			 (\ instate r k
			  -> (instate, r, \ (CTypesInp env input) -> let r' = k (CTypesInp (syDisableTypeSpecFlag env) input) in r')
			 )
			 p

pEnableTypedefFlag p = pWrap
		       (\ instate r k
			-> (instate, r, \ (CTypesInp env input) -> let r' = k (CTypesInp (syEnableTypedefFlag env) input) in r')
		       )
		       (\ instate r k
			-> (instate, r, \ (CTypesInp env input) -> let r' = k (CTypesInp (syEnableTypedefFlag env) input) in r')
		       )
                       p

pDisableTypedefFlag p = pWrap
			(\ instate r k
			 -> (instate, r, \ (CTypesInp env input) -> let r' = k (CTypesInp (syDisableTypedefFlag env) input) in r')
			)
			(\ instate r k
			 -> (instate, r, \ (CTypesInp env input) -> let r' = k (CTypesInp (syDisableTypedefFlag env) input) in r')
			)
			p


pPushScope p = pMap 
	       (\ (CTypesInp env input) r 
		-> ((CTypesInp (syOpen env) input), r)
	       ) 
	       (\ (CTypesInp env input) r 
		-> ((CTypesInp (syOpen env) input), r)
	       ) p

pPushScopeAfter p = pWrap
		    (\ instate r k
		     -> (instate, r, \ (CTypesInp env input) -> k (CTypesInp (syOpen env) input))
		    )
		    (\ instate r k
		     -> (instate, r, \ (CTypesInp env input) -> k (CTypesInp (syOpen env) input))
		    )
                    p

pPopScope p = pMap
	      (\ (CTypesInp env input) r 
	       -> ((CTypesInp (syClose env) input), r)
	      ) 
	      (\ (CTypesInp env input) r 
	       -> ((CTypesInp (syClose env) input), r)
	      ) p

pOpenScopeCurly = pPushScope pOCurly

pCloseScopeCurly = pPopScope pCCurly


--------------------------------------------------------


pLiteral :: CParser Token Literal
pLiteral = f <$> pStringLoc <*> pFoldr ((++),"") pString
	   <|> Literal_Char <$+> pCharLoc
	   <|> Literal_UInt <$+> pUIntLoc
	   <|> Literal_ULong <$+> pULongLoc
	   <|> Literal_Int <$+> pIntLoc
	   <|> Literal_Long <$+> pLongLoc
	   <|> Literal_Float <$+> pFloatLoc
	   <|> Literal_Double <$+> pDoubleLoc
	   <|> Literal_LDouble <$+> pLDoubleLoc
	       where f (s1,l) s2 = Literal_String (s1++s2) l

pFoldl1 alg@(op,e) p = foldl op e <$> pList1 p

pFoldl1Sep alg@(op,e) sep p = foldl op e <$> ((:) <$> p <*> pList (sep *> p))

pFoldl alg@(op,e) p = foldl op e <$> pList p

pFoldlSep alg@(op,e) sep p = foldl op e <$> (((:) <$> p <*> pList (sep *> p)) `opt` [])

-- special combinators for file position information
f <$+> p = uncurry f <$> p

f <$+ p = g <$> p
        where g (_,l) = f l

p <*+> q = uncurry <$> p <*> q

p +**> q = f <$> p <*> q
	   where f p g = g (snd p)
---------------------------------------------------

pExprs ::CParser Token Exprs
pExprs = foldr (:) [] <$> pListSep (pSpec ',') pExprN

pExpr ::CParser Token Expr
pExpr = pChainl (Expr_Binary BinOp_Comma <$+ pSpecLoc ',') pExprN

pExprN ::CParser Token Expr
pExprN = pChainr pUnOpAssign pTernaryExpr

pUnOpAssign ::CParser Token (Expr -> Expr -> Expr)
pUnOpAssign = Expr_Binary BinOp_Assign <$+ pKeyLoc "="
	      <|> Expr_Binary BinOp_AssignAdd <$+ pKeyLoc "+="
	      <|> Expr_Binary BinOp_AssignSub <$+ pKeyLoc "-="
	      <|> Expr_Binary BinOp_AssignMul <$+ pKeyLoc "*="
	      <|> Expr_Binary BinOp_AssignDiv <$+ pKeyLoc "/="
	      <|> Expr_Binary BinOp_AssignMod <$+ pKeyLoc "%="
	      <|> Expr_Binary BinOp_AssignShl <$+ pKeyLoc "<<="
	      <|> Expr_Binary BinOp_AssignShr <$+ pKeyLoc ">>="
	      <|> Expr_Binary BinOp_AssignAnd <$+ pKeyLoc "&="
	      <|> Expr_Binary BinOp_AssignXor <$+ pKeyLoc "^="
	      <|> Expr_Binary BinOp_AssignOr  <$+ pKeyLoc "|="

-- get rid of the variable l in f to get a very subtle bug
-- spent 40 minutes thinking it was an error caused by the grammar
pTernaryExpr ::CParser Token Expr
pTernaryExpr = pBinExpr <??> (f <$+ pKeyLoc "?" <*> pExpr <* pSpec ':' <*> pTernaryExpr)
	       where f l e2 e3 e1 = Expr_Cond e1 l e2 e3

pGExprl ops p = foldr ($) p ops2
		where ops2 = map (\x y->pChainl (foldr1 (<|>) x) y) ops

-- reverse priority order
bins = [ [Expr_Binary BinOp_LogOr <$+ pKeyLoc "||"],
	 [Expr_Binary BinOp_LogAnd <$+ pKeyLoc "&&"],
	 [Expr_Binary BinOp_BinOr <$+ pKeyLoc "|"],
	 [Expr_Binary BinOp_BinXor <$+ pKeyLoc "^"],
	 [Expr_Binary BinOp_BinAnd <$+ pKeyLoc "&"],
	 [Expr_Binary BinOp_Eq <$+ pKeyLoc "==",
	  Expr_Binary BinOp_Ne <$+ pKeyLoc "!="],
	 [Expr_Binary BinOp_Lt <$+ pKeyLoc "<",
	  Expr_Binary BinOp_Gt <$+ pKeyLoc ">",
	  Expr_Binary BinOp_Le <$+ pKeyLoc "<=",
	  Expr_Binary BinOp_Ge <$+ pKeyLoc ">="],
	 [Expr_Binary BinOp_Shl <$+ pKeyLoc "<<",
	  Expr_Binary BinOp_Shr <$+ pKeyLoc ">>"],
	 [Expr_Binary BinOp_Add <$+ pKeyLoc "+",
	  Expr_Binary BinOp_Sub <$+ pKeyLoc "-"],
	 [Expr_Binary BinOp_Mul <$+ pKeyLoc "*",
	  Expr_Binary BinOp_Mod <$+ pKeyLoc "%",
	  Expr_Binary BinOp_Div <$+ pKeyLoc "/"] ]

pBinExpr = pGExprl bins pUnaryExpr

-- Merged with Postfix expressions to reduce the look ahead by one token
-- not anymore, just for casts and parentheses
pUnaryExpr ::CParser Token Expr
pUnaryExpr = pSpecLoc '(' +**> pCastOrParen -- )
	     <|> (Expr_Literal <$> pLiteral) <??> pFollowPostfixExpr
	     <|> (Expr_Ident <$+> pIdentLoc) <??> pFollowPostfixExpr
	     <|> Expr_Unary UnOp_Plus <$+ pKeyLoc "+" <*> pUnaryExpr
	     <|> Expr_Unary UnOp_Minus <$+ pKeyLoc "-" <*> pUnaryExpr
	     <|> Expr_Unary UnOp_LogNot <$+ pKeyLoc "!" <*> pUnaryExpr
	     <|> Expr_Unary UnOp_BinNot <$+ pKeyLoc "~" <*> pUnaryExpr
	     <|> Expr_Unary UnOp_AddressOf <$+ pKeyLoc "&" <*> pUnaryExpr
	     <|> Expr_Unary UnOp_Indirection <$+ pKeyLoc "*" <*> pUnaryExpr
	     <|> Expr_Unary UnOp_PreInc <$+ pKeyLoc "++" <*> pUnaryExpr
	     <|> Expr_Unary UnOp_PreDec <$+ pKeyLoc "--" <*> pUnaryExpr
	     <|> Expr_SizeOf <$+ pKeyLoc "sizeof" <*> pRestOfSlow
	     <|> Expr_AlignOf <$+ pKeyLoc "__alignof" <*> pRestOfSlow
	     where pRestOfSlow = SizeOfExpr_Expr <$> pUnaryExpr
				 <|> pParens (SizeOfExpr_Type <$> pDeclSpecs <*> pAbstractDeclarator)
		   -- This parser is faster than the previous and works for most code
		   -- I though the correct syntax for sizeof was always with a parenthesis
		   -- but reading the standard i realized it's not the case.
		   -- And i already encountered code that uses it so... we use the previous one
		   pRestOfFast = pParens (SizeOfExpr_Expr <$> pUnaryExpr
					  <|> SizeOfExpr_Type <$> pDeclSpecs <*> pAbstractDeclarator)

-- struct and union members could have a typedef name, that's
-- why there is the "<|> pTypedef" construction
pFollowPostfixExpr ::CParser Token (Expr -> Expr)
pFollowPostfixExpr = (\ fs p -> foldl (flip ($)) p fs ) <$> pList1 pFollow
		     where pFollow = f Expr_FunCall <$+ pSpecLoc '(' <*> pExprs <* pSpec ')'
				     <|> f Expr_Subscript <$+ pSpecLoc '[' <*> pExpr <* pSpec ']'
				     <|> f Expr_DComponentSel <$+ pKeyLoc "." <*> (pIdent <|> pTypedef)
				     <|> f Expr_IComponentSel <$+ pKeyLoc "->" <*> (pIdent <|> pTypedef)
				     <|> Expr_Unary UnOp_PostInc <$+ pKeyLoc "++"
				     <|> Expr_Unary UnOp_PostDec <$+ pKeyLoc "--"
			   f g l a b = g l b a

-- Sorry about this mess
-- i am passing the information previously collected with the '('.
-- parsers not needing the location ignore it with 'const'
pCastOrParen ::CParser Token (Pos->Expr)
pCastOrParen = Expr_Cast <$> pDeclSpecs <*> pAbstractDeclarator <* pSpec ')' <*> pUnaryExpr
	       <|> const <$> ((pExpr <* pSpec ')') <??> pFollowPostfixExpr)
               -- statement expression (GNUism)
               <|> Expr_Stmnt <$> pCompoundStmnt <* pSpec ')'

-- pEnableTypeSpecFlag can only be used iff
-- afterwards we always do a pDisableTypeSpecFlag
-- it must be transparent outside pDeclSpecs
-- we do that so no problem
-- we use pEnableTypedefFlag in storage class specifier
-- always disable that flag!! maybe use a special declarator
pDeclSpecs :: CParser Token DeclSpecs
pDeclSpecs = pDisableTypeSpecFlag $
	     pFoldr1 ((:),[]) pDeclSpec

pDeclSpec :: CParser Token DeclSpec
pDeclSpec = DeclSpec_StorClassSpec <$> pStorClassSpec
	    <|> DeclSpec_TypeSpec <$> pEnableTypeSpecFlag pTypeSpec
	    <|> DeclSpec_TypeQual <$> pTypeQual
	    <|> DeclSpec_GNUAttr <$ pAttributes

-- This parser is safer than pDeclSpecs in the sens that we do not need
-- to use pDisableTypedefFlag. Note that you can't use it for saving
-- typedefs!!!
pDeclSpecsSoft = pDisableTypeSpecFlag $
		 pFoldr1 ((:),[]) pDeclSpecSoft

pDeclSpecSoft = DeclSpec_StorClassSpec <$> pStorClassSpecSoft
		<|> DeclSpec_TypeSpec <$> pEnableTypeSpecFlag pTypeSpec
		<|> DeclSpec_TypeQual <$> pTypeQual
		<|> DeclSpec_GNUAttr <$ pAttributes

pTypeQuals = pFoldr ((:),[]) pTypeQual

pTypeQual :: CParser Token TypeQual
pTypeQual = TypeQual_Const <$ (pKey "const" <|> pKey "__const")
	    <|> TypeQual_Volatile <$ pKey "volatile"
	    <|> TypeQual_Restrict <$ (pKey "restrict" <|> pKey "__restrict")

-- see remark in declspecs
pStorClassSpec ::CParser Token StorClassSpec
pStorClassSpec = StorClassSpec_Auto <$ pKey "auto"
		 <|> StorClassSpec_Extern <$ pKey "extern"
		 <|> StorClassSpec_Register <$ pKey "register"
		 <|> StorClassSpec_Static <$ pKey "static"
		 <|> (pEnableTypedefFlag $ StorClassSpec_Typedef <$ pKey "typedef")

pStorClassSpecSoft = StorClassSpec_Auto <$ pKey "auto"
		     <|> StorClassSpec_Extern <$ pKey "extern"
		     <|> StorClassSpec_Register <$ pKey "register"
		     <|> StorClassSpec_Static <$ pKey "static"
		     <|> StorClassSpec_Typedef <$ pKey "typedef"

-- Mmm i don't remeber where this was used. We might need it for some code
pInline = StorClassSpec_Inline <$ (pKey "inline" <|> pKey "__inline" <|> pKey "__inline__")

-- Type specifier
pTypeSpec ::CParser Token TypeSpec
pTypeSpec = pKeyLoc "enum" +**> pEnum
	    <|> TypeSpec_Float <$+ pKeyLoc "float"
	    <|> TypeSpec_Double <$+ pKeyLoc "double"
	    <|> TypeSpec_Short <$+ pKeyLoc "short"
	    <|> TypeSpec_Int <$+ pKeyLoc "int"
	    <|> TypeSpec_Long <$+ pKeyLoc "long"
	    <|> TypeSpec_Char <$+ pKeyLoc "char"
	    <|> TypeSpec_Signed <$+ pKeyLoc "signed"
	    <|> TypeSpec_Unsigned <$+ pKeyLoc "unsigned"
	    <|> TypeSpec_TypeOf <$ pKey "typeof" <*> pParens (TypeOf_Expr <$> pExpr
							      <|> TypeOf_Type <$> pDeclSpecs <*> pAbstractDeclarator)
	    <|> pKeyLoc "struct" +**> pStruct
	    <|> TypeSpec_TypeDefName <$+> pTypedefLoc
	    <|> pKeyLoc "union" +**> pUnion
	    <|> TypeSpec_Void <$+ pKeyLoc "void"
	    where -- Note that enum struct and union names live in different
		  -- namespaces, that's why we need to parse pTypedef's
		  pEnum = TypeSpec_EnumDef "" <$> pCurly pEnumDefs
			  <|> (pIdent <|> pTypedef) <**> pEnumRest
		  pEnumRest = flip TypeSpec_EnumDef <$> pCurly pEnumDefs
			      `opt` TypeSpec_EnumRef

		  pStruct = TypeSpec_StructDef "" <$> pCurly pFields
			    <|> (pIdent <|> pTypedef) <**> pStructRest
		  pStructRest = flip TypeSpec_StructDef <$> pCurly pFields
				`opt` TypeSpec_StructRef

		  pUnion = TypeSpec_UnionDef "" <$> pCurly pFields
			   <|> (pIdent <|> pTypedef) <**> pUnionRest
		  pUnionRest = flip TypeSpec_UnionDef <$> pCurly pFields
			       `opt` TypeSpec_UnionRef

pEnumDefs ::CParser Token EnumDefs
pEnumDefs = pFoldr1Sep ((:),[]) (pSpec ',') pEnumDef

pEnumDef ::CParser Token EnumDef
pEnumDef = EnumDef_Sin <$+> pIdentLoc <*> ((MExpr_Just <$ pKey "=" <*> pExprN) `opt` MExpr_Nothing)

pFields ::CParser Token Fields
pFields = pFoldr1 ((:),[]) pField

pField ::CParser Token Field
pField = Field_Sin <$> pDeclSpecs <*> pComponentDeclarators <* pSpec ';'

pComponentDeclarators ::CParser Token ComponentDeclarators
pComponentDeclarators = pFoldr1Sep ((:),[]) pComma pComponentDeclarator

-- Can component declarators have GNU attributes?
-- We use pDeclaratorSoft because identifiers with name of typedefs
-- are referenced by . or -> so we don't hace to use a special list
-- as we do with general case in Top Level Declarations
pComponentDeclarator ::CParser Token ComponentDeclarator
pComponentDeclarator = ComponentDeclarator_Bitfield MDeclarator_Nothing <$ pSpec ':' <*> pExpr
		       <|> pDeclaratorSoft
		       <**> (pSpec ':' *> ((\e d
					    -> ComponentDeclarator_Bitfield (MDeclarator_Just d) e )
					   <$> pExpr)
			    `opt` ComponentDeclarator_Simple)

-- We will ignore attributes
-- one more dirty hack to recognize __extension keyword
pAttributes = pKey "__attribute__" *> pParens( pParens (pList1Sep pComma pAttr))
	      <|> [] <$ pKey "__extension__"
	      where pAttr = (pIdent <|> pKey "const") <*
			    (pParens (pList1Sep pComma pExpr) `opt` [])

-- Puede representar un AbstractDeclarator vacío de la sig. manera:
-- AbstractDeclarator_PDecl []
pAbstractDeclarator ::CParser Token AbstractDeclarator
pAbstractDeclarator = pPointers <**> (flip AbstractDeclarator_DDecl <$> pDAbstractDeclarator
				      `opt` AbstractDeclarator_PDecl)

pDAbstractDeclarator ::CParser Token DAbstractDeclarator
pDAbstractDeclarator = f <$> pParens pAbstractDeclarator <*> pFollow <|>
		       f (AbstractDeclarator_PDecl []) <$> pFollowX
		       where f ad pfs = foldl (flip ($)) (DAbstractDeclarator_Paren ad) pfs
			     pFollow = pList pFollow1
			     pFollowX = pList1 pFollow1
			     pFollow1= flip DAbstractDeclarator_Array <$> pBracks pMExpr
				       <|> flip DAbstractDeclarator_Fun <$> pParens pParametersSoft

pParametersSoft = pParamsDef . pParamGen $ pDeclaratorSoft


pParamsDef p = (:) <$> p <**> pFollow
    where pFollow = ParamTypes_VarNParam . ($[]) <$ pSpec ',' <* pKey "..."
		    <|> (\ p f fp -> f $ fp . (:) p) <$ pSpec ',' <*> p <*> pFollow
		    `opt` ParamTypes_ConNParam . ($[])

pParamGen p = flip ($) <$> pDeclSpecsSoft <*> (flip Parameter_Named <$> p
					       <|> flip Parameter_Unnamed <$> pAbstractDeclarator)

pDDeclaratorGen p px ps = f <$+> p <*> pFollow
		    <|> g <$> pParens px <*> pFollow
		    where f i l pfs = foldl (flip ($)) (DDeclarator_Simple i l) pfs
			  g d pfs = foldl (flip ($)) (DDeclarator_Paren d) pfs
			  h ps x = DDeclarator_Fun x (FunDeclarator_Proto ps)
			  k ps x = DDeclarator_Fun x (FunDeclarator_Old ps)
			  pFollow = pList pFollow1
			  pFollow1= flip DDeclarator_Array <$> pBracks pMExpr
				    <|> pParens (h <$> ps
						 <|> k <$> pIdents)

pPointers :: CParser Token Pointers
pPointers = pFoldl (flip ($),[]) (pKey "*" *> p)
	    where p = (:) <$> pTypeQuals

--------------------------------------------
-- Declarator used in top level declarations
-- it saves identifiers into the typedef structure
-- if typedef flag is enabled
-- the parameters of functions declared/defined here
-- do not save identifiers into typedef list but
-- they put them into the no-typedefs list if they
-- are encountered as declarators
-- note that it also opens a new scope as it can
-- define function bodies where we have to put typedef
-- identifiers
pDeclaratorTopLevel :: CParser Token Declarator
pDeclaratorTopLevel = Declarator_Sin <$> pPointers
		      <*> pDDeclaratorGen (pPushScopeAfter . pSaver fst $ pIdentLoc)
			  pDeclaratorTopLevel
			  (pParamsDef.pParamGen$ pDeclaratorTopAux)

pDeclaratorTopAux = Declarator_Sin <$> pPointers
		    <*> pDDeclaratorGen (pIdentLoc <|> pRemover fst pTypedefLoc)
			pDeclaratorTopAux
			(pParamsDef.pParamGen$ pDeclaratorSoft)

--------------------------------------------
-- Declarator used in body declarations
-- this saves identifiers into the typedef list
-- if corresponding flag is enabled
-- this also puts identifiers in the no-typedefs list
-- if typedefs are parsed as declarators
-- if functions are declared here its parameters
-- don't do a thing (soft declarators)
pDeclaratorBody = Declarator_Sin <$> pPointers
		  <*> pDDeclaratorGen (pSaver fst pIdentLoc <|> pSaverRemover fst pTypedefLoc)
		      pDeclaratorBody
		      (pParamsDef.pParamGen$ pDeclaratorSoft)

-----------------------------------------------
-- Soft declarator
-- a soft declarator does not touch the state
-- we try to use them as much as possible
pDeclaratorSoft = Declarator_Sin <$> pPointers
		  <*> pDDeclaratorGen (pIdentLoc<|>pTypedefLoc)
                                      pDeclaratorSoft
				      pParametersSoft

--------------------------------------------------------------------------

pIdents :: CParser Token Idents
pIdents = pFoldrSep ((:),[]) pComma pIdent

pMExpr ::CParser Token MExpr
pMExpr = (MExpr_Just <$> pExpr) `opt` MExpr_Nothing

-------------------------------------
-- Now .... let's go for declarations
pDeclaration ::CParser Token Decl
pDeclaration = Decl_Sin <$> pDeclSpecs <*> pInitDecls <* (pAttributes `opt` [])
	       <* pDisableTypedefFlag pSemi

-- Only used by pDeclaration
pInitDecls ::CParser Token InitDecls
pInitDecls = pFoldlSep (flip (:),[]) (pSpec ',') $
	     pInitDecl pDeclaratorBody

-- Attributes are only parsed their semantics are not "saved"
pInitDecl :: CParser Token Declarator -> CParser Token InitDecl
pInitDecl p = InitDecl_Sin <$> p <* (pAttributes `opt` []) <*> pDs
    where pDs = MInitializer_Just <$ pKey "=" <*> pInitializer
		`opt` MInitializer_Nothing

-- parameter types of traditional C
pSDeclarations ::CParser Token Decls
pSDeclarations = pFoldr ((:),[])  pDeclaration

-- Note, be careful to use "commaless" expressions
pInitializer ::CParser Token Initializer
pInitializer = Initializer_Sin Tag_Nil <$> pExprN
	       <|> Initializer_List <$> pCurly pInitializers
	       <|> p1 <*> (pKey "=" *> pExprN
			   <|> pExprN)
	       <|> Initializer_Sin . Tag_Tag <$>(pIdent<|>pTypedef)<*pSpec ':'<*>pExprN
	       where p1 = pBracks (pExprN <**>
				   ((\x y->Initializer_Sin (Tag_Range y x)) <$ pKey "..." <*> pExprN
				    `opt` (\x->Initializer_Sin (Tag_Index x))))
			  <|> Initializer_Sin . Tag_Tag <$ pKey ['.'] <*> (pIdent<|>pTypedef)
	       

pInitializers ::CParser Token Initializers
pInitializers = (:) <$> pInitializer
		<*> ((pSpec ',' *> (pInitializers `opt` []))
		     `opt` [])


-- Parsing of statements and compound statements including inner declarations
pDeclarations ::CParser Token Decls
pDeclarations = pFoldr ((:),[]) pDeclaration

pStmnts = pFoldr ((:),[]) pStmnt

pCompoundStmnt = Stmnt_Compound <$ pOpenScopeCurly <*> pDeclarations <*> pStmnts <* pCloseScopeCurly
pCompoundStmntCScope = Stmnt_Compound <$ pOCurly <*> pDeclarations <*> pStmnts <* pCloseScopeCurly

pStmnt ::CParser Token Stmnt
pStmnt = Stmnt_Label <$+> pIdentLoc <* pSpec ':' <*> pStmnt
	 <|> Stmnt_Expr <$> pExpr <* pSemi
         <|> Stmnt_Compound <$ pOpenScopeCurly <*> pDeclarations <*> pStmnts <* pCloseScopeCurly
	 <|> Stmnt_If <$+ pKeyLoc "if" <*> pParens pExpr <*> pStmnt <*>
		  (MStmnt_Just <$ pKey "else" <*> pStmnt
		   `opt` MStmnt_Nothing)
	 <|> Stmnt_Do <$+ pKeyLoc "do" <*> pStmnt <* pKey "while" <*> pParens pExpr
         <|> Stmnt_While <$+ pKeyLoc "while" <*> pParens pExpr <*> pStmnt
	 <|> Stmnt_For <$+ pKeyLoc "for" <* pOParen <*> pMExpr <* pSemi <*> pMExpr
		   <* pSemi <*> pMExpr <* pCParen <*> pStmnt
	 <|> Stmnt_Switch <$+ pKeyLoc "switch" <*> pParens pExpr <*> pStmnt
	 <|> Stmnt_Break <$+ pKeyLoc "break" <* pSemi
	 <|> Stmnt_Continue <$+ pKeyLoc "continue" <* pSemi
	 <|> Stmnt_Return <$+ pKeyLoc "return" <*> pMExpr <* pSemi
	 -- goto expr is a GNU extension
	 <|> Stmnt_Goto <$+ pKeyLoc "goto" <*> pIdent <* pSemi
	 <|> Stmnt_Case <$ pKey "case" <*> pExpr <* pSpec ':' <*> pStmnt
	 <|> Stmnt_Default <$ pKey "default" <* pSpec ':' <*> pStmnt
	 <|> Stmnt_Null <$ pSemi

-----------------------------------------------------------------
-- Top level declaration
--------------------
-- Please note that it is divided in two main parsing rules
-- the first rule parses declarations without typedef
-- and the second parses declarations with typedefs
-- we could join the rules by adding more state information:
-- "there is a pending typedef"
-- haven't tried it yet though

pTopLevelDecl ::CParser Token TopLevelDecl
pTopLevelDecl = pDisableTypedefFlag $
		pDeclSpecs <**> (ff <$> pDeclaratorTopLevel <* (pList1 pAttributes `opt` []) <*> pRest
				 <|> gg <$ pSemi)
		where pRest = f <$ pKey "=" <*> pInitializer <*> pRestInitDecls <* pPopScope pSemi
			      <|> g <$> pRestInitDecls <* pPopScope pSemi
			      <|> h <$> pSDeclarations <*> pCompoundStmntCScope
		      f i is declSpecs declarator = TopLevelDecl_Decl (Decl_Sin declSpecs inits)
			  where inits = foldl (flip (:))
					      []
					      (InitDecl_Sin declarator (MInitializer_Just i):is)
		      g is declSpecs declarator = TopLevelDecl_Decl (Decl_Sin declSpecs inits)
			  where inits = foldl (flip (:))
					      []
					      (InitDecl_Sin declarator MInitializer_Nothing:is)
		      h sdecls stmnt declSpecs declarator = TopLevelDecl_Fun
							    (FunDef_Sin declSpecs declarator sdecls stmnt)
		      ff declarator func declSpecs= func declSpecs declarator
		      gg declSpecs = TopLevelDecl_Decl (Decl_Sin declSpecs [])

-- A program must at least one declaration long in ANSI C
-- In GNU C it is allowed to have a "zero length" program
-- We'll stick with GNU C syntactically
pTopLevelDecls ::CParser Token TopLevelDecls
pTopLevelDecls = pFoldr ((:),[]) pTopLevelDecl

pRestInitDecls ::CParser Token [InitDecl]
pRestInitDecls = pList (pPopScope pComma *> pInitDecl pDeclaratorTopLevel)

-- GCC predefined types
-- GCC headers require some builtin types
-- They are added in the initial environment
builtin_gcc = ["__builtin_va_list"]
ini_env = foldr (flip syInsertTypedef) syInit builtin_gcc

parseC p i = parse p (CTypesInp ini_env i)

tokenizer = lexC

{-
test s = do cont <- readFile s
	    let toks = tokenizer s cont
	        tree = parseC pTopLevelDecls toks
	    putStr (show tree)
-}
{-
testC s   = do cont <- readFile s
	       let (toks,m) = tokenizer s cont
		   (tree,pErrors) = parseC pTopLevelDecls toks
		   newTree = sem_TopLevelDecls tree
		   (e,(ioErrors,tErrors)) = newTree nullCEnv undefined ia32Flags
	       putStr (show pErrors)
	       putStr tErrors

testC2 = do cont <- getContents
	    let (toks,m) = tokenizer "" cont
		(tree,pErrors) = parseC pTopLevelDecls toks
		newTree = sem_TopLevelDecls tree
		(e,(ioErrors,tErrors)) = newTree nullCEnv undefined ia32Flags
	    putStr (show pErrors)
	    putStr tErrors
--	    putStr . show $ m
-}


{-
	       let f s = if null s then ""
		         else maybe ("Identifier "++s++" not found!\n")
				    (\ (t,b) -> "Identifer "++s++" has type "++show t++"\n")
                                    (findExprIdent e s)
	       putStr (f i)
-}

{-
showFM :: CG -> IO ()
showFM cg = foldFM showEC (return ()) cg
    where showEC k vs c = mapM_ showL vs >> c
	      where showL v = putStr (n++" -> \""++v++"\"\n")
		    n = show k

testC2 = do cont <- getContents
	    let toks = tokenizer "" cont
		(tree,pErrors) = parseC pTopLevelDecls toks
		newTree = sem_TopLevelDecls tree
		(e,(ioErrors,tErrors),cg) = newTree nullCEnv ia32Flags emptyFM
	    putStr (show pErrors)
	    putStr tErrors
	    showFM cg

testC s   = do cont <- readFile s
	       let toks = tokenizer s cont
		   (tree,pErrors) = parseC pTopLevelDecls toks
		   newTree = sem_TopLevelDecls tree
		   (e,(ioErrors,tErrors),cg) = newTree nullCEnv ia32Flags emptyFM
	       putStr (show pErrors)
	       putStr tErrors
	       showFM cg
-}