{-# LANGUAGE CPP, PatternGuards #-}
module Language.Java.Paragon.Parser (
    parser, 
    
    compilationUnit, packageDecl, importDecl, typeDecl,
    
    classDecl, interfaceDecl,

    memberDecl, fieldDecl, methodDecl, constrDecl,
    interfaceMemberDecl, absMethodDecl, lockDecl,


    methodBody, formalParams, formalParam,
    
    modifier,
    
    varDecls, varDecl, varInit, arrayInit,
    
    block, blockStmt, stmt,
    
    stmtExp, exp, primary, literal, lhs,
    
    ttype, primType, refType, classType, resultType,
    
    typeParams, typeParam,
    
    name, ident,
    
    policy, policyExp, clause, actor, atom, lock, lockProperties,
    
    
    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 = unMod $
    (do cd <- classDeclM
        checkConstrs (cd [])
        return $ \ms -> ClassTypeDecl () (cd ms)) <|>
    (do id <- interfaceDeclM
        return $ \ms -> InterfaceTypeDecl () (id ms))

classDeclM :: P (Mod (ClassDecl ()))
classDeclM = normalClassDeclM <|> enumClassDeclM

-- Not called internally:
-- | Top-level parser for class declarations
classDecl :: P (ClassDecl ())
classDecl = unMod classDeclM

unMod :: P (Mod a) -> P a
unMod pma = do
  ms <- list modifier
  pa <- pma
  return $ pa ms

normalClassDeclM :: P (Mod (ClassDecl ()))
normalClassDeclM = 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

enumClassDeclM :: P (Mod (ClassDecl ()))
enumClassDeclM = 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

-- Not used internally:
-- | Top-level parser for interface declarations
interfaceDecl :: P (InterfaceDecl ())
interfaceDecl = unMod interfaceDeclM

interfaceDeclM :: P (Mod (InterfaceDecl ()))
interfaceDeclM = {- trace "interfaceDeclM" $ -} 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 <- memberDeclM
        return $ MemberDecl () (dec ms))
    
-- Not used internally:
-- | Top-level parser for member declarations
memberDecl :: P (MemberDecl ())
memberDecl = unMod memberDeclM

memberDeclM :: P (Mod (MemberDecl ()))
memberDeclM = {- trace "memberDeclM" $ -}
    (try $ do 
        cd  <- classDeclM
        return $ \ms -> MemberClassDecl () (cd ms)) <|>
    (try $ do 
        id  <- interfaceDeclM
        return $ \ms -> MemberInterfaceDecl () (id ms)) <|> 
    try fieldDeclM <|>
    lockDeclM <|>        -- Paragon
--    policyDeclM <|>      -- Paragon
    try methodDeclM <|> 
    constrDeclM

-- Not used internally:
-- | Top-level parser for field declarations
fieldDecl :: P (MemberDecl ())
fieldDecl = unMod fieldDeclM

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

-- Not used internally:
-- | Top-level parser for method declarations
methodDecl :: P (MemberDecl ())
methodDecl = unMod methodDeclM

methodDeclM :: P (Mod (MemberDecl ()))
methodDeclM = 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)

-- Not used internally:
-- | Top-level parser for constructor declarations
constrDecl :: P (MemberDecl ())
constrDecl = unMod constrDeclM

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

-- Not used internally:
-- | Top-level parser for lock declarations
lockDecl :: P (MemberDecl ())
lockDecl = unMod lockDeclM

lockDeclM :: P (Mod (MemberDecl ()))
lockDeclM = 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

{-
policyDeclM :: P (Mod MemberDecl)
policyDeclM = 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 <- interfaceMemberDeclM
       return $ Just (imd ms)
    
-- Not used internally:
-- | Top-level parser for interface member declarations
interfaceMemberDecl :: P (MemberDecl ())
interfaceMemberDecl = unMod interfaceMemberDeclM

interfaceMemberDeclM :: P (Mod (MemberDecl ()))
interfaceMemberDeclM =
    (do cd  <- classDeclM
        return $ \ms -> MemberClassDecl () (cd ms)) <|>
    (do id  <- interfaceDeclM
        return $ \ms -> MemberInterfaceDecl () (id ms)) <|> 
    try fieldDeclM <|> 
    lockDeclM <|>
    absMethodDeclM

-- Not used internally:
-- | Top-level parser for abstract method declarations
absMethodDecl :: P (MemberDecl ())
absMethodDecl = unMod absMethodDeclM

absMethodDeclM :: P (Mod (MemberDecl ()))
absMethodDeclM = 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_Symmetric   >> return (Symmetric  ())
    <|> 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  <- classDeclM
        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 <|>
    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 <|>
    AntiQExp () <$> 
      javaToken (\t -> 
          case t of
            AntiQExpTok s -> Just s
            _ -> Nothing)

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
     InstanceCreation     {} -> return icp
     QualInstanceCreation {} -> return icp
     _ -> fail "instanceCreation"

{- 
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 :: P (ArrayIndex ())
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 >> opt (angles policy))
             ai <- arrayInit
             return $ \t -> ArrayCreateInit () t ds ai) <|> 
         (do des <- list1 $ do
                      e <- brackets exp
                      p <- opt (angles policy)
                      return (e,p)
             ds  <- list  $ (brackets empty >> opt (angles policy))
             return $ \t -> ArrayCreate () t des 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 
         <|> AntiQType () <$> 
               javaToken (\t -> 
                   case t of
                     AntiQTypeTok s -> Just $ s
                     _ -> Nothing)

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
        mps <- list1 arrPols
        return $ ArrayType () (PrimType () pt) mps)
    <|>
    (do ct <- classType
        mps <- list arrPols
        let baseType = ClassRefType () ct
        case mps of
          [] -> return baseType
          _  -> return $ ArrayType () (RefType () baseType) mps) <?> "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 <|>
         javaToken (\t -> case t of
          AntiQNameTok s -> Just $ AntiQName () s
          _ -> Nothing)

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

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

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

policyExp :: P (PolicyExp ())
policyExp = try (PolicyLit () <$> (braces $ seplist clause semiColon)) <|>
            PolicyLit () <$> (braces colon >> return []) <|>
            tok KW_P_Policyof >> 
                parens (PolicyOf () <$> ident <|>
                        const (PolicyThis ()) <$> tok KW_This)
--            PolicyOf  () <$> (tok KW_P_Policyof >> parens ident)

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

lclause :: P (LClause ())
lclause = do
    h <- atom
    as <- lopt $ colon >> seplist atom comma
    return $ LClause () 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 lclause semiColon

lockExp :: P [Lock ()]
lockExp = parens (seplist1 lock comma) 
      <|> return <$> lock


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

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 ]