paragon-0.1.7: src/Language/Java/Paragon/Parser.hs
{-# LANGUAGE CPP, PatternGuards #-}
module Language.Java.Paragon.Parser (
parser,
compilationUnit, packageDecl, importDecl, typeDecl,
classDecl, interfaceDecl,
memberDecl, fieldDecl, methodDecl, constrDecl,
interfaceMemberDecl, absMethodDecl,methodBody,
formalParams, formalParam,
modifier,
varDecls, varDecl, varInit, arrayInit,
block, blockStmt, stmt,
stmtExp, exp, primary, literal,
ttype, primType, refType, classType, resultType,
typeParams, typeParam,
name, ident,
policy, policyExp, clause, actor, atom,
empty, list, list1, seplist, seplist1, opt, bopt, lopt,
comma, semiColon, period, colon,
ParseError
) where
import Language.Java.Paragon.Lexer ( L(..), Token(..), lexer)
import Language.Java.Paragon.Syntax
import Language.Java.Paragon.Pretty
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Pos
import Prelude hiding ( exp, catch, (>>), (>>=) )
import qualified Prelude as P ( (>>), (>>=) )
import Data.Maybe ( isJust, catMaybes )
import Control.Monad ( ap, liftM )
import Control.Applicative ( (<$>) )
import Control.Arrow ( first )
import Data.Generics.Uniplate.Data
#ifdef BASE4
import Data.Data
#else
import Data.Generics (Data(..),Typeable(..))
#endif
-- import Debug.Trace (trace)
type P = GenParser (L Token) ()
-- A trick to allow >> and >>=, normally infixr 1, to be
-- used inside branches of <|>, which is declared as infixl 1.
-- There are no clashes with other operators of precedence 2.
(>>) = (P.>>)
(>>=) = (P.>>=)
infixr 2 >>, >>=
-- Note also when reading that <$> is infixl 4 and thus has
-- lower precedence than all the others (>>, >>=, and <|>).
-- Since I cba to find the instance Monad m => Applicative m declaration.
(<*>) :: Monad m => m (a -> b) -> m a -> m b
(<*>) = ap
----------------------------------------------------------------------------
-- Top-level parsing
parseCompilationUnit :: String -> Either ParseError CompilationUnit
parseCompilationUnit inp =
runParser compilationUnit () "" (lexer inp)
parser p = runParser p () "" . lexer
----------------------------------------------------------------------------
-- Packages and compilation units
compilationUnit :: P CompilationUnit
compilationUnit = do
mpd <- opt packageDecl
ids <- list importDecl
tds <- list typeDecl
return $ CompilationUnit mpd ids (catMaybes tds)
packageDecl :: P PackageDecl
packageDecl = do
tok KW_Package
n <- name
semiColon
return $ PackageDecl n
importDecl :: P ImportDecl
importDecl = do
tok KW_Import
st <- bopt $ tok KW_Static
n <- name
ds <- bopt $ period >> tok Op_Star
semiColon
return $ ImportDecl st n ds
typeDecl :: P (Maybe TypeDecl)
typeDecl = Just <$> classOrInterfaceDecl <|>
const Nothing <$> semiColon
----------------------------------------------------------------------------
-- Declarations
-- Class declarations
classOrInterfaceDecl :: P TypeDecl
classOrInterfaceDecl = do
ms <- list modifier
de <- (do cd <- classDecl
checkConstrs (cd [])
return $ \ms -> ClassTypeDecl (cd ms)) <|>
(do id <- interfaceDecl
return $ \ms -> InterfaceTypeDecl (id ms))
return $ de ms
classDecl :: P (Mod ClassDecl)
classDecl = normalClassDecl <|> enumClassDecl
normalClassDecl :: P (Mod ClassDecl)
normalClassDecl = do
tok KW_Class
i <- ident
tps <- lopt typeParams
mex <- opt extends
imp <- lopt implements
bod <- classBody
return $ \ms ->
generalize tps $ ClassDecl ms i tps ((fmap head) mex) imp bod
extends :: P [RefType]
extends = tok KW_Extends >> refTypeList
implements :: P [RefType]
implements = tok KW_Implements >> refTypeList
enumClassDecl :: P (Mod ClassDecl)
enumClassDecl = do
tok KW_Enum
i <- ident
imp <- lopt implements
bod <- enumBody
return $ \ms -> EnumDecl ms i imp bod
classBody :: P ClassBody
classBody = ClassBody <$> braces classBodyDecls
enumBody :: P EnumBody
enumBody = braces $ do
ecs <- seplist enumConst comma
optional comma
eds <- lopt enumBodyDecls
return $ EnumBody ecs eds
enumConst :: P EnumConstant
enumConst = do
id <- ident
as <- lopt args
mcb <- opt classBody
return $ EnumConstant id as mcb
enumBodyDecls :: P [Decl]
enumBodyDecls = semiColon >> classBodyDecls
classBodyDecls :: P [Decl]
classBodyDecls = list classBodyDecl
-- Interface declarations
interfaceDecl :: P (Mod InterfaceDecl)
interfaceDecl = {- trace "interfaceDecl" $ -} do
tok KW_Interface
id <- ident
tps <- lopt typeParams
exs <- lopt extends
bod <- interfaceBody
return $ \ms ->
generalize tps $ InterfaceDecl ms id tps exs bod
interfaceBody :: P InterfaceBody
interfaceBody = InterfaceBody . catMaybes <$>
braces (list interfaceBodyDecl)
-- Declarations
classBodyDecl :: P Decl
classBodyDecl =
(try $ do
mst <- bopt (tok KW_Static)
blk <- block
return $ InitDecl mst blk) <|>
(do ms <- list modifier
dec <- memberDecl
return $ MemberDecl (dec ms))
memberDecl :: P (Mod MemberDecl)
memberDecl = {- trace "memberDecl" $ -}
(try $ do
cd <- classDecl
return $ \ms -> MemberClassDecl (cd ms)) <|>
(try $ do
id <- interfaceDecl
return $ \ms -> MemberInterfaceDecl (id ms)) <|>
try fieldDecl <|>
lockDecl <|> -- Paragon
-- policyDecl <|> -- Paragon
try methodDecl <|>
constrDecl
fieldDecl :: P (Mod MemberDecl)
fieldDecl = endSemi $ do
typ <- ttype
vds <- varDecls
return $ \ms -> FieldDecl ms typ vds
methodDecl :: P (Mod MemberDecl)
methodDecl = do
tps <- lopt typeParams
rt <- resultType
id <- ident
fps <- formalParams
thr <- lopt throws
bod <- methodBody
return $ \ms ->
generalize tps $ MethodDecl ms tps rt id fps thr bod
methodBody :: P MethodBody
methodBody = MethodBody <$>
(const Nothing <$> semiColon <|> Just <$> block)
constrDecl :: P (Mod MemberDecl)
constrDecl = do
tps <- lopt typeParams
id <- ident
fps <- formalParams
thr <- lopt throws
bod <- constrBody
return $ \ms ->
generalize tps $ ConstructorDecl ms tps id fps thr bod
lockDecl :: P (Mod MemberDecl)
lockDecl = endSemi $ do
tok KW_P_Lock
lc <- ident
ar <- lopt arity
lp <- opt lockProperties
return $ \ms -> LockDecl ms lc ar lp
arity :: P [Maybe Ident]
arity = parens $ seplist ({- tok Op_Query >> -} opt ident) comma
{-
policyDecl :: P (Mod MemberDecl)
policyDecl = endSemi $ do
tok KW_P_Policy
pn <- ident
tok Op_Equal
pol <- policy
return $ \ms -> PolicyDecl ms pn pol
-}
constrBody :: P ConstructorBody
constrBody = braces $ do
mec <- opt (try explConstrInv)
bss <- list blockStmt
return $ ConstructorBody mec bss
explConstrInv :: P ExplConstrInv
explConstrInv = endSemi $
(try $ do
tas <- lopt nonWildTypeArgs
tok KW_This
as <- args
return $ ThisInvoke tas as) <|>
(try $ do
tas <- lopt nonWildTypeArgs
tok KW_Super
as <- args
return $ SuperInvoke tas as) <|>
(do pri <- primary
period
tas <- lopt nonWildTypeArgs
tok KW_Super
as <- args
return $ PrimarySuperInvoke pri tas as)
-- TODO: This should be parsed like class bodies, and post-checked.
-- That would give far better error messages.
interfaceBodyDecl :: P (Maybe MemberDecl)
interfaceBodyDecl = semiColon >> return Nothing <|>
do ms <- list modifier
imd <- interfaceMemberDecl
return $ Just (imd ms)
interfaceMemberDecl :: P (Mod MemberDecl)
interfaceMemberDecl =
(do cd <- classDecl
return $ \ms -> MemberClassDecl (cd ms)) <|>
(do id <- interfaceDecl
return $ \ms -> MemberInterfaceDecl (id ms)) <|>
try fieldDecl <|>
lockDecl <|>
absMethodDecl
absMethodDecl :: P (Mod MemberDecl)
absMethodDecl = do
tps <- lopt typeParams
rt <- resultType
id <- ident
fps <- formalParams
thr <- lopt throws
semiColon
return $ \ms ->
generalize tps $ MethodDecl ms tps rt id fps thr (MethodBody Nothing)
throws :: P [ExceptionSpec]
throws = tok KW_Throws >> seplist1 exceptionSpec comma
exceptionSpec :: P ExceptionSpec
exceptionSpec = do
--mp <- opt policy
mods <- list modifier
rt <- refType
return $ ExceptionSpec mods rt
-- Formal parameters
formalParams :: P [FormalParam]
formalParams = parens $ do
fps <- seplist formalParam comma
if validateFPs fps
then return fps
else fail "Only the last formal parameter may be of variable arity"
where validateFPs :: [FormalParam] -> Bool
validateFPs [] = True
validateFPs [_] = True
validateFPs (FormalParam _ _ b _ :xs) = not b
formalParam :: P FormalParam
formalParam = do
ms <- list modifier
typ <- ttype
var <- bopt ellipsis
vid <- varDeclId
return $ FormalParam ms typ var vid
ellipsis :: P ()
ellipsis = period >> period >> period
-- Modifiers
modifier :: P Modifier
modifier =
tok KW_Public >> return Public
<|> tok KW_Protected >> return Protected
<|> tok KW_Private >> return Private
<|> tok KW_Abstract >> return Abstract
<|> tok KW_Static >> return Static
<|> tok KW_Strictfp >> return StrictFP
<|> tok KW_Final >> return Final
<|> tok KW_Native >> return Native
<|> tok KW_Transient >> return Transient
<|> tok KW_Volatile >> return Volatile
<|> tok KW_P_Typemethod >> return Typemethod
<|> tok KW_P_Reflexive >> return Reflexive
<|> tok KW_P_Transitive >> return Transitive
<|> tok KW_P_Commutative >> return Commutative
<|> tok Op_Query >> policy >>= return . Reads
<|> tok Op_Bang >> policy >>= return . Writes
<|> tok Op_Plus >> lockExp >>= return . Opens
<|> tok Op_Minus >> lockExp >>= return . Closes
<|> tok Op_Tilde >> lockExp >>= return . Expects
----------------------------------------------------------------------------
-- Variable declarations
varDecls :: P [VarDecl]
varDecls = seplist1 varDecl comma
varDecl :: P VarDecl
varDecl = do
vid <- varDeclId
mvi <- opt $ tok Op_Equal >> varInit
return $ VarDecl vid mvi
varDeclId :: P VarDeclId
varDeclId = do
id <- ident
abs <- list arrBrackets
return $ foldl (\f _ -> VarDeclArray . f) VarId abs id
arrBrackets :: P ()
arrBrackets = brackets $ return ()
localVarDecl :: P ([Modifier], Type, [VarDecl])
localVarDecl = do
ms <- list modifier
typ <- ttype
vds <- varDecls
return (ms, typ, vds)
varInit :: P VarInit
varInit =
try (InitArray <$> arrayInit) <|>
InitExp <$> exp
arrayInit :: P ArrayInit
arrayInit = braces $ do
vis <- seplist varInit comma
opt comma
return $ ArrayInit vis
----------------------------------------------------------------------------
-- Statements
block :: P Block
block = braces $ Block <$> list blockStmt
blockStmt :: P BlockStmt
blockStmt =
(try $ do
ms <- list modifier
cd <- classDecl
return $ LocalClass (cd ms)) <|>
(try $ do
(m,t,vds) <- endSemi $ localVarDecl
return $ LocalVars m t vds) <|>
(try $ endSemi $ do
ms <- list modifier
tok KW_P_Lock
lc <- ident
ar <- lopt arity
lp <- opt lockProperties
return $ LocalLock ms lc ar lp) <|>
{- (try $ endSemi $ do
ms <- list modifier
tok KW_P_Policy
ln <- ident
tok Op_Equal
pol <- policy
return $ LocalPolicy ms ln pol) <|> -}
BlockStmt <$> stmt
stmt :: P Stmt
stmt =
-- ifThen and ifThenElse, with a common prefix
(do tok KW_If
e <- parens exp
(try $
do th <- stmtNSI
tok KW_Else
el <- stmt
return $ IfThenElse e th el) <|>
(do th <- stmt
return $ IfThen e th)) <|>
-- while loops
(do tok KW_While
e <- parens exp
s <- stmt
return $ While e s) <|>
-- basic and enhanced for
(do tok KW_For
f <- parens $
(try $ do
fi <- opt forInit
semiColon
e <- opt exp
semiColon
fu <- opt forUp
return $ BasicFor fi e fu) <|>
(do ms <- list modifier
t <- ttype
i <- ident
colon
e <- exp
return $ EnhancedFor ms t i e)
s <- stmt
return $ f s) <|>
-- labeled statements
(try $ do
lbl <- ident
colon
s <- stmt
return $ Labeled lbl s) <|>
-- the rest
stmtNoTrail
stmtNSI :: P Stmt
stmtNSI =
-- if statements - only full ifThenElse
(do tok KW_If
e <- parens exp
th <- stmtNSI
tok KW_Else
el <- stmtNSI
return $ IfThenElse e th el) <|>
-- while loops
(do tok KW_While
e <- parens exp
s <- stmtNSI
return $ While e s) <|>
-- for loops, both basic and enhanced
(do tok KW_For
f <- parens $ (try $ do
fi <- opt forInit
semiColon
e <- opt exp
semiColon
fu <- opt forUp
return $ BasicFor fi e fu)
<|> (do
ms <- list modifier
t <- ttype
i <- ident
colon
e <- exp
return $ EnhancedFor ms t i e)
s <- stmtNSI
return $ f s) <|>
-- labeled stmts
(try $ do
i <- ident
colon
s <- stmtNSI
return $ Labeled i s) <|>
-- the rest
stmtNoTrail
stmtNoTrail :: P Stmt
stmtNoTrail =
-- empty statement
const Empty <$> semiColon <|>
-- inner block
StmtBlock <$> block <|>
-- assertions
(endSemi $ do
tok KW_Assert
e <- exp
me2 <- opt $ colon >> exp
return $ Assert e me2) <|>
-- switch stmts
(do tok KW_Switch
e <- parens exp
sb <- switchBlock
return $ Switch e sb) <|>
-- do-while loops
(endSemi $ do
tok KW_Do
s <- stmt
tok KW_While
e <- parens exp
return $ Do s e) <|>
-- break
(endSemi $ do
tok KW_Break
mi <- opt ident
return $ Break mi) <|>
-- continue
(endSemi $ do
tok KW_Continue
mi <- opt ident
return $ Continue mi) <|>
-- return
(endSemi $ do
tok KW_Return
me <- opt exp
return $ Return me) <|>
-- synchronized
(do tok KW_Synchronized
e <- parens exp
b <- block
return $ Synchronized e b) <|>
-- throw
(endSemi $ do
tok KW_Throw
e <- exp
return $ Throw e) <|>
-- try-catch, both with and without a finally clause
(do tok KW_Try
b <- block
c <- list catch
mf <- opt $ tok KW_Finally >> block
-- TODO: here we should check that there exists at
-- least one catch or finally clause
return $ Try b c mf) <|>
-- Paragon
-- opening a lock
(do tok KW_P_Open
lc <- lock
(try block >>= (\bl -> return (OpenBlock lc bl)) <|> semiColon >> return (Open lc))) <|>
-- closing a lock
(do
tok KW_P_Close
lc <- lock
{- (try block >>= (\bl -> return (CloseBlock lc bl)) <|> -}
semiColon >> return (Close lc)) <|>
-- expressions as stmts
ExpStmt <$> endSemi stmtExp
-- For loops
forInit :: P ForInit
forInit = (do
(m,t,vds) <- localVarDecl
return $ ForLocalVars m t vds) <|>
seplist1 stmtExp comma >>= return . ForInitExps
forUp :: P [Exp]
forUp = seplist1 stmtExp comma
-- Switches
switchBlock :: P [SwitchBlock]
switchBlock = braces $ list switchStmt
switchStmt :: P SwitchBlock
switchStmt = do
lbl <- switchLabel
bss <- list blockStmt
return $ SwitchBlock lbl bss
switchLabel :: P SwitchLabel
switchLabel = tok KW_Default >> colon >> return Default <|>
(do tok KW_Case
e <- exp
colon
return $ SwitchCase e)
-- Try-catch clauses
catch :: P Catch
catch = do
tok KW_Catch
fp <- parens formalParam
b <- block
return $ Catch fp b
----------------------------------------------------------------------------
-- Expressions
stmtExp :: P Exp
stmtExp = try preIncDec
<|> try postIncDec
<|> try assignment
-- There are sharing gains to be made by unifying these two
<|> try instanceCreation
<|> methodInvocationExp
preIncDec :: P Exp
preIncDec = do
op <- preIncDecOp
e <- unaryExp
return $ op e
postIncDec :: P Exp
postIncDec = do
e <- postfixExpNES
ops <- list1 postfixOp
return $ foldl (\a s -> s a) e ops
assignment :: P Exp
assignment = do
lh <- lhs
op <- assignOp
e <- assignExp
return $ Assign lh op e
lhs :: P Lhs
lhs = try (FieldLhs <$> fieldAccess)
<|> try (ArrayLhs <$> arrayAccess)
<|> NameLhs <$> name
exp :: P Exp
exp = assignExp
assignExp :: P Exp
assignExp = try assignment <|> condExp
condExp :: P Exp
condExp = do
ie <- infixExp
ces <- list condExpSuffix
return $ foldl (\a s -> s a) ie ces
condExpSuffix :: P (Exp -> Exp)
condExpSuffix = do
tok Op_Query
th <- exp
colon
el <- condExp
return $ \ce -> Cond ce th el
infixExp :: P Exp
infixExp = do
ue <- unaryExp
ies <- list infixExpSuffix
return $ foldl (\a s -> s a) ue ies
infixExpSuffix :: P (Exp -> Exp)
infixExpSuffix =
(do op <- infixOp
e2 <- unaryExp
return $ \e1 -> BinOp e1 op e2) <|>
(do tok KW_Instanceof
t <- refType
return $ \e1 -> InstanceOf e1 t)
unaryExp :: P Exp
unaryExp = try preIncDec <|>
try (do
op <- prefixOp
ue <- unaryExp
return $ op ue) <|>
try (do
t <- parens ttype
e <- unaryExp
return $ Cast t e) <|>
postfixExp
postfixExpNES :: P Exp
postfixExpNES = -- try postIncDec <|>
try primary <|>
ExpName <$> name
postfixExp :: P Exp
postfixExp = do
pe <- postfixExpNES
ops <- list postfixOp
return $ foldl (\a s -> s a) pe ops
primary :: P Exp
primary = primaryNPS |>> primarySuffix
primaryNPS :: P Exp
primaryNPS = try arrayCreation <|> primaryNoNewArrayNPS
primaryNoNewArray = startSuff primaryNoNewArrayNPS primarySuffix
primaryNoNewArrayNPS :: P Exp
primaryNoNewArrayNPS =
Lit <$> literal <|>
const This <$> tok KW_This <|>
Paren <$> parens exp <|>
PolicyExp <$> policyExp <|>
-- PolicyOf <$> (tok KW_P_Policyof >> ident) <|>
LockExp <$> (tok Op_Query >> lock) <|>
-- TODO: These two following should probably be merged more
(try $ do
rt <- resultType
period >> tok KW_Class
return $ ClassLit rt) <|>
(try $ do
n <- name
period >> tok KW_This
return $ ThisClass n) <|>
try instanceCreationNPS <|>
try (MethodInv <$> methodInvocationNPS) <|>
try (FieldAccess <$> fieldAccessNPS) <|>
ArrayAccess <$> arrayAccessNPS
primarySuffix :: P (Exp -> Exp)
primarySuffix = try instanceCreationSuffix <|>
try ((ArrayAccess .) <$> arrayAccessSuffix) <|>
try ((MethodInv .) <$> methodInvocationSuffix) <|>
(FieldAccess .) <$> fieldAccessSuffix
instanceCreationNPS :: P Exp
instanceCreationNPS =
do tok KW_New
tas <- lopt typeArgs
ct <- classType
as <- args
mcb <- opt classBody
return $ InstanceCreation tas ct as mcb
instanceCreationSuffix :: P (Exp -> Exp)
instanceCreationSuffix =
do period >> tok KW_New
tas <- lopt typeArgs
i <- ident
as <- args
mcb <- opt classBody
return $ \p -> QualInstanceCreation p tas i as mcb
instanceCreation :: P Exp
instanceCreation = try instanceCreationNPS <|> do
p <- primaryNPS
ss <- list primarySuffix
let icp = foldl (\a s -> s a) p ss
case icp of
QualInstanceCreation {} -> return icp
_ -> fail ""
{-
instanceCreation =
(do tok KW_New
tas <- lopt typeArgs
ct <- classType
as <- args
mcb <- opt classBody
return $ InstanceCreation tas ct as mcb) <|>
(do p <- primary
period >> tok KW_New
tas <- lopt typeArgs
i <- ident
as <- args
mcb <- opt classBody
return $ QualInstanceCreation p tas i as mcb)
-}
fieldAccessNPS :: P FieldAccess
fieldAccessNPS =
(do tok KW_Super >> period
i <- ident
return $ SuperFieldAccess i) <|>
(do n <- name
period >> tok KW_Super >> period
i <- ident
return $ ClassFieldAccess n i)
fieldAccessSuffix :: P (Exp -> FieldAccess)
fieldAccessSuffix = do
period
i <- ident
return $ \p -> PrimaryFieldAccess p i
fieldAccess :: P FieldAccess
fieldAccess = try fieldAccessNPS <|> do
p <- primaryNPS
ss <- list primarySuffix
let fap = foldl (\a s -> s a) p ss
case fap of
FieldAccess fa -> return fa
_ -> fail ""
{-
fieldAccess :: P FieldAccess
fieldAccess = try fieldAccessNPS <|> do
p <- primary
fs <- fieldAccessSuffix
return (fs p)
-}
{-
fieldAccess :: P FieldAccess
fieldAccess =
(do tok KW_Super >> period
i <- ident
return $ SuperFieldAccess i) <|>
(try $ do
n <- name
period >> tok KW_Super >> period
i <- ident
return $ ClassFieldAccess n i) <|>
(do p <- primary
period
i <- ident
return $ PrimaryFieldAccess p i)
-}
methodInvocationNPS :: P MethodInvocation
methodInvocationNPS =
(do tok KW_Super >> period
rts <- lopt nonWildTypeArgs
i <- ident
as <- args
return $ SuperMethodCall rts i as) <|>
(do n <- name
f <- (do as <- args
return $ \n -> MethodCall n as) <|>
(period >> do
msp <- opt (tok KW_Super >> period)
rts <- lopt nonWildTypeArgs
i <- ident
as <- args
let mc = maybe TypeMethodCall (const ClassMethodCall) msp
return $ \n -> mc n rts i as)
return $ f n)
methodInvocationSuffix :: P (Exp -> MethodInvocation)
methodInvocationSuffix = do
period
rts <- lopt nonWildTypeArgs
i <- ident
as <- args
return $ \p -> PrimaryMethodCall p [] i as
methodInvocationExp :: P Exp
methodInvocationExp = try (MethodInv <$> methodInvocationNPS) <|> do
p <- primaryNPS
ss <- list primarySuffix
let mip = foldl (\a s -> s a) p ss
case mip of
MethodInv _ -> return mip
_ -> fail ""
{-
methodInvocation :: P MethodInvocation
methodInvocation =
(do tok KW_Super >> period
rts <- lopt nonWildTypeArgs
i <- ident
as <- args
return $ SuperMethodCall rts i as) <|>
(do p <- primary
period
rts <- lopt nonWildTypeArgs
i <- ident
as <- args
return $ PrimaryMethodCall p rts i as) <|>
(do n <- name
f <- (do as <- args
return $ \n -> MethodCall n as) <|>
(period >> do
msp <- opt (tok KW_Super >> period)
rts <- lopt nonWildTypeArgs
i <- ident
as <- args
let mc = maybe TypeMethodCall (const ClassMethodCall) msp
return $ \n -> mc n rts i as)
return $ f n)
-}
args :: P [Argument]
args = parens $ seplist exp comma
-- Arrays
arrayAccessNPS :: P ArrayIndex
arrayAccessNPS = do
n <- name
e <- brackets exp
return $ ArrayIndex (ExpName n) e
arrayAccessSuffix :: P (Exp -> ArrayIndex)
arrayAccessSuffix = do
e <- brackets exp
return $ \ref -> ArrayIndex ref e
arrayAccess = try arrayAccessNPS <|> do
p <- primaryNoNewArrayNPS
ss <- list primarySuffix
let aap = foldl (\a s -> s a) p ss
case aap of
ArrayAccess ain -> return ain
_ -> fail ""
{-
arrayAccess :: P (Exp, Exp)
arrayAccess = do
ref <- arrayRef
e <- brackets exp
return (ref, e)
arrayRef :: P Exp
arrayRef = ExpName <$> name <|> primaryNoNewArray
-}
arrayCreation :: P Exp
arrayCreation = do
tok KW_New
t <- nonArrayType
f <- (try $ do
ds <- list1 $ brackets empty
ai <- arrayInit
return $ \t -> ArrayCreateInit t (length ds) ai) <|>
(do des <- list1 $ brackets exp
ds <- list $ brackets empty
return $ \t -> ArrayCreate t des (length ds))
return $ f t
literal :: P Literal
literal =
javaToken $ \t -> case t of
IntTok i -> Just (Int i)
LongTok l -> Just (Word l)
DoubleTok d -> Just (Double d)
FloatTok f -> Just (Float f)
CharTok c -> Just (Char c)
StringTok s -> Just (String s)
BoolTok b -> Just (Boolean b)
NullTok -> Just Null
_ -> Nothing
-- Operators
preIncDecOp, prefixOp, postfixOp :: P (Exp -> Exp)
preIncDecOp =
(tok Op_PPlus >> return PreIncrement) <|>
(tok Op_MMinus >> return PreDecrement)
prefixOp =
(tok Op_Bang >> return PreNot ) <|>
(tok Op_Tilde >> return PreBitCompl ) <|>
(tok Op_Plus >> return PrePlus ) <|>
(tok Op_Minus >> return PreMinus )
postfixOp =
(tok Op_PPlus >> return PostIncrement) <|>
(tok Op_MMinus >> return PostDecrement)
assignOp :: P AssignOp
assignOp =
(tok Op_Equal >> return EqualA ) <|>
(tok Op_StarE >> return MultA ) <|>
(tok Op_SlashE >> return DivA ) <|>
(tok Op_PercentE >> return RemA ) <|>
(tok Op_PlusE >> return AddA ) <|>
(tok Op_MinusE >> return SubA ) <|>
(tok Op_LShiftE >> return LShiftA ) <|>
(tok Op_RShiftE >> return RShiftA ) <|>
(tok Op_RRShiftE >> return RRShiftA ) <|>
(tok Op_AndE >> return AndA ) <|>
(tok Op_CaretE >> return XorA ) <|>
(tok Op_OrE >> return OrA )
infixOp :: P Op
infixOp =
(tok Op_Star >> return Mult ) <|>
(tok Op_Slash >> return Div ) <|>
(tok Op_Percent >> return Rem ) <|>
(tok Op_Plus >> return Add ) <|>
(tok Op_Minus >> return Sub ) <|>
(tok Op_LShift >> return LShift ) <|>
(tok Op_RShift >> return RShift ) <|>
(tok Op_RRShift >> return RRShift ) <|>
(tok Op_LThan >> return LThan ) <|>
(tok Op_GThan >> return GThan ) <|>
(tok Op_LThanE >> return LThanE ) <|>
(tok Op_GThanE >> return GThanE ) <|>
(tok Op_Equals >> return Equal ) <|>
(tok Op_BangE >> return NotEq ) <|>
(tok Op_And >> return And ) <|>
(tok Op_Caret >> return Xor ) <|>
(tok Op_Or >> return Or ) <|>
(tok Op_AAnd >> return CAnd ) <|>
(tok Op_OOr >> return COr )
----------------------------------------------------------------------------
-- Types
ttype :: P Type
ttype = try (RefType <$> refType) <|> PrimType <$> primType
primType :: P PrimType
primType =
tok KW_Boolean >> return BooleanT <|>
tok KW_Byte >> return ByteT <|>
tok KW_Short >> return ShortT <|>
tok KW_Int >> return IntT <|>
tok KW_Long >> return LongT <|>
tok KW_Char >> return CharT <|>
tok KW_Float >> return FloatT <|>
tok KW_Double >> return DoubleT
-- Paragon
<|> tok KW_P_Actor >> return ActorT
<|> tok KW_P_Policy >> return PolicyT
refType :: P RefType
refType =
(do pt <- primType
(mp:mps) <- list1 arrPols
return $ foldl (\f mp -> flip ArrayType mp . RefType . f)
(flip ArrayType mp . PrimType) mps pt) <|>
(do ct <- classType
mps <- list arrPols
return $ foldl (\f mp -> flip ArrayType mp . RefType . f)
ClassRefType mps ct) <?> "refType"
arrPols :: P (Maybe Policy)
arrPols = do
_ <- arrBrackets
opt $ ExpName <$> angles name
nonArrayType :: P Type
nonArrayType = PrimType <$> primType <|>
RefType <$> ClassRefType <$> classType
classType :: P ClassType
classType = ClassType <$> seplist1 classTypeSpec period
classTypeSpec :: P (Ident, [TypeArgument])
classTypeSpec = do
i <- ident
tas <- lopt typeArgs
return (i, tas)
resultType :: P (Maybe Type)
resultType = tok KW_Void >> return Nothing <|> Just <$> ttype <?> "resultType"
refTypeList :: P [RefType]
refTypeList = seplist1 refType comma
----------------------------------------------------------------------------
-- Type parameters and arguments
typeParams :: P [TypeParam]
typeParams = angles $ seplist1 typeParam comma
typeParam :: P TypeParam
typeParam =
(do tok KW_P_Actor >> ActorParam <$> ident) <|>
(do tok KW_P_Policy >> PolicyParam <$> ident) <|>
(do tok KW_P_Lock >> arrBrackets >> LockStateParam <$> ident) <|>
(do i <- ident
bs <- lopt bounds
return $ TypeParam i bs)
bounds :: P [RefType]
bounds = tok KW_Extends >> seplist1 refType (tok Op_And)
typeArgs :: P [TypeArgument]
typeArgs = angles $ seplist1 typeArg comma
typeArg :: P TypeArgument
typeArg = tok Op_Query >> Wildcard <$> opt wildcardBound
<|> ActualArg <$> nonWildTypeArg
nonWildTypeArg :: P NonWildTypeArgument
nonWildTypeArg = ActualLockState <$> (tok KW_P_Lock >> arrBrackets >> lockExp) <|>
-- TODO: UGLY HACK
ActualPolicy . ExpName <$> (tok KW_P_Policy >> name) <|>
ActualActor <$> (tok KW_P_Actor >> name) <|>
ActualType <$> refType
wildcardBound :: P WildcardBound
wildcardBound = tok KW_Extends >> ExtendsBound <$> refType
<|> tok KW_Super >> SuperBound <$> refType
nonWildTypeArgs :: P [NonWildTypeArgument]
nonWildTypeArgs = angles $ seplist nonWildTypeArg (tok Comma)
----------------------------------------------------------------------------
-- Names
name :: P Name
name = Name <$> seplist1 ident period
ident :: P Ident
ident = javaToken $ \t -> case t of
IdentTok s -> Just $ Ident s
_ -> Nothing
----------------------------------------------------------------------------
-- Policies
policy :: P Policy
policy = postfixExpNES -- Policy <$> policyLit <|> PolicyRef <$> (tok Op_Tilde >> name)
policyExp :: P PolicyExp
policyExp = PolicyLit <$> (braces $ seplist (clause actor) semiColon) <|>
PolicyOf <$> (tok KW_P_Policyof >> parens ident)
clause :: P a -> P (Clause a)
clause headC = do
h <- headC
as <- lopt $ colon >> seplist atom comma
return $ Clause h as
atom :: P Atom
atom = do
n <- name
ps <- lopt $ parens $ seplist actor comma
return $ Atom n ps
actor :: P Actor
actor = Actor <$> actorName <|> Var <$> actorVar -- (tok Op_Query >> ident)
actorName :: P ActorName
actorName = ActorName <$> name
actorVar :: P Ident
actorVar = javaToken $ \t -> case t of
VarActorTok s -> Just $ Ident s
_ -> Nothing
lock :: P Lock
lock = do
n <- name
as <- lopt $ parens $ seplist actorName comma
return $ Lock n as
lockProperties :: P LockProperties
lockProperties = braces $ LockProperties <$> optendseplist (clause atom) semiColon
lockExp :: P [Lock]
lockExp = parens (seplist1 lock (tok Comma))
<|> return . LockVar <$> ident
------------------------------------------------------------
empty :: P ()
empty = return ()
opt :: P a -> P (Maybe a)
opt pa = --optionMaybe
try (Just <$> pa) <|> return Nothing
bopt :: P a -> P Bool
bopt p = opt p >>= \ma -> return $ isJust ma
lopt :: P [a] -> P [a]
lopt p = do mas <- opt p
case mas of
Nothing -> return []
Just as -> return as
list :: P a -> P [a]
list = option [] . list1
list1 :: P a -> P [a]
list1 = many1
seplist :: P a -> P sep -> P [a]
--seplist = sepBy
seplist p sep = option [] $ seplist1 p sep
seplist1 :: P a -> P sep -> P [a]
--seplist1 = sepBy1
seplist1 p sep =
p >>= \a ->
try (do sep
as <- seplist1 p sep
return (a:as))
<|> return [a]
optendseplist :: P a -> P sep -> P [a]
optendseplist p sep = seplist p sep `optend` sep
optend :: P a -> P end -> P a
optend p end = do
x <- p
_ <- opt end
return x
startSuff, (|>>) :: P a -> P (a -> a) -> P a
startSuff start suffix = do
x <- start
ss <- list suffix
return $ foldl (\a s -> s a) x ss
(|>>) = startSuff
------------------------------------------------------------
javaToken :: (Token -> Maybe a) -> P a
javaToken test = token showT posT testT
where showT (L _ t) = show t
posT (L p _) = pos2sourcePos p
testT (L _ t) = test t
tok, matchToken :: Token -> P ()
tok = matchToken
matchToken t = javaToken (\r -> if r == t then Just () else Nothing)
pos2sourcePos :: (Int, Int) -> SourcePos
pos2sourcePos (l,c) = newPos "" l c
type Mod a = [Modifier] -> a
parens, braces, brackets, angles :: P a -> P a
parens = between (tok OpenParen) (tok CloseParen)
braces = between (tok OpenCurly) (tok CloseCurly)
brackets = between (tok OpenSquare) (tok CloseSquare)
angles = between (tok Op_LThan) (tok Op_GThan)
endSemi :: P a -> P a
endSemi p = p >>= \a -> semiColon >> return a
comma, colon, semiColon, period :: P ()
comma = tok Comma
colon = tok Op_Colon
semiColon = tok SemiColon
period = tok Period
------------------------------------------------------------
test = "public class Foo { }"
checkConstrs :: ClassDecl -> P ()
checkConstrs (ClassDecl _ i _ _ _ cb) = do
let errs = [ ci | ConstructorDecl _ _ ci _ _ _ <- universeBi cb, ci /= i ]
if null errs then return ()
else fail $ "Declaration of class " ++ prettyPrint i
++ " cannot contain constructor with name "
++ prettyPrint (head errs)
-----------------------------------------------------
-- Generalization is only needed for parameters of
-- kind Type, since these are representated by a
-- special contructor TypeVariable.
-- LockStateVar is handled by the parser, NO LONGER
-- and actors and policies are parsed as ExpName.
generalize :: Data a => [TypeParam] -> a -> a
generalize pars = transformBi gen
. transformBi genA
. transformBi genP
. transformBi genL
where gen :: RefType -> RefType
gen (ClassRefType (ClassType [(i, [])]))
| i `elem` parIs = TypeVariable i
gen rt = rt
genA :: ActorName -> ActorName
genA (ActorName (Name [i]))
| i `elem` actIs = ActorTypeVar i
genA a = a
genP :: Exp -> Exp
genP (ExpName (Name [i]))
| i `elem` polIs = PolicyExp (PolicyTypeVar i)
genP e = e
genL :: Lock -> Lock
genL (Lock (Name [i]) [])
| i `elem` locIs = LockVar i
-- genL (Lock n as) = Lock n $
genL l = l
parIs = [ i | TypeParam i _ <- pars ]
locIs = [ i | LockStateParam i <- pars ]
actIs = [ i | ActorParam i <- pars ]
polIs = [ i | PolicyParam i <- pars ]
-- Instantiation is needed for all four kinds.
instantiate :: Data a => [(TypeParam,TypeArgument)] -> a -> a
instantiate pas = transformBi instT
. transformBi instA
. transformBi instP
. transformBi instLs
where instT :: RefType -> RefType
instT tv@(TypeVariable i) =
case lookup i typs of
Just rt -> rt
Nothing -> tv
instT rt = rt
instA :: ActorName -> ActorName
instA a@(ActorName (Name [i])) =
case lookup i as of
Just n -> ActorName n
_ -> a
instA a = a
instP :: Exp -> Exp
instP p@(ExpName (Name [i])) =
case lookup i ps of
Just p -> p
_ -> p
instP p = p
instLs :: [Lock] -> [Lock]
instLs = concatMap instL
instL :: Lock -> [Lock]
instL lv@(LockVar i) =
case lookup i lps of
Just le -> le
Nothing -> [lv]
instL le = [le]
nameOfType (ClassRefType (ClassType iArgs)) =
let (is, args) = unzip iArgs
in if all null args
then Just $ Name $ foldr (:) [] is
else Nothing
typs = [ (i,rt) | (TypeParam i _, ActualArg (ActualType rt)) <- pas ]
as = [ (i,n) | (ActorParam i, ActualArg (ActualActor n )) <- pas ]
ps = [ (i,p) | (PolicyParam i, ActualArg (ActualPolicy p )) <- pas ]
lps = [ (i,le) | (LockStateParam i, ActualArg (ActualLockState le)) <- pas ]