paragon-0.1.28: src/Language/Java/Paragon/Parser.hs
{-# 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