{-# LANGUAGE CPP, PatternGuards, TupleSections #-}
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, returnType,

    typeParams, typeParam,
    
    name, ident, 
    nameRaw, ambName, eName, tName, pName, pOrTName, mOrLName,
    flattenName,
    
    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 (prettyPrint)
import Language.Java.Paragon.Interaction
import Language.Java.Paragon.Monad.Base

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

import Prelude hiding ( exp, catch, (>>), (>>=) )
import qualified Prelude as P ( (>>), (>>=) ) 
import qualified Data.ByteString.Char8 as B
import Data.Maybe ( isJust, catMaybes, fromJust )
--import Control.Monad ( ap )
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)

parserModule :: String
parserModule = libraryBase ++ ".Parser"

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.
(>>) :: Monad m => m a -> m b -> m b
(>>) = (P.>>)
(>>=) :: Monad m => m a -> (a -> m b) -> m b
(>>=) = (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 a -> String -> Either ParseError a
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 <- nameRaw pName
    semiColon
    return $ PackageDecl () n
    
importDecl :: P (ImportDecl ())
importDecl = do
    tok KW_Import
    st <- bopt $ tok KW_Static
    n  <- nameRaw ambName
    ds <- bopt $ period >> tok Op_Star
    semiColon
    return $ mkImportDecl st ds n

  where mkImportDecl False False n 
            = SingleTypeImport () $ flattenRealName tName n
        mkImportDecl False True  n 
            = TypeImportOnDemand () $ flattenRealName pOrTName n
        mkImportDecl True  True  n 
            = StaticImportOnDemand () $ flattenRealName tName n
        mkImportDecl True  False n@(Name{}) = 
            let is = flattenName n
            in case reverse is of
                 [] -> panic (parserModule ++ ".importDecl") "Empty name"
                 (lastI:initN) -> 
                     SingleStaticImport () 
                       (tName $ reverse initN) lastI
        mkImportDecl _ _ _ 
            = error $ "Single static import declaration \
                      \requires at least one non-antiquote ident"

        flattenRealName rebuild n@(Name{}) = rebuild $ flattenName n
        flattenRealName _ n = n

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

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

-- Class declarations

classOrInterfaceDecl :: P (TypeDecl ())
classOrInterfaceDecl = unMod $
    (do cdecl <- classDeclM
        checkConstrs (cdecl [])
        return $ \ms -> ClassTypeDecl () (cdecl ms)) <|>
    (do idecl <- interfaceDeclM
        return $ \ms -> InterfaceTypeDecl () (idecl 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 [ClassType ()]
extends = tok KW_Extends >> classTypeList

implements :: P [ClassType ()]
implements = tok KW_Implements >> classTypeList

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
    i   <- ident
    as  <- lopt args
    mcb <- opt classBody
    return $ EnumConstant () i 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
    i   <- ident
    tps <- lopt typeParams
    exs <- lopt extends
    bod <- interfaceBody
    return $ \ms -> 
        generalize tps $ InterfaceDecl () ms i 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 
        idecl  <- interfaceDeclM
        return $ \ms -> MemberInterfaceDecl () (idecl 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  <- returnType
    i   <- ident
    fps <- formalParams
    thr <- lopt throws
    bod <- methodBody
    return $ \ms -> 
        generalize tps $ MethodDecl () ms tps rt i 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
    i   <- ident
    fps <- formalParams
    thr <- lopt throws
    bod <- constrBody
    return $ \ms -> 
        generalize tps $ ConstructorDecl () ms tps i 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 idecl  <- interfaceDeclM
        return $ \ms -> MemberInterfaceDecl () (idecl 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  <- returnType
    i   <- ident
    fps <- formalParams
    thr <- lopt throws
    semiColon
    return $ \ms -> 
        generalize tps $ MethodDecl () ms tps rt i 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 && validateFPs xs

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_Readonly    >> return (Readonly   ())
    <|> 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
    i  <- ident
    bs <- list arrBrackets
    return $ foldl (\f _ -> VarDeclArray () . f) (VarId ()) bs i

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 = (try $ do
    (m,t,vds) <- localVarDecl
    return $ ForLocalVars () m t vds) <|>
    ForInitExps () <$> seplist1 stmtExp comma

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 () <$> nameRaw eName



exp :: P (Exp ())
exp = assignExp

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

condExp :: P (Exp ())
condExp = do
    ie <- fixPrecs <$> infixExp -- TODO: precedence resolution
    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 () <$> nameRaw eOrLName

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 :: P (Exp ())
--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 <- returnType 
        mt <- checkClassLit rt
        period >> tok KW_Class
        return $ ClassLit () mt) <|>
    (try $ do 
        n <- nameRaw tName
        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)

checkClassLit :: ReturnType () -> P (Maybe (Type ()))
checkClassLit (LockType ()) = fail "Lock is not a class type!"
checkClassLit (VoidType ()) = return Nothing
checkClassLit (Type _ t)    = return $ Just t
                                           

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 <- nameRaw tName
        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 ""

fieldAccessExp :: P (Exp ())
fieldAccessExp = FieldAccess () <$> fieldAccess

{-
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 <- nameRaw ambName
        f <- (do as <- args
                 return $ \na -> MethodCallOrLockQuery () (mOrLName $ flattenName na) as) <|>
             (period >> do
                msp <- opt (tok KW_Super >> period)
                rts <- lopt nonWildTypeArgs
                i   <- ident
                as  <- args
                let mc = maybe (TypeMethodCall ()) (const (ClassMethodCall ())) msp
                return $ \na -> mc (tName $ flattenName na) rts i as)
        return $ f n)

methodInvocationSuffix :: P (Exp () -> MethodInvocation ())
methodInvocationSuffix = do
        period
        rts <- lopt nonWildTypeArgs
        i   <- ident
        as  <- args
        return $ \p -> PrimaryMethodCall () p rts 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 <- nameRaw eName
    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 argExp))
             ai <- arrayInit
             return $ \ty -> ArrayCreateInit () ty ds ai) <|> 
         (do des <- list1 $ do
                      e <- brackets exp
                      p <- opt (angles argExp)
                      return (e,p)
             ds  <- list  $ (brackets empty >> opt (angles argExp))
             return $ \ty -> ArrayCreate () ty 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       ()))

typeArgInfixOp :: P (Op ())
typeArgInfixOp = 
    (tok Op_Star >> return (Mult ())) <|> 
    (tok Op_Plus >> return (Add  ()))


----------------------------------------------------------------------------
-- 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 = checkNoExtraEnd refTypeE

refTypeE :: P (RefType (), Int)
refTypeE = {- trace "refTypeE" -} (
    (do pt <- primType
        mps <- list1 arrPols
        return $ (ArrayType () (PrimType () pt) mps, 0))
    <|>
    (do (ct, e) <- classTypeE
        let baseType = ClassRefType () ct
        if (e == 0)
         then do
           mps <- list arrPols
           case mps of
             [] -> return (baseType, e)
             _  -> return $ (ArrayType () (RefType () baseType) mps, 0)
         else return (baseType, e)
    ) <?> "refType")

arrPols :: P (Maybe (Policy ()))
arrPols = do
  _ <- arrBrackets
  opt $ angles argExp
--  ExpName () <$> angles (nameRaw eName)
--      <|> PolicyExp () <$> policyExp

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


classType :: P (ClassType ())
classType = checkNoExtraEnd classTypeE

classTypeE :: P (ClassType (), Int)
classTypeE = {- trace "classTypeE" $ -} do
  n <- nameRaw tName
  mtase <- opt typeArgsE
  {- trace ("mtase: " ++ show mtase) $ -}
  case mtase of
    Just (tas, e) -> return (ClassType () n tas, e)
    Nothing       -> return (ClassType () n [] , 0)

returnType :: P (ReturnType ())
returnType = tok KW_Void   >> return (VoidType ()) <|> 
             tok KW_P_Lock >> return (LockType ()) <|>
             Type () <$> ttype <?> "returnType"

classTypeList :: P [ClassType ()]
classTypeList = seplist1 classType 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)

checkNoExtraEnd :: P (a, Int) -> P a
checkNoExtraEnd pai = do
  (a, e) <- pai
  check (e == 0) "Unexpected >"
  return a

typeArgs :: P [TypeArgument ()]
typeArgs = {- trace "typeArgs" $ -} checkNoExtraEnd typeArgsE

typeArgsE :: P ([TypeArgument ()], Int)
typeArgsE = {- trace "typeArgsE" $ -}
    do tok Op_LThan {- < -}
       (as, extra) <- typeArgsSuffix
       return (as, extra-1)

typeArgsSuffix :: P ([TypeArgument ()], Int)
typeArgsSuffix = {- trace "typeArgsSuffix" $ -}
  (do tok Op_Query
      wcArg <- Wildcard () <$> opt wildcardBound
      (rest, e) <- typeArgsEnd 0
      return $ (wcArg:rest, e)) <|>
  (do lArg <- ActualArg () <$> parens (ActualLockState () <$> seplist1 lock comma)
      (rest, e) <- typeArgsEnd 0
      return (lArg:rest, e)) <|>
  (try $ do (rt, er)  <- refTypeE
            (rest, e) <- typeArgsEnd er
            let tArg = case nameOfRefType rt of
                         Just n -> ActualName () $ ambName $ flattenName n -- keep as ambiguous
                         _ -> ActualType () rt
            return $ (ActualArg () tArg:rest, e)) <|>
  (do eArg <- ActualArg () . ActualExp () <$> argExp
      (rest, e) <- typeArgsEnd 0
      return (eArg:rest, e))

      where nameOfRefType :: RefType () -> Maybe (Name ())
            nameOfRefType (ClassRefType _ (ClassType _ n tas)) =
                if null tas then Just n else Nothing
            nameOfRefType _ = Nothing

typeArgsEnd :: Int -> P ([TypeArgument ()], Int) -- Int for the number of "extra" >
typeArgsEnd n | n > 0 = {- trace ("typeArgsEnd-1: " ++ show n) $ -} return ([], n)
typeArgsEnd _ = {- trace ("typeArgsEnd-2: ") $ -}
    (tok Op_GThan   {- >   -} >> return ([], 1)) <|>
    (tok Op_RShift  {- >>  -} >> return ([], 2)) <|>
    (tok Op_RRShift {- >>> -} >> return ([], 3)) <|>
    (tok Comma >> typeArgsSuffix)

argExp :: P (Exp ())
argExp = do
  e1 <- argExp1
  fe <- argExpSuffix
  return $ fe e1

argExp1 :: P (Exp ())
argExp1 = PolicyExp () <$> policyExp 
          <|> try methodInvocationExp
          <|> try fieldAccessExp
          <|> ExpName () <$> nameRaw eName

argExpSuffix :: P (Exp () -> Exp ())
argExpSuffix = 
    (do op <- typeArgInfixOp
        e2 <- argExp
        return $ \e1 -> BinOp () e1 op e2) <|> return id

{-
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 = typeArgs >>= mapM checkNonWild
  where checkNonWild (ActualArg _ arg) = return arg
        checkNonWild _ = fail "Use of wildcard in non-wild context"


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

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

nameRaw :: ([Ident ()] -> Name ()) -> P (Name ())
nameRaw nf = 
    nf <$> seplist1 ident period <|>
        javaToken (\t -> case t of
          AntiQNameTok s -> Just $ AntiQName () s
          _ -> Nothing)

name :: P (Name ())
name = nameRaw ambName

ident :: P (Ident ())
ident = javaToken $ \t -> case t of
    IdentTok s -> Just $ Ident () $ B.pack 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   <- nameRaw lName
    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 () <$> nameRaw eName

actorVar :: P (Ident ())
actorVar = javaToken $ \t -> case t of
    VarActorTok s -> Just $ Ident () $ B.pack s
    _ -> Nothing

lock :: P (Lock ())
lock = do
    n <- nameRaw lName
    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

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

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)
checkConstrs _ = panic (parserModule ++ ".checkConstrs")
                 "Checking constructors of Enum decl"

-----------------------------------------------------
-- Making the meaning of a name explicit

ambName :: [Ident a] -> Name a
ambName = mkUniformName_ AmbName

-- A package name can only have a package name prefix
pName :: [Ident a] -> Name a
pName = mkUniformName_ PName

-- A package-or-type name has a package-or-type prefix
pOrTName :: [Ident a] -> Name a
pOrTName = mkUniformName_ POrTName

-- A type name has a package-or-type prefix
tName :: [Ident a] -> Name a
tName = mkName_ TName POrTName

-- Names with ambiguous prefixes
eName, lName, eOrLName, mOrLName :: [Ident a] -> Name a
eName = mkName_ EName AmbName
lName = mkName_ LName AmbName
eOrLName = mkName_ EOrLName AmbName
mOrLName = mkName_ MOrLName AmbName


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


-- 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 _ (Name _ TName Nothing i) [])) 
              | i `elem` parIs = TypeVariable () i
          gen rt = rt

          genA :: ActorName () -> ActorName ()
          genA (ActorName _ (Name _ EName Nothing i))
               | i `elem` actIs = ActorTypeVar () i
          genA a = a

          genP :: Exp () -> Exp ()
          genP (ExpName _ (Name _ EName Nothing i)) 
              | i `elem` polIs = PolicyExp () (PolicyTypeVar () i)
          genP e = e

          genL :: Lock () -> Lock ()
          genL (Lock () (Name _ LName Nothing i) [])
              | i `elem` locIs = LockVar () i
          genL l = l

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

--------------------------------------------------------------
-- Resolving precedences

builtInPrecs :: [(Op (), Int)]
builtInPrecs = 
    map (,9) [Mult   (), Div    (), Rem     ()           ] ++
    map (,8) [Add    (), Sub    ()                       ] ++
    map (,7) [LShift (), RShift (), RRShift ()           ] ++
    map (,6) [LThan  (), GThan  (), LThanE  (), GThanE ()] ++
    map (,5) [Equal  (), NotEq  ()                       ] ++
    [(And  (), 4), 
     (Or   (), 3), 
     (Xor  (), 2), 
     (CAnd (), 1), 
     (COr  (), 0)]

instanceOfPrec :: Int
instanceOfPrec = 6 -- same as comparison ops

fixPrecs :: Exp () -> Exp ()
fixPrecs (BinOp _ a op2 z) =
    let e = fixPrecs a -- recursively fix left subtree
        getPrec op = fromJust $ lookup op builtInPrecs
        fixup p1 p2 y pre =
            if p1 >= p2 
             then BinOp () e op2 z -- already right order
             else pre (fixPrecs $ BinOp () y op2 z)
    in case e of
         BinOp _ x op1 y   -> fixup (getPrec op1)  (getPrec op2) y (BinOp () x op1)
         InstanceOf _ y rt -> fixup instanceOfPrec (getPrec op2) y (flip (InstanceOf ()) rt)
         _ -> BinOp () e op2 z
fixPrecs e = e