language-java-classfile 0.1 → 0.2.0
raw patch · 2 files changed
+257/−106 lines, 2 filesdep +LibZipdep +containersdep +deepseqdep ~mtl
Dependencies added: LibZip, containers, deepseq
Dependency ranges changed: mtl
Files
- Language/Java/ClassFile.hs +249/−101
- language-java-classfile.cabal +8/−5
Language/Java/ClassFile.hs view
@@ -1,5 +1,14 @@ {-# LANGUAGE DoRec #-}-module Language.Java.ClassFile (getClass, nameConstructor) where+module Language.Java.ClassFile (+ -- * Classfile parsing+ ClassImportResult(..),+ InnerType(..),+ getClass,+ -- parseClasses,+ -- parseJar,+ -- * Magic identifiers+ nameConstructor, nameClassConstructor+ ) where import Language.Java.Syntax import Data.Binary.Get@@ -8,12 +17,15 @@ import Data.Maybe import Control.Monad import Data.Word-import Control.Applicative ((<$>), (<$), (<*>)) -- (<*) (see parseFull)-import Data.Array+import Control.Applicative ((<$>), (<$))+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap import Data.Flags import Control.Monad.Reader import Text.ParserCombinators.Parsec import Data.List+import Control.DeepSeq+import Data.Monoid parseFull :: Parser a -> Parser a -- language-java depends on Parsec 2, which is not Applicative...@@ -34,41 +46,48 @@ (PrimType ShortT <$ char 'S') <|> (PrimType BooleanT <$ char 'Z') <|> (RefType <$> ArrayType <$> (char '[' >> parseType)) <|>- (RefType <$> ClassRefType <$> (char 'L' >> parseClassType'))-- where parseClassType' = - do x <- parseClassType- _ <- char ';'- return x+ (RefType <$> ClassRefType <$> (char 'L' >> parseClassTypeEnd)) readType :: String -> Type readType s = case parse (parseFull parseType) "" s of Right x -> x Left e -> error $ show e +parseRefType :: Parser RefType+parseRefType =+ ArrayType <$> (char '[' >> parseType) <|>+ ClassRefType <$> parseClassType ++readRefType :: String -> RefType +readRefType s = + case parse (parseFull parseRefType) "" s of+ Right x -> x+ Left e -> error $ unwords [show s, show e]+ parseClassType :: Parser ClassType parseClassType = - do parts <- (many1 alphaNum) `sepBy` (char '/')+ do parts <- (many1 $ alphaNum <|> oneOf "-_") `sepBy` (char '/' <|> char '$') let ids = map (\ part -> (Ident part, [])) parts return $ ClassType ids -readClassType :: String -> ClassType-readClassType s = case parse (parseFull parseClassType) "" s of- Right x -> x- Left e -> error $ show e+parseClassTypeEnd =+ do x <- parseClassType+ _ <- char ';'+ return x+ parseMethodType :: Parser (Maybe Type, [Type])-parseMethodType = do- args <- between (char '(') (char ')') (many parseType)- ret <- (Nothing <$ char 'V') <|> (Just <$> parseType) - return (ret, args)+parseMethodType = + do args <- between (char '(') (char ')') (many parseType)+ ret <- (Nothing <$ char 'V') <|> (Just <$> parseType) + return (ret, args) readMethodType s = case parse (parseFull parseMethodType) "" s of Right x -> x Left e -> error $ show e -type ConstIdx = Word16 -getConstIdx = getWord16be+type ConstIdx = IntMap.Key+getConstIdx = fromIntegral <$> getWord16be data ConstantValue = ValueInteger Word32 | ValueFloat Float@@ -77,88 +96,88 @@ | ValueString String deriving Show -data Constant = ConstantClass { constClass :: ClassType }- | ConstantFieldRef { constClass :: ClassType, nameAndTypeIdx :: ConstIdx }- | ConstantMethodRef { constClass :: ClassType, nameAndTypeIdx :: ConstIdx }- | ConstantInterfaceMethodRef { constClass :: ClassType, nameAndTypeIdx :: ConstIdx }+data Constant = ConstantClass { constRefType :: RefType } | ConstantValue ConstantValue | ConstantString String- | ConstantNameAndType { nameIdx :: ConstIdx, descIdx :: ConstIdx }- | Unknown Word8 deriving Show -type ConstTable = Array Word16 Constant+type ConstTable = IntMap Constant type ClassImporter a = ReaderT ConstTable Get a getMany f = do count <- lift getWord16be forM [1..count] $ const f -getConstant :: ConstTable -> Get Constant+getConstant :: ConstTable -> Get (ConstIdx, Maybe Constant) getConstant constTable = do tag <- getWord8 case tag of- 1 -> ConstantString <$> getString- 3 -> ConstantValue <$> ValueInteger <$> getWord32be- 4 -> ConstantValue <$> ValueFloat <$> getFloat32be- 5 -> ConstantValue <$> ValueLong <$> getWord64be- 6 -> ConstantValue <$> ValueDouble <$> getFloat64be- 7 -> ConstantClass <$> readClassType <$> getStringRef- 8 -> ConstantValue <$> ValueString <$> getStringRef- 9 -> ConstantFieldRef <$> getType <*> getConstIdx- 10 -> ConstantMethodRef <$> getType <*> getConstIdx- 11 -> ConstantInterfaceMethodRef <$> getType <*> getConstIdx- 12 -> ConstantNameAndType <$> getConstIdx <*> getConstIdx- tag -> error $ unwords ["Unknown tag type:", show tag] -- return $ Unknown tag+ 1 -> noSkip <$> Just <$> ConstantString <$> getString+ 3 -> noSkip <$> Just <$> ConstantValue <$> ValueInteger <$> getWord32be+ 4 -> noSkip <$> Just <$> ConstantValue <$> ValueFloat <$> getFloat32be+ 5 -> skip <$> Just <$> ConstantValue <$> ValueLong <$> getWord64be+ 6 -> skip <$> Just <$> ConstantValue <$> ValueDouble <$> getFloat64be+ 7 -> noSkip <$> Just <$> ConstantClass <$> readRefType <$> getStringRef+ 8 -> noSkip <$> Just <$> ConstantValue <$> ValueString <$> getStringRef+ + 9 -> noSkip <$> (getConstIdx >> getConstIdx >> return Nothing)+ 10 -> noSkip <$> (getConstIdx >> getConstIdx >> return Nothing)+ 11 -> noSkip <$> (getConstIdx >> getConstIdx >> return Nothing)+ 12 -> noSkip <$> (getConstIdx >> getConstIdx >> return Nothing)+ + tag -> fail $ unwords ["Unknown tag type:", show tag] where getString = toString <$> (getByteString =<< (fromInteger . fromIntegral <$> getWord16be)) - lookupString idx = case constTable!idx of- ConstantString s -> s+ -- lookupString idx = case IntMap.lookup idx constTable of+ -- Just (ConstantString s) -> s - getStringRef = lookupString <$> getConstIdx+ -- getStringRef = lookupString <$> getConstIdx++ getStringRef = do idx <- getConstIdx+ let Just (ConstantString s) = IntMap.lookup idx constTable+ return s - getType = lookupType <$> getConstIdx- lookupType = constClass . (constTable!)+ noSkip x = (1, x)+ skip x = (2, x) getConstants :: Get ConstTable-getConstants = do - count <- getWord16be- rec - -- According to the Java .class spec, count is, for some reason, one larger than the actual number of constants- consts <- listArray (1, count - 1) <$> (forM [1..count-1] $ const $ getConstant consts)- return consts+getConstants = + do count <- fromIntegral <$> getWord16be+ rec + -- According to the Java .class spec, count is, for some reason, one larger than the actual number of constants+ consts <- IntMap.fromAscList <$> mapMaybe filter <$> (fromToM 1 (count - 1) $ \i -> + do (step, const) <- getConstant consts+ return (step, (i, const)))+ return consts+ + where filter (_, Nothing) = Nothing+ filter (i, Just c) = Just (i, c) +fromToM from to f | from > to = return []+ | otherwise = + do (step, x) <- f from+ liftM (x:) $ fromToM (from + step) to f+ classObject :: ClassType classObject = ClassType [(Ident "java", []), (Ident "lang", []), (Ident "Object", [])] +-- |Constructors are encoded in .class files as member functions of the name \"@\<init>@\". nameConstructor :: String nameConstructor = "<init>" -getClassType :: ClassImporter ClassType-getClassType = constClass <$> getConstantRef+-- |Class constructors are encoded in .class files as static member functions of the name \"@\<clinit>@\".+nameClassConstructor :: String+nameClassConstructor = "<clinit>" -getClass :: Get TypeDecl-getClass = - do (_major, _minor) <- getHeader- constTable <- getConstants- flip runReaderT constTable $- do (isInterface, modifiers) <- getToplevel- - ClassType [(this, _)] <- getClassType- superClass <- getClassType- let super = if superClass == classObject then Nothing else Just (ClassRefType superClass)- - ifaces <- getMany (ClassRefType <$> getClassType)- fields <- getMany getField- methods <- catMaybes <$> getMany (getMethod this)- - _attributes <- getAttributes- - return $ if isInterface- then InterfaceTypeDecl $ InterfaceDecl modifiers this [] ifaces (InterfaceBody [])- else ClassTypeDecl $ ClassDecl modifiers this [] super ifaces (ClassBody $ map MemberDecl $ fields ++ methods)+constClassType con = let ClassRefType cls = constRefType con in cls +getClassTypeMaybe :: ClassImporter (Maybe ClassType)+getClassTypeMaybe = fmap constClassType <$> getConstantRefMaybe++getClassType :: ClassImporter ClassType+getClassType = constClassType <$> fromMaybe (error "getClassType") <$> getConstantRefMaybe+ getHeader = do signature <- replicateM 4 getWord8 unless (signature == [0xCA, 0xFE, 0xBA, 0xBE]) $ @@ -167,31 +186,45 @@ major <- getWord16be return (major, minor) -getConstantRef :: ClassImporter Constant-getConstantRef = +getConstantRefMaybe :: ClassImporter (Maybe Constant)+getConstantRefMaybe = do idx <- lift getConstIdx- asks (!idx)+ if idx == 0 then return Nothing else asks (IntMap.lookup idx)++getConstantRef :: ClassImporter Constant+getConstantRef = fromMaybe (error "getConstantRef") <$> getConstantRefMaybe -getStringRef :: ClassImporter String -getStringRef = - do const <- getConstantRef- case const of- ConstantString s -> return s+getStringRefMaybe ::ClassImporter (Maybe String) +getStringRefMaybe = + do const <- getConstantRefMaybe+ return $ case const of+ Just (ConstantString s) -> Just s+ _ -> Nothing+ +getStringRef :: ClassImporter String+getStringRef = fromMaybe (fail "getStringRef") <$> getStringRefMaybe +data InnerClass = InnerClass { innerInner :: ClassType, + innerOuter :: Maybe ClassType,+ innerName :: Maybe String,+ innerFlags :: Word16 }+ deriving Show+ data Attribute = AttrConstantValue ConstantValue | AttrExceptions [ClassType] | AttrSynthetic+ | AttrInnerClasses [InnerClass]+ | AttrSourceFile String deriving Show -isAttrSynthetic AttrSynthetic = True-isAttrSynthetic _ = False- -isAttrConstantValue (AttrConstantValue _) = True-isAttrConstantValue _ = False- -isAttrExceptions (AttrExceptions _) = True-isAttrExceptions _ = False- +getInnerClass :: ClassImporter InnerClass+getInnerClass =+ do inner <- getClassType+ outer <- fmap constClassType <$> getConstantRefMaybe+ name <- getStringRefMaybe+ flags <- lift getWord16be+ return $ InnerClass inner outer name flags+ getAttribute :: ClassImporter (Maybe Attribute) getAttribute = do name <- getStringRef@@ -206,13 +239,17 @@ ConstantValue val -> val "Exceptions" -> Just <$> AttrExceptions <$> getMany getClassType+ "InnerClasses" ->+ Just <$> AttrInnerClasses <$> getMany getInnerClass + "SourceFile" ->+ Just <$> AttrSourceFile <$> getStringRef _ -> do lift $ skip (fromIntegral len) return Nothing getAttributes = catMaybes <$> getMany getAttribute -getField :: ClassImporter MemberDecl+getField :: ClassImporter (Maybe MemberDecl) getField = do modifiers <- getModifiers name <- getStringRef@@ -227,26 +264,36 @@ ValueString s -> String s ValueFloat x -> Float $ realToFrac x ValueDouble x -> Double x- return $ FieldDecl modifiers ty [VarDecl (VarId $ Ident name) init] + return $ unlessSynthetic attributes $ + FieldDecl modifiers ty [VarDecl (VarId $ Ident name) init] + where isAttrConstantValue (AttrConstantValue _) = True+ isAttrConstantValue _ = False getMethod :: Ident -> ClassImporter (Maybe MemberDecl) getMethod cls = do modifiers <- getModifiers name <- getStringRef- let isConstructor = name == nameConstructor+ let isConstructor = name `elem` [nameConstructor, nameClassConstructor] (ret, args) <- readMethodType <$> getStringRef let formals = zipWith (\i ty -> FormalParam [] ty False (VarId $ Ident $ 'p':show i)) [(1::Integer)..] args attributes <- getAttributes- let exceptions = case find (isAttrExceptions) attributes of+ + let getAttrExceptions (AttrExceptions tys) = Just tys+ getAttrExceptions _ = Nothing+ exceptions = case mapFirst getAttrExceptions attributes of Nothing -> []- Just (AttrExceptions tys) -> map ClassRefType tys- return $- if any isAttrSynthetic attributes then Nothing- else Just $ - if isConstructor - then ConstructorDecl modifiers [] cls formals exceptions (ConstructorBody Nothing [])- else MethodDecl modifiers [] ret (Ident name) formals exceptions (MethodBody Nothing)+ Just tys -> map ClassRefType tys+ + return $ unlessSynthetic attributes $+ if isConstructor + then ConstructorDecl modifiers [] cls formals exceptions (ConstructorBody Nothing [])+ else MethodDecl modifiers [] ret (Ident name) formals exceptions (MethodBody Nothing) +unlessSynthetic :: [Attribute] -> a -> Maybe a+unlessSynthetic attributes x = if any isAttrSynthetic attributes then Nothing else Just x+ where isAttrSynthetic AttrSynthetic = True+ isAttrSynthetic _ = False+ parseModifiers :: Word16 -> [Modifier] parseModifiers flags = catMaybes [0x0001 ~> Public,@@ -272,3 +319,104 @@ let iface = 0x0200 .~. flags modifiers = parseModifiers flags return (iface, modifiers)++-- | Descriptor of an inner (nested) type. +-- +-- The actual definition of inner types are not in the .class file, but+-- in separate ones for each type. E.g. if class @Foo@ is defined+-- inside class @Bar@, then the file @Bar.class@ will contain an+-- 'InnerType' for Foo, and the actual definition is in+-- @Bar$Foo.class@.+data InnerType = InnerType [Modifier] ClassType+ deriving Show+ +data ClassImportResult = ClassImportResult + { sourcePath :: Maybe String,+ outerType :: Maybe ClassType,+ typeDecl :: TypeDecl,+ innerTypes :: [InnerType] }+ deriving Show+ +instance NFData Constant where+ rnf (ConstantClass ty) = ty `seq` ()+ rnf (ConstantValue value) = value `deepseq` ()+ rnf (ConstantString s) = s `deepseq` () ++instance NFData ConstantValue where+ rnf (ValueString s) = s `deepseq` ()+ rnf (ValueInteger n) = n `seq` ()+ rnf (ValueLong n) = n `seq` ()+ rnf (ValueFloat f) = f `seq` ()+ rnf (ValueDouble f) = f `seq` ()+ +mapFirst f = getFirst . mconcat . map (First . f)+ +-- | Parse a binary .class file into an 'ImportedType'.+getClass :: Get (ClassType, ClassImportResult)+getClass = + do (_major, _minor) <- getHeader+ constTable <- getConstants+ constTable `deepseq` flip runReaderT constTable $+ do (isInterface, modifiers) <- getToplevel+ + classType@(ClassType parts) <- getClassType+ let (this, _) = last parts+ superClass <- getClassTypeMaybe+ let super = case superClass of+ Nothing -> Nothing+ Just superClass -> if superClass /= classObject then Just $ ClassRefType superClass else Nothing+ + ifaces <- getMany (ClassRefType <$> getClassType)+ fields <- catMaybes <$> getMany getField+ methods <- catMaybes <$> getMany (getMethod this)+ + attributes <- getAttributes+ let sourcePath = mapFirst getSourceFile attributes+ where getSourceFile (AttrSourceFile path) = Just path+ getSourceFile _ = Nothing+ + let innerClasses = fromMaybe [] $ mapFirst getInnerClasses attributes+ where getInnerClasses (AttrInnerClasses ics) = Just ics+ getInnerClasses _ = Nothing+ innerDecls = mapMaybe (toInnerType classType) innerClasses+ outer = getOuter classType innerClasses + + let members = fields ++ methods+ decl = if isInterface+ then InterfaceTypeDecl $ InterfaceDecl modifiers this [] ifaces (InterfaceBody members)+ else ClassTypeDecl $ ClassDecl modifiers this [] super ifaces (ClassBody $ map MemberDecl members)+ + return (classType, ClassImportResult sourcePath outer decl innerDecls)+ + where toInnerType classType ic = + do outer <- innerOuter ic + guard $ outer == classType+ let inner = innerInner ic+ modifiers = parseModifiers $ innerFlags ic+ return $ InnerType modifiers inner+ + -- (ClassDecl _ id tys super ifaces body) `withClassModifiers` ms = ClassDecl ms id tys super ifaces body+ -- (InterfaceDecl _ id tys ifaces body) `withInterfaceModifiers` ms = InterfaceDecl ms id tys ifaces body++ getOuter classType ics = innerOuter =<< find (\ ic -> innerInner ic == classType) ics++-- WIP:+-- +-- type DeclMap = [(ClassType, ImportedType)]+-- -- | Parse a bunch of binary .class files+-- --+-- -- Because inner class declarations are actually described in separate .class files, +-- -- this function needs all relevant .class files. Inner classes in the result are +-- -- represented as proper 'MemberDecl's.+-- parseClasses :: [ByteString] -> [(ClassType, TypeDecl)]+-- parseClasses streams = mapMaybe toTypeDecl declMap+-- where declMap = map run streams+-- run stream = runGet (getClass_ $ Just declMap) stream++-- toTypeDecl :: (ClassType, ImportedType) -> Maybe (ClassType, TypeDecl)+-- toTypeDecl (classType, (Toplevel decl)) = Just (classType, decl)+-- toTypeDecl _ = Nothing++-- -- | Parse all classes in a .jar file, and return a list of 'CompilationUnit's corresponding to non-inner classes.+-- parseJar :: FilePath -> IO [CompilationUnit]+-- parseJar jarPath = undefined
language-java-classfile.cabal view
@@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version: 0.1+Version: 0.2.0 Synopsis: Parser for Java .class files Description: Parses compiled Java .class files into the syntax tree@@ -18,8 +18,8 @@ -- The file containing the license text. License-file: LICENSE -Author: Dr. ERDI Gergo <http://gergo.erdi.hu/>-Maintainer: Dr. ERDI Gergo <gergo@erdi.hu>+Author: Gergő Érdi <http://gergo.erdi.hu/>+Maintainer: Gergő Érdi <gergo@erdi.hu> -- A copyright notice. -- Copyright: @@ -41,11 +41,14 @@ Build-depends: base >= 2 && < 5, parsec >= 2 && < 4, language-java,- mtl >= 1 && < 2,+ deepseq,+ containers,+ mtl, data-flags, array, utf8-string, bytestring,- data-binary-ieee754, binary+ data-binary-ieee754, binary,+ LibZip -- Modules not exported by this package. -- Other-modules: