{-# LANGUAGE CPP, PatternGuards #-}
module Language.Java.Paragon.Parser (
    parser, 
    
    compilationUnit, packageDecl, importDecl, typeDecl,
    
    classDecl, interfaceDecl,
    
    memberDecl, fieldDecl, methodDecl, constrDecl,
    interfaceMemberDecl, absMethodDecl,methodBody,
    
    formalParams, formalParam,
    
    modifier,
    
    varDecls, varDecl, varInit, arrayInit,
    
    block, blockStmt, stmt,
    
    stmtExp, exp, primary, literal,
    
    ttype, primType, refType, classType, resultType,
    
    typeParams, typeParam,
    
    name, ident,
    
    policy, policyExp, clause, actor, atom,
    
    
    empty, list, list1, seplist, seplist1, opt, bopt, lopt,
    
    comma, semiColon, period, colon,

    ParseError
    
    ) where

import Language.Java.Paragon.Lexer ( L(..), Token(..), lexer)
import Language.Java.Paragon.Syntax
import Language.Java.Paragon.Pretty

import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Pos

import Prelude hiding ( exp, catch, (>>), (>>=) )
import qualified Prelude as P ( (>>), (>>=) ) 
import Data.Maybe ( isJust, catMaybes )
import Control.Monad ( ap, liftM )
import Control.Applicative ( (<$>) )
import Control.Arrow ( first )

import Data.Generics.Uniplate.Data
#ifdef BASE4
import Data.Data
#else
import Data.Generics (Data(..),Typeable(..))
#endif

-- import Debug.Trace (trace)

type P = GenParser (L Token) ()

-- A trick to allow >> and >>=, normally infixr 1, to be
-- used inside branches of <|>, which is declared as infixl 1.
-- There are no clashes with other operators of precedence 2.
(>>) = (P.>>)
(>>=) = (P.>>=)
infixr 2 >>, >>=
-- Note also when reading that <$> is infixl 4 and thus has 
-- lower precedence than all the others (>>, >>=, and <|>).

-- Since I cba to find the instance Monad m => Applicative m declaration.
(<*>) :: Monad m => m (a -> b) -> m a -> m b
(<*>) = ap

----------------------------------------------------------------------------
-- Top-level parsing

parseCompilationUnit :: String -> Either ParseError CompilationUnit
parseCompilationUnit inp = 
    runParser compilationUnit () "" (lexer inp)

parser p = runParser p () "" . lexer

----------------------------------------------------------------------------
-- Packages and compilation units

compilationUnit :: P CompilationUnit
compilationUnit = do
    mpd <- opt packageDecl
    ids <- list importDecl
    tds <- list typeDecl
    return $ CompilationUnit mpd ids (catMaybes tds)

packageDecl :: P PackageDecl
packageDecl = do
    tok KW_Package
    n <- name
    semiColon
    return $ PackageDecl n
    
importDecl :: P ImportDecl
importDecl = do
    tok KW_Import
    st <- bopt $ tok KW_Static
    n  <- name
    ds <- bopt $ period >> tok Op_Star
    semiColon
    return $ ImportDecl st n ds

typeDecl :: P (Maybe TypeDecl)
typeDecl = Just <$> classOrInterfaceDecl <|> 
            const Nothing <$> semiColon

----------------------------------------------------------------------------
-- Declarations

-- Class declarations

classOrInterfaceDecl :: P TypeDecl
classOrInterfaceDecl = do
    ms <- list modifier
    de <- (do cd <- classDecl
              checkConstrs (cd [])
              return $ \ms -> ClassTypeDecl (cd ms)) <|>
          (do id <- interfaceDecl
              return $ \ms -> InterfaceTypeDecl (id ms))
    return $ de ms

classDecl :: P (Mod ClassDecl)
classDecl = normalClassDecl <|> enumClassDecl

normalClassDecl :: P (Mod ClassDecl)
normalClassDecl = do
    tok KW_Class
    i   <- ident
    tps <- lopt typeParams
    mex <- opt extends
    imp <- lopt implements
    bod <- classBody
    return $ \ms -> 
        generalize tps $ ClassDecl ms i tps ((fmap head) mex) imp bod

extends :: P [RefType]
extends = tok KW_Extends >> refTypeList

implements :: P [RefType]
implements = tok KW_Implements >> refTypeList

enumClassDecl :: P (Mod ClassDecl)
enumClassDecl = do
    tok KW_Enum
    i   <- ident
    imp <- lopt implements
    bod <- enumBody
    return $ \ms -> EnumDecl ms i imp bod

classBody :: P ClassBody
classBody = ClassBody <$> braces classBodyDecls

enumBody :: P EnumBody
enumBody = braces $ do
    ecs <- seplist enumConst comma
    optional comma
    eds <- lopt enumBodyDecls
    return $ EnumBody ecs eds
    
enumConst :: P EnumConstant
enumConst = do
    id  <- ident
    as  <- lopt args
    mcb <- opt classBody
    return $ EnumConstant id as mcb

enumBodyDecls :: P [Decl]
enumBodyDecls = semiColon >> classBodyDecls

classBodyDecls :: P [Decl]
classBodyDecls = list classBodyDecl

-- Interface declarations

interfaceDecl :: P (Mod InterfaceDecl)
interfaceDecl = {- trace "interfaceDecl" $ -} do
    tok KW_Interface
    id  <- ident
    tps <- lopt typeParams
    exs <- lopt extends
    bod <- interfaceBody
    return $ \ms -> 
        generalize tps $ InterfaceDecl ms id tps exs bod

interfaceBody :: P InterfaceBody
interfaceBody = InterfaceBody . catMaybes <$> 
    braces (list interfaceBodyDecl)

-- Declarations

classBodyDecl :: P Decl
classBodyDecl = 
    (try $ do 
        mst <- bopt (tok KW_Static)
        blk <- block
        return $ InitDecl mst blk) <|> 
    (do ms  <- list modifier
        dec <- memberDecl
        return $ MemberDecl (dec ms))
    
memberDecl :: P (Mod MemberDecl)
memberDecl = {- trace "memberDecl" $ -}
    (try $ do 
        cd  <- classDecl
        return $ \ms -> MemberClassDecl (cd ms)) <|>
    (try $ do 
        id  <- interfaceDecl
        return $ \ms -> MemberInterfaceDecl (id ms)) <|> 
    try fieldDecl <|>
    lockDecl <|>        -- Paragon
--    policyDecl <|>      -- Paragon
    try methodDecl <|> 
    constrDecl

fieldDecl :: P (Mod MemberDecl)
fieldDecl = endSemi $ do
    typ <- ttype
    vds <- varDecls
    return $ \ms -> FieldDecl ms typ vds

methodDecl :: P (Mod MemberDecl)
methodDecl = do
    tps <- lopt typeParams
    rt  <- resultType
    id  <- ident
    fps <- formalParams
    thr <- lopt throws
    bod <- methodBody
    return $ \ms -> 
        generalize tps $ MethodDecl ms tps rt id fps thr bod

methodBody :: P MethodBody
methodBody = MethodBody <$> 
    (const Nothing <$> semiColon <|> Just <$> block)

constrDecl :: P (Mod MemberDecl)
constrDecl = do
    tps <- lopt typeParams
    id  <- ident
    fps <- formalParams
    thr <- lopt throws
    bod <- constrBody
    return $ \ms -> 
        generalize tps $ ConstructorDecl ms tps id fps thr bod

lockDecl :: P (Mod MemberDecl)
lockDecl = endSemi $ do
    tok KW_P_Lock
    lc  <- ident
    ar  <- lopt arity
    lp  <- opt lockProperties
    return $ \ms -> LockDecl ms lc ar lp

arity :: P [Maybe Ident]
arity = parens $ seplist ({- tok Op_Query >> -} opt ident) comma

{-
policyDecl :: P (Mod MemberDecl)
policyDecl = endSemi $ do
    tok KW_P_Policy
    pn  <- ident
    tok Op_Equal
    pol <- policy
    return $ \ms -> PolicyDecl ms pn pol
-}

constrBody :: P ConstructorBody
constrBody = braces $ do
    mec <- opt (try explConstrInv)
    bss <- list blockStmt
    return $ ConstructorBody mec bss
    
explConstrInv :: P ExplConstrInv
explConstrInv = endSemi $
    (try $ do
        tas <- lopt nonWildTypeArgs
        tok KW_This
        as  <- args
        return $ ThisInvoke tas as) <|> 
    (try $ do
        tas <- lopt nonWildTypeArgs
        tok KW_Super
        as  <- args
        return $ SuperInvoke tas as) <|> 
    (do pri <- primary
        period
        tas <- lopt nonWildTypeArgs
        tok KW_Super
        as  <- args
        return $ PrimarySuperInvoke pri tas as)

-- TODO: This should be parsed like class bodies, and post-checked.
--       That would give far better error messages.
interfaceBodyDecl :: P (Maybe MemberDecl)
interfaceBodyDecl = semiColon >> return Nothing <|> 
    do ms  <- list modifier
       imd <- interfaceMemberDecl
       return $ Just (imd ms)
    
interfaceMemberDecl :: P (Mod MemberDecl)
interfaceMemberDecl =
    (do cd  <- classDecl
        return $ \ms -> MemberClassDecl (cd ms)) <|>
    (do id  <- interfaceDecl
        return $ \ms -> MemberInterfaceDecl (id ms)) <|> 
    try fieldDecl <|> 
    lockDecl <|>
    absMethodDecl

absMethodDecl :: P (Mod MemberDecl)
absMethodDecl = do
    tps <- lopt typeParams
    rt  <- resultType
    id  <- ident
    fps <- formalParams
    thr <- lopt throws
    semiColon
    return $ \ms -> 
        generalize tps $ MethodDecl ms tps rt id fps thr (MethodBody Nothing)

throws :: P [ExceptionSpec]
throws = tok KW_Throws >> seplist1 exceptionSpec comma

exceptionSpec :: P ExceptionSpec
exceptionSpec = do
  --mp <- opt policy
  mods <- list modifier
  rt <- refType
  return $ ExceptionSpec mods rt

-- Formal parameters

formalParams :: P [FormalParam]
formalParams = parens $ do
    fps <- seplist formalParam comma
    if validateFPs fps
     then return fps
     else fail "Only the last formal parameter may be of variable arity"
  where validateFPs :: [FormalParam] -> Bool
        validateFPs [] = True
        validateFPs [_] = True
        validateFPs (FormalParam _ _ b _ :xs) = not b

formalParam :: P FormalParam
formalParam = do
    ms  <- list modifier
    typ <- ttype
    var <- bopt ellipsis
    vid <- varDeclId
    return $ FormalParam ms typ var vid

ellipsis :: P ()
ellipsis = period >> period >> period

-- Modifiers

modifier :: P Modifier
modifier = 
        tok KW_Public      >> return Public    
    <|> tok KW_Protected   >> return Protected 
    <|> tok KW_Private     >> return Private   
    <|> tok KW_Abstract    >> return Abstract  
    <|> tok KW_Static      >> return Static    
    <|> tok KW_Strictfp    >> return StrictFP  
    <|> tok KW_Final       >> return Final     
    <|> tok KW_Native      >> return Native    
    <|> tok KW_Transient   >> return Transient 
    <|> tok KW_Volatile    >> return Volatile  

    <|> tok KW_P_Typemethod  >> return Typemethod
    <|> tok KW_P_Reflexive   >> return Reflexive
    <|> tok KW_P_Transitive  >> return Transitive
    <|> tok KW_P_Commutative >> return Commutative
    <|> tok Op_Query >> policy  >>= return . Reads
    <|> tok Op_Bang  >> policy  >>= return . Writes
    <|> tok Op_Plus  >> lockExp >>= return . Opens
    <|> tok Op_Minus >> lockExp >>= return . Closes
    <|> tok Op_Tilde >> lockExp >>= return . Expects

----------------------------------------------------------------------------
-- Variable declarations

varDecls :: P [VarDecl]
varDecls = seplist1 varDecl comma

varDecl :: P VarDecl
varDecl = do
    vid <- varDeclId
    mvi <- opt $ tok Op_Equal >> varInit
    return $ VarDecl vid mvi

varDeclId :: P VarDeclId
varDeclId = do
    id  <- ident
    abs <- list arrBrackets
    return $ foldl (\f _ -> VarDeclArray . f) VarId abs id

arrBrackets :: P ()
arrBrackets = brackets $ return ()

localVarDecl :: P ([Modifier], Type, [VarDecl])
localVarDecl = do
    ms  <- list modifier
    typ <- ttype
    vds <- varDecls
    return (ms, typ, vds)

varInit :: P VarInit
varInit = 
    try (InitArray <$> arrayInit) <|> 
    InitExp   <$> exp

arrayInit :: P ArrayInit
arrayInit = braces $ do
    vis <- seplist varInit comma
    opt comma
    return $ ArrayInit vis


----------------------------------------------------------------------------
-- Statements

block :: P Block
block = braces $ Block <$> list blockStmt

blockStmt :: P BlockStmt
blockStmt = 
    (try $ do
        ms  <- list modifier
        cd  <- classDecl
        return $ LocalClass (cd ms)) <|> 
    (try $ do
        (m,t,vds) <- endSemi $ localVarDecl
        return $ LocalVars m t vds) <|>
    (try $ endSemi $ do
        ms  <- list modifier
        tok KW_P_Lock
        lc  <- ident
        ar  <- lopt arity
        lp  <- opt lockProperties
        return $ LocalLock ms lc ar lp) <|>
{-    (try $ endSemi $ do
        ms  <- list modifier
        tok KW_P_Policy
        ln  <- ident
        tok Op_Equal
        pol <- policy
        return $ LocalPolicy ms ln pol) <|> -}
    BlockStmt <$> stmt

stmt :: P Stmt
stmt = 
    -- ifThen and ifThenElse, with a common prefix
    (do tok KW_If
        e   <- parens exp
        (try $ 
            do th <- stmtNSI
               tok KW_Else
               el <- stmt
               return $ IfThenElse e th el) <|> 
           (do th <- stmt
               return $ IfThen e th)) <|> 
    -- while loops
    (do tok KW_While
        e   <- parens exp
        s   <- stmt
        return $ While e s) <|>
    -- basic and enhanced for
    (do tok KW_For
        f <- parens $ 
            (try $ do
                fi <- opt forInit
                semiColon
                e  <- opt exp
                semiColon
                fu <- opt forUp
                return $ BasicFor fi e fu) <|> 
            (do ms <- list modifier
                t  <- ttype
                i  <- ident
                colon
                e  <- exp
                return $ EnhancedFor ms t i e)
        s <- stmt
        return $ f s) <|> 
    -- labeled statements
    (try $ do
        lbl <- ident
        colon
        s   <- stmt
        return $ Labeled lbl s) <|>
    -- the rest
    stmtNoTrail

stmtNSI :: P Stmt
stmtNSI =
    -- if statements - only full ifThenElse
    (do tok KW_If
        e  <- parens exp
        th <- stmtNSI
        tok KW_Else
        el <- stmtNSI
        return $ IfThenElse e th el) <|>
    -- while loops
    (do tok KW_While
        e <- parens exp
        s <- stmtNSI
        return $ While e s) <|>
    -- for loops, both basic and enhanced
    (do tok KW_For
        f <- parens $ (try $ do
            fi <- opt forInit
            semiColon
            e  <- opt exp
            semiColon
            fu <- opt forUp
            return $ BasicFor fi e fu)
            <|> (do
            ms <- list modifier
            t  <- ttype
            i  <- ident
            colon
            e  <- exp
            return $ EnhancedFor ms t i e)
        s <- stmtNSI
        return $ f s) <|>
    -- labeled stmts
    (try $ do
        i <- ident
        colon
        s <- stmtNSI
        return $ Labeled i s) <|>
    -- the rest
    stmtNoTrail


stmtNoTrail :: P Stmt
stmtNoTrail = 
    -- empty statement
    const Empty <$> semiColon <|>
    -- inner block
    StmtBlock <$> block <|>
    -- assertions
    (endSemi $ do 
        tok KW_Assert
        e   <- exp
        me2 <- opt $ colon >> exp
        return $ Assert e me2) <|>
    -- switch stmts
    (do tok KW_Switch
        e  <- parens exp
        sb <- switchBlock
        return $ Switch e sb) <|>
    -- do-while loops
    (endSemi $ do 
        tok KW_Do
        s <- stmt
        tok KW_While
        e <- parens exp
        return $ Do s e) <|>
    -- break
    (endSemi $ do
        tok KW_Break
        mi <- opt ident
        return $ Break mi) <|>
    -- continue
    (endSemi $ do
        tok KW_Continue
        mi <- opt ident
        return $ Continue mi) <|>
    -- return
    (endSemi $ do
        tok KW_Return
        me <- opt exp
        return $ Return me) <|>
    -- synchronized
    (do tok KW_Synchronized
        e <- parens exp
        b <- block
        return $ Synchronized e b) <|>
    -- throw
    (endSemi $ do
        tok KW_Throw
        e <- exp
        return $ Throw e) <|>
    -- try-catch, both with and without a finally clause
    (do tok KW_Try
        b <- block
        c <- list catch
        mf <- opt $ tok KW_Finally >> block
        -- TODO: here we should check that there exists at
        -- least one catch or finally clause
        return $ Try b c mf) <|>
    -- Paragon
    -- opening a lock
    (do tok KW_P_Open
        lc <- lock
        (try block >>= (\bl -> return (OpenBlock lc bl)) <|> semiColon >> return (Open lc))) <|>
    -- closing a lock
    (do
        tok KW_P_Close
        lc <- lock
        {- (try block >>= (\bl -> return (CloseBlock lc bl)) <|> -}
        semiColon >> return (Close lc)) <|>

    -- expressions as stmts
    ExpStmt <$> endSemi stmtExp

-- For loops

forInit :: P ForInit
forInit = (do
    (m,t,vds) <- localVarDecl
    return $ ForLocalVars m t vds) <|>
    seplist1 stmtExp comma >>= return . ForInitExps

forUp :: P [Exp]
forUp = seplist1 stmtExp comma

-- Switches

switchBlock :: P [SwitchBlock]
switchBlock = braces $ list switchStmt

switchStmt :: P SwitchBlock
switchStmt = do
    lbl <- switchLabel
    bss <- list blockStmt
    return $ SwitchBlock lbl bss

switchLabel :: P SwitchLabel
switchLabel = tok KW_Default >> colon >> return Default <|> 
    (do tok KW_Case 
        e <- exp 
        colon
        return $ SwitchCase e)

-- Try-catch clauses

catch :: P Catch
catch = do
    tok KW_Catch
    fp <- parens formalParam
    b  <- block
    return $ Catch fp b

----------------------------------------------------------------------------
-- Expressions

stmtExp :: P Exp
stmtExp = try preIncDec
    <|> try postIncDec
    <|> try assignment
    -- There are sharing gains to be made by unifying these two
    <|> try instanceCreation
    <|> methodInvocationExp

preIncDec :: P Exp
preIncDec = do
    op <- preIncDecOp
    e <- unaryExp
    return $ op e

postIncDec :: P Exp
postIncDec = do
    e <- postfixExpNES
    ops <- list1 postfixOp
    return $ foldl (\a s -> s a) e ops

assignment :: P Exp
assignment = do
    lh <- lhs
    op <- assignOp
    e  <- assignExp
    return $ Assign lh op e

lhs :: P Lhs
lhs = try (FieldLhs <$> fieldAccess)
    <|> try (ArrayLhs <$> arrayAccess)
    <|> NameLhs <$> name



exp :: P Exp
exp = assignExp

assignExp :: P Exp
assignExp = try assignment <|> condExp

condExp :: P Exp
condExp = do
    ie <- infixExp
    ces <- list condExpSuffix
    return $ foldl (\a s -> s a) ie ces

condExpSuffix :: P (Exp -> Exp)
condExpSuffix = do
    tok Op_Query
    th <- exp
    colon
    el <- condExp
    return $ \ce -> Cond ce th el

infixExp :: P Exp
infixExp = do
    ue <- unaryExp
    ies <- list infixExpSuffix
    return $ foldl (\a s -> s a) ue ies

infixExpSuffix :: P (Exp -> Exp)
infixExpSuffix =
    (do op <- infixOp
        e2 <- unaryExp
        return $ \e1 -> BinOp e1 op e2) <|> 
    (do tok KW_Instanceof
        t  <- refType
        return $ \e1 -> InstanceOf e1 t)
    
unaryExp :: P Exp
unaryExp = try preIncDec <|>
    try (do
        op <- prefixOp
        ue <- unaryExp
        return $ op ue) <|>
    try (do
        t <- parens ttype
        e <- unaryExp
        return $ Cast t e) <|>
    postfixExp

postfixExpNES :: P Exp
postfixExpNES = -- try postIncDec <|>
    try primary <|>
    ExpName <$> name

postfixExp :: P Exp
postfixExp = do 
    pe <- postfixExpNES
    ops <- list postfixOp
    return $ foldl (\a s -> s a) pe ops
    

primary :: P Exp
primary = primaryNPS |>> primarySuffix

primaryNPS :: P Exp
primaryNPS = try arrayCreation <|> primaryNoNewArrayNPS

primaryNoNewArray = startSuff primaryNoNewArrayNPS primarySuffix

primaryNoNewArrayNPS :: P Exp
primaryNoNewArrayNPS = 
    Lit <$> literal <|>
    const This <$> tok KW_This <|>
    Paren <$> parens exp <|> 
    PolicyExp <$> policyExp <|>
--    PolicyOf  <$> (tok KW_P_Policyof >> ident) <|>
    LockExp <$> (tok Op_Query >> lock) <|>
    -- TODO: These two following should probably be merged more
    (try $ do 
        rt <- resultType 
        period >> tok KW_Class
        return $ ClassLit rt) <|>
    (try $ do 
        n <- name
        period >> tok KW_This
        return $ ThisClass n) <|>
    try instanceCreationNPS <|>
    try (MethodInv <$> methodInvocationNPS) <|>
    try (FieldAccess <$> fieldAccessNPS) <|>
    ArrayAccess <$> arrayAccessNPS

primarySuffix :: P (Exp -> Exp)
primarySuffix = try instanceCreationSuffix <|>
    try ((ArrayAccess .) <$> arrayAccessSuffix) <|>
    try ((MethodInv .) <$> methodInvocationSuffix) <|>
    (FieldAccess .) <$> fieldAccessSuffix


instanceCreationNPS :: P Exp
instanceCreationNPS = 
    do tok KW_New
       tas <- lopt typeArgs
       ct  <- classType
       as  <- args
       mcb <- opt classBody
       return $ InstanceCreation tas ct as mcb

instanceCreationSuffix :: P (Exp -> Exp)
instanceCreationSuffix =
     do period >> tok KW_New
        tas <- lopt typeArgs
        i   <- ident
        as  <- args
        mcb <- opt classBody
        return $ \p -> QualInstanceCreation p tas i as mcb

instanceCreation :: P Exp
instanceCreation = try instanceCreationNPS <|> do
    p <- primaryNPS
    ss <- list primarySuffix
    let icp = foldl (\a s -> s a) p ss
    case icp of
     QualInstanceCreation {} -> return icp
     _ -> fail ""

{- 
instanceCreation = 
    (do tok KW_New
        tas <- lopt typeArgs
        ct  <- classType
        as  <- args
        mcb <- opt classBody
        return $ InstanceCreation tas ct as mcb) <|>
    (do p   <- primary
        period >> tok KW_New
        tas <- lopt typeArgs
        i   <- ident
        as  <- args
        mcb <- opt classBody
        return $ QualInstanceCreation p tas i as mcb) 
-}

fieldAccessNPS :: P FieldAccess
fieldAccessNPS =
    (do tok KW_Super >> period
        i <- ident
        return $ SuperFieldAccess i) <|>
    (do n <- name
        period >> tok KW_Super >> period
        i <- ident
        return $ ClassFieldAccess n i)    

fieldAccessSuffix :: P (Exp -> FieldAccess)
fieldAccessSuffix = do
    period
    i <- ident
    return $ \p -> PrimaryFieldAccess p i

fieldAccess :: P FieldAccess
fieldAccess = try fieldAccessNPS <|> do
    p <- primaryNPS
    ss <- list primarySuffix
    let fap = foldl (\a s -> s a) p ss
    case fap of
     FieldAccess fa -> return fa
     _ -> fail ""

{-
fieldAccess :: P FieldAccess
fieldAccess = try fieldAccessNPS <|> do
    p <- primary
    fs <- fieldAccessSuffix 
    return (fs p)
-}

{-
fieldAccess :: P FieldAccess
fieldAccess =
    (do tok KW_Super >> period
        i <- ident
        return $ SuperFieldAccess i) <|>
    (try $ do
        n <- name
        period >> tok KW_Super >> period
        i <- ident
        return $ ClassFieldAccess n i) <|>
    (do p <- primary
        period
        i <- ident
        return $ PrimaryFieldAccess p i) 
-}

methodInvocationNPS :: P MethodInvocation
methodInvocationNPS =
    (do tok KW_Super >> period
        rts <- lopt nonWildTypeArgs
        i   <- ident
        as  <- args
        return $ SuperMethodCall rts i as) <|>
    (do n <- name
        f <- (do as <- args
                 return $ \n -> MethodCall n as) <|>
             (period >> do
                msp <- opt (tok KW_Super >> period)
                rts <- lopt nonWildTypeArgs
                i   <- ident
                as  <- args
                let mc = maybe TypeMethodCall (const ClassMethodCall) msp
                return $ \n -> mc n rts i as)
        return $ f n)

methodInvocationSuffix :: P (Exp -> MethodInvocation)
methodInvocationSuffix = do
        period
        rts <- lopt nonWildTypeArgs
        i   <- ident
        as  <- args
        return $ \p -> PrimaryMethodCall p [] i as

methodInvocationExp :: P Exp
methodInvocationExp = try (MethodInv <$> methodInvocationNPS) <|> do
    p <- primaryNPS
    ss <- list primarySuffix
    let mip = foldl (\a s -> s a) p ss
    case mip of
     MethodInv _ -> return mip
     _ -> fail ""

{-
methodInvocation :: P MethodInvocation
methodInvocation =
    (do tok KW_Super >> period
        rts <- lopt nonWildTypeArgs
        i   <- ident
        as  <- args
        return $ SuperMethodCall rts i as) <|>
    (do p <- primary
        period
        rts <- lopt nonWildTypeArgs
        i   <- ident
        as  <- args
        return $ PrimaryMethodCall p rts i as) <|>
    (do n <- name
        f <- (do as <- args
                 return $ \n -> MethodCall n as) <|>
             (period >> do
                msp <- opt (tok KW_Super >> period)
                rts <- lopt nonWildTypeArgs
                i   <- ident
                as  <- args
                let mc = maybe TypeMethodCall (const ClassMethodCall) msp
                return $ \n -> mc n rts i as)
        return $ f n)
-}

args :: P [Argument]
args = parens $ seplist exp comma

-- Arrays

arrayAccessNPS :: P ArrayIndex
arrayAccessNPS = do
    n <- name
    e <- brackets exp
    return $ ArrayIndex (ExpName n) e

arrayAccessSuffix :: P (Exp -> ArrayIndex)
arrayAccessSuffix = do
    e <- brackets exp
    return $ \ref -> ArrayIndex ref e
    
arrayAccess = try arrayAccessNPS <|> do
    p <- primaryNoNewArrayNPS
    ss <- list primarySuffix
    let aap = foldl (\a s -> s a) p ss
    case aap of
     ArrayAccess ain -> return ain
     _ -> fail ""

{-
arrayAccess :: P (Exp, Exp)
arrayAccess = do
    ref <- arrayRef
    e   <- brackets exp
    return (ref, e)

arrayRef :: P Exp
arrayRef = ExpName <$> name <|> primaryNoNewArray
-}

arrayCreation :: P Exp
arrayCreation = do
    tok KW_New
    t <- nonArrayType
    f <- (try $ do
             ds <- list1 $ brackets empty
             ai <- arrayInit
             return $ \t -> ArrayCreateInit t (length ds) ai) <|> 
         (do des <- list1 $ brackets exp
             ds  <- list  $ brackets empty
             return $ \t -> ArrayCreate t des (length ds))
    return $ f t

literal :: P Literal
literal = 
    javaToken $ \t -> case t of
        IntTok     i -> Just (Int i)
        LongTok    l -> Just (Word l)
        DoubleTok  d -> Just (Double d)
        FloatTok   f -> Just (Float f)
        CharTok    c -> Just (Char c)
        StringTok  s -> Just (String s)
        BoolTok    b -> Just (Boolean b)
        NullTok      -> Just Null
        _ -> Nothing

-- Operators

preIncDecOp, prefixOp, postfixOp :: P (Exp -> Exp)
preIncDecOp =
    (tok Op_PPlus >> return PreIncrement) <|> 
    (tok Op_MMinus >> return PreDecrement)
prefixOp = 
    (tok Op_Bang  >> return PreNot      ) <|>
    (tok Op_Tilde >> return PreBitCompl ) <|>
    (tok Op_Plus  >> return PrePlus     ) <|>
    (tok Op_Minus >> return PreMinus    )
postfixOp =
    (tok Op_PPlus  >> return PostIncrement) <|>
    (tok Op_MMinus >> return PostDecrement)

assignOp :: P AssignOp
assignOp =
    (tok Op_Equal    >> return EqualA   ) <|>
    (tok Op_StarE    >> return MultA    ) <|>
    (tok Op_SlashE   >> return DivA     ) <|>
    (tok Op_PercentE >> return RemA     ) <|>
    (tok Op_PlusE    >> return AddA     ) <|>
    (tok Op_MinusE   >> return SubA     ) <|>
    (tok Op_LShiftE  >> return LShiftA  ) <|>
    (tok Op_RShiftE  >> return RShiftA  ) <|>
    (tok Op_RRShiftE >> return RRShiftA ) <|>
    (tok Op_AndE     >> return AndA     ) <|>
    (tok Op_CaretE   >> return XorA     ) <|>
    (tok Op_OrE      >> return OrA      )

infixOp :: P Op
infixOp =
    (tok Op_Star    >> return Mult      ) <|>
    (tok Op_Slash   >> return Div       ) <|>
    (tok Op_Percent >> return Rem       ) <|>
    (tok Op_Plus    >> return Add       ) <|>
    (tok Op_Minus   >> return Sub       ) <|>
    (tok Op_LShift  >> return LShift    ) <|>
    (tok Op_RShift  >> return RShift    ) <|>
    (tok Op_RRShift >> return RRShift   ) <|>
    (tok Op_LThan   >> return LThan     ) <|>
    (tok Op_GThan   >> return GThan     ) <|>
    (tok Op_LThanE  >> return LThanE    ) <|>
    (tok Op_GThanE  >> return GThanE    ) <|>
    (tok Op_Equals  >> return Equal     ) <|>
    (tok Op_BangE   >> return NotEq     ) <|>
    (tok Op_And     >> return And       ) <|>
    (tok Op_Caret   >> return Xor       ) <|>
    (tok Op_Or      >> return Or        ) <|>
    (tok Op_AAnd    >> return CAnd      ) <|>
    (tok Op_OOr     >> return COr       )


----------------------------------------------------------------------------
-- Types

ttype :: P Type
ttype = try (RefType <$> refType) <|> PrimType <$> primType

primType :: P PrimType
primType =
    tok KW_Boolean >> return BooleanT  <|>
    tok KW_Byte    >> return ByteT     <|>
    tok KW_Short   >> return ShortT    <|>
    tok KW_Int     >> return IntT      <|>
    tok KW_Long    >> return LongT     <|>
    tok KW_Char    >> return CharT     <|>
    tok KW_Float   >> return FloatT    <|>
    tok KW_Double  >> return DoubleT   
    -- Paragon
     <|> tok KW_P_Actor  >> return ActorT
     <|> tok KW_P_Policy >> return PolicyT
    
refType :: P RefType
refType =
    (do pt <- primType
        (mp:mps) <- list1 arrPols
        return $ foldl (\f mp -> flip ArrayType mp . RefType . f) 
                        (flip ArrayType mp . PrimType) mps pt) <|>
    (do ct <- classType
        mps <- list arrPols
        return $ foldl (\f mp -> flip ArrayType mp . RefType . f)
                            ClassRefType mps ct) <?> "refType"

arrPols :: P (Maybe Policy)
arrPols = do
  _ <- arrBrackets
  opt $ ExpName <$> angles name

nonArrayType :: P Type
nonArrayType = PrimType <$> primType <|> 
    RefType <$> ClassRefType <$> classType

classType :: P ClassType
classType = ClassType <$> seplist1 classTypeSpec period

classTypeSpec :: P (Ident, [TypeArgument])
classTypeSpec = do
    i   <- ident
    tas <- lopt typeArgs
    return (i, tas)

resultType :: P (Maybe Type)
resultType = tok KW_Void >> return Nothing <|> Just <$> ttype <?> "resultType"

refTypeList :: P [RefType]
refTypeList = seplist1 refType comma

----------------------------------------------------------------------------
-- Type parameters and arguments

typeParams :: P [TypeParam]
typeParams = angles $ seplist1 typeParam comma

typeParam :: P TypeParam
typeParam = 
  (do tok KW_P_Actor >> ActorParam <$> ident) <|>
  (do tok KW_P_Policy >> PolicyParam <$> ident) <|>
  (do tok KW_P_Lock >> arrBrackets >> LockStateParam <$> ident) <|>
  (do i  <- ident
      bs <- lopt bounds
      return $ TypeParam i bs)

bounds :: P [RefType]
bounds = tok KW_Extends >> seplist1 refType (tok Op_And)

typeArgs :: P [TypeArgument]
typeArgs = angles $ seplist1 typeArg comma

typeArg :: P TypeArgument
typeArg = tok Op_Query >> Wildcard <$> opt wildcardBound
      <|> ActualArg <$> nonWildTypeArg

nonWildTypeArg :: P NonWildTypeArgument
nonWildTypeArg = ActualLockState <$> (tok KW_P_Lock >> arrBrackets >> lockExp) <|>
                 -- TODO: UGLY HACK
                 ActualPolicy . ExpName <$> (tok KW_P_Policy >> name) <|>
                 ActualActor <$> (tok KW_P_Actor >> name) <|>
                 ActualType <$> refType

wildcardBound :: P WildcardBound
wildcardBound = tok KW_Extends >> ExtendsBound <$> refType
    <|> tok KW_Super >> SuperBound <$> refType

nonWildTypeArgs :: P [NonWildTypeArgument]
nonWildTypeArgs = angles $ seplist nonWildTypeArg (tok Comma)

----------------------------------------------------------------------------
-- Names

name :: P Name
name = Name <$> seplist1 ident period

ident :: P Ident
ident = javaToken $ \t -> case t of
    IdentTok s -> Just $ Ident s
    _ -> Nothing

----------------------------------------------------------------------------
-- Policies

policy :: P Policy
policy = postfixExpNES -- Policy <$> policyLit <|> PolicyRef <$> (tok Op_Tilde >> name)

policyExp :: P PolicyExp
policyExp = PolicyLit <$> (braces $ seplist (clause actor) semiColon) <|>
            PolicyOf  <$> (tok KW_P_Policyof >> parens ident)

clause :: P a -> P (Clause a)
clause headC = do
    h <- headC
    as <- lopt $ colon >> seplist atom comma
    return $ Clause h as

atom :: P Atom
atom = do
    n   <- name
    ps  <- lopt $ parens $ seplist actor comma
    return $ Atom n ps

actor :: P Actor
actor = Actor <$> actorName <|> Var <$> actorVar -- (tok Op_Query >> ident)

actorName :: P ActorName
actorName = ActorName <$> name

actorVar :: P Ident
actorVar = javaToken $ \t -> case t of
    VarActorTok s -> Just $ Ident s
    _ -> Nothing

lock :: P Lock
lock = do
    n <- name
    as <- lopt $ parens $ seplist actorName comma
    return $ Lock n as

lockProperties :: P LockProperties
lockProperties = braces $ LockProperties <$> optendseplist (clause atom) semiColon

lockExp :: P [Lock]
lockExp = parens (seplist1 lock (tok Comma)) 
      <|> return . LockVar <$> ident


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

empty :: P ()
empty = return ()

opt :: P a -> P (Maybe a)
opt pa = --optionMaybe
  try (Just <$> pa) <|> return Nothing

bopt :: P a -> P Bool
bopt p = opt p >>= \ma -> return $ isJust ma

lopt :: P [a] -> P [a]
lopt p = do mas <- opt p
            case mas of
             Nothing -> return []
             Just as -> return as

list :: P a -> P [a]
list = option [] . list1

list1 :: P a -> P [a]
list1 = many1

seplist :: P a -> P sep -> P [a]
--seplist = sepBy
seplist p sep = option [] $ seplist1 p sep

seplist1 :: P a -> P sep -> P [a]
--seplist1 = sepBy1
seplist1 p sep = 
    p >>= \a -> 
        try (do sep
                as <- seplist1 p sep
                return (a:as)) 
        <|> return [a]

optendseplist :: P a -> P sep -> P [a]
optendseplist p sep = seplist p sep `optend` sep

optend :: P a -> P end -> P a
optend p end = do
  x <- p
  _ <- opt end
  return x

startSuff, (|>>) :: P a -> P (a -> a) -> P a
startSuff start suffix = do
    x <- start
    ss <- list suffix
    return $ foldl (\a s -> s a) x ss

(|>>) = startSuff

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

javaToken :: (Token -> Maybe a) -> P a
javaToken test = token showT posT testT
  where showT (L _ t) = show t
        posT  (L p _) = pos2sourcePos p
        testT (L _ t) = test t

tok, matchToken :: Token -> P ()
tok = matchToken
matchToken t = javaToken (\r -> if r == t then Just () else Nothing)

pos2sourcePos :: (Int, Int) -> SourcePos
pos2sourcePos (l,c) = newPos "" l c

type Mod a = [Modifier] -> a

parens, braces, brackets, angles :: P a -> P a
parens   = between (tok OpenParen)  (tok CloseParen)
braces   = between (tok OpenCurly)  (tok CloseCurly)
brackets = between (tok OpenSquare) (tok CloseSquare)
angles   = between (tok Op_LThan)   (tok Op_GThan)

endSemi :: P a -> P a
endSemi p = p >>= \a -> semiColon >> return a

comma, colon, semiColon, period :: P ()
comma     = tok Comma
colon     = tok Op_Colon
semiColon = tok SemiColon
period    = tok Period

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

test = "public class Foo { }"

checkConstrs :: ClassDecl -> P ()
checkConstrs (ClassDecl _ i _ _ _ cb) = do
    let errs = [ ci | ConstructorDecl _ _ ci _ _ _ <- universeBi cb, ci /= i ]
    if null errs then return () 
     else fail $ "Declaration of class " ++ prettyPrint i 
                  ++ " cannot contain constructor with name " 
                  ++ prettyPrint (head errs)
    

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

-- Generalization is only needed for parameters of 
-- kind Type, since these are representated by a
-- special contructor TypeVariable.
-- LockStateVar is handled by the parser, NO LONGER
-- and actors and policies are parsed as ExpName.
generalize :: Data a => [TypeParam] -> a -> a
generalize pars = transformBi gen
                  . transformBi genA
                  . transformBi genP
                  . transformBi genL
    where gen :: RefType -> RefType
          gen (ClassRefType (ClassType [(i, [])])) 
              | i `elem` parIs = TypeVariable i
          gen rt = rt

          genA :: ActorName -> ActorName
          genA (ActorName (Name [i]))
               | i `elem` actIs = ActorTypeVar i
          genA a = a

          genP :: Exp -> Exp
          genP (ExpName (Name [i])) 
              | i `elem` polIs = PolicyExp (PolicyTypeVar i)
          genP e = e

          genL :: Lock -> Lock
          genL (Lock (Name [i]) [])
              | i `elem` locIs = LockVar i
--          genL (Lock n as) = Lock n $ 
          genL l = l

          parIs = [ i | TypeParam i _ <- pars ]
          locIs = [ i | LockStateParam i <- pars ]
          actIs = [ i | ActorParam i <- pars ]
          polIs = [ i | PolicyParam i <- pars ]

-- Instantiation is needed for all four kinds.
instantiate :: Data a => [(TypeParam,TypeArgument)] -> a -> a
instantiate pas = transformBi instT 
                  . transformBi instA 
                  . transformBi instP 
                  . transformBi instLs
    where instT :: RefType -> RefType
          instT tv@(TypeVariable i) =
              case lookup i typs of
                Just rt -> rt
                Nothing -> tv
          instT rt = rt
          instA :: ActorName -> ActorName
          instA a@(ActorName (Name [i])) =
              case lookup i as of
                Just n -> ActorName n
                _ -> a
          instA a = a

          instP :: Exp -> Exp
          instP p@(ExpName (Name [i])) =
              case lookup i ps of
                Just p -> p
                _ -> p
          instP p = p

          instLs :: [Lock] -> [Lock]
          instLs = concatMap instL

          instL :: Lock -> [Lock]
          instL lv@(LockVar i) =
              case lookup i lps of
                Just le -> le
                Nothing -> [lv]
          instL le = [le]

          nameOfType (ClassRefType (ClassType iArgs)) = 
              let (is, args) = unzip iArgs
               in if all null args
                   then Just $ Name $ foldr (:) [] is
                   else Nothing



          typs = [ (i,rt) | (TypeParam i _,    ActualArg (ActualType      rt)) <- pas ]
          as   = [ (i,n)  | (ActorParam  i,    ActualArg (ActualActor     n )) <- pas ]
          ps   = [ (i,p)  | (PolicyParam i,    ActualArg (ActualPolicy    p )) <- pas ]
          lps  = [ (i,le) | (LockStateParam i, ActualArg (ActualLockState le)) <- pas ]