diff --git a/Language/Java/ClassFile.hs b/Language/Java/ClassFile.hs --- a/Language/Java/ClassFile.hs +++ b/Language/Java/ClassFile.hs @@ -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 \"@\@\". nameConstructor :: String nameConstructor = "" -getClassType :: ClassImporter ClassType -getClassType = constClass <$> getConstantRef +-- |Class constructors are encoded in .class files as static member functions of the name \"@\@\". +nameClassConstructor :: String +nameClassConstructor = "" -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 diff --git a/language-java-classfile.cabal b/language-java-classfile.cabal --- a/language-java-classfile.cabal +++ b/language-java-classfile.cabal @@ -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 -Maintainer: Dr. ERDI Gergo +Author: Gergő Érdi +Maintainer: Gergő Érdi -- 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: