From 2872ad36144dae1b896f93d490c0e62d55f891b1 Mon Sep 17 00:00:00 2001 From: "Ilya V. Portnov" Date: Tue, 4 Oct 2011 11:20:31 +0600 Subject: [PATCH] Refactor. --- JAR/Archive.hs | 57 -------------- JVM/Builder/Monad.hs | 27 +++++-- JVM/ClassFile.hs | 13 +++- Java/ClassPath.hs | 153 ++++++++++++++++++-------------------- Java/ClassPath/Common.hs | 52 +++++++++++++ Java/ClassPath/Types.hs | 32 ++++++++ Java/JAR/Archive.hs | 32 ++++++++ {JAR => Java/JAR}/Tree.hs | 0 Java/META.hs | 62 +++++++++++++++ Java/META/Spec.hs | 62 --------------- TestGen.hs | 4 +- 11 files changed, 281 insertions(+), 213 deletions(-) delete mode 100644 JAR/Archive.hs create mode 100644 Java/ClassPath/Common.hs create mode 100644 Java/ClassPath/Types.hs create mode 100644 Java/JAR/Archive.hs rename {JAR => Java/JAR}/Tree.hs (100%) diff --git a/JAR/Archive.hs b/JAR/Archive.hs deleted file mode 100644 index 78902dc..0000000 --- a/JAR/Archive.hs +++ /dev/null @@ -1,57 +0,0 @@ - -module JAR.Archive where - -import Control.Monad.Trans -import qualified Control.Monad.State as St -import qualified Codec.Archive.LibZip as Zip -import Data.Binary -import Data.String.Utils (split) -import qualified Data.ByteString.Lazy as B - -import Java.ClassPath -import JVM.ClassFile -import JVM.Converter - -readJAR :: FilePath -> IO [Tree CPEntry] -readJAR jarfile = do - files <- Zip.withArchive [] jarfile $ Zip.fileNames [] - return $ mapF (NotLoadedJAR jarfile) (buildTree files) - -readFromJAR :: FilePath -> FilePath -> IO (Class Direct) -readFromJAR jarfile path = do - content <- Zip.withArchive [] jarfile $ Zip.fileContents [] path - let bstr = B.pack content - return $ classFile2Direct (decode bstr) - -addJAR :: FilePath -> ClassPath () -addJAR jarfile = do - classes <- liftIO $ readJAR jarfile - cp <- St.get - let cp' = merge $ cp ++ classes - St.put cp' - -loadClass :: String -> ClassPath () -loadClass path = do - cp <- St.get - cp' <- liftIO $ mapM (load xs) cp - St.put cp' - where - xs = split "/" path - - load :: [String] -> Tree CPEntry -> IO (Tree CPEntry) - load [] t = return t - load (p:ps) t@(Directory dir forest) - | p == dir = Directory dir `fmap` mapM (load ps) forest - | otherwise = return t - load [p] t@(File (NotLoaded f)) - | (p ++ ".class") == f = do - cls <- parseClassFile (path ++ ".class") - return (File $ Loaded path cls) - | otherwise = return t - load [p] t@(File (NotLoadedJAR jarfile f)) - | (p ++ ".class") == f = do - cls <- readFromJAR jarfile (path ++ ".class") - return (File $ LoadedJAR jarfile cls) - | otherwise = return t - load ps (File _) = fail $ "Found file when expecting directory! " ++ show ps - diff --git a/JVM/Builder/Monad.hs b/JVM/Builder/Monad.hs index 837c312..f5b1d74 100644 --- a/JVM/Builder/Monad.hs +++ b/JVM/Builder/Monad.hs @@ -23,6 +23,7 @@ import qualified Data.ByteString.Lazy as B import JVM.Common () -- import instances only import JVM.ClassFile import JVM.Assembler +import Java.ClassPath -- | Generator state data GState = GState { @@ -31,7 +32,8 @@ data GState = GState { doneMethods :: [Method Direct], -- ^ Already generated class methods currentMethod :: Maybe (Method Direct), -- ^ Current method stackSize :: Word16, -- ^ Maximum stack size for current method - locals :: Word16 -- ^ Maximum number of local variables for current method + locals :: Word16, -- ^ Maximum number of local variables for current method + classPath :: [Tree CPEntry] } deriving (Eq,Show) @@ -43,10 +45,17 @@ emptyGState = GState { doneMethods = [], currentMethod = Nothing, stackSize = 496, - locals = 0 } + locals = 0, + classPath = []} -- | Generate monad -type Generate a = State GState a +type Generate a = StateT GState IO a + +withClassPath :: ClassPath () -> Generate () +withClassPath cp = do + res <- liftIO $ execClassPath cp + st <- St.get + St.put $ st {classPath = res} -- | Append a constant to pool appendPool :: Constant Direct -> Pool Direct -> (Pool Direct, Word16) @@ -213,15 +222,17 @@ initClass name = do addToPool (CString "Code") -- | Generate a class -generate :: B.ByteString -> Generate () -> Class Direct -generate name gen = +generate :: [Tree CPEntry] -> B.ByteString -> Generate () -> IO (Class Direct) +generate cp name gen = do let generator = do initClass name + st <- St.get + St.put $ st {classPath = cp} gen - res = execState generator emptyGState - code = genCode res + res <- execStateT generator emptyGState + let code = genCode res d = defaultClass :: Class Direct - in d { + return $ d { constsPoolSize = fromIntegral $ M.size (currentPool res), constsPool = currentPool res, accessFlags = S.fromList [ACC_PUBLIC, ACC_STATIC], diff --git a/JVM/ClassFile.hs b/JVM/ClassFile.hs index 56615c0..623585a 100644 --- a/JVM/ClassFile.hs +++ b/JVM/ClassFile.hs @@ -23,6 +23,7 @@ module JVM.ClassFile -- * Misc HasSignature (..), HasAttributes (..), NameType (..), + fieldNameType, methodNameType, toString, className, apsize, arsize, arlist @@ -165,9 +166,9 @@ instance HasSignature a => Binary (NameType a) where -- | Constant pool item data Constant stage = CClass (Link stage B.ByteString) - | CField {refClass :: Link stage B.ByteString, fieldNameType :: Link stage (NameType Field)} - | CMethod {refClass :: Link stage B.ByteString, nameType :: Link stage (NameType Method)} - | CIfaceMethod {refClass :: Link stage B.ByteString, nameType :: Link stage (NameType Method)} + | CField (Link stage B.ByteString) (Link stage (NameType Field)) + | CMethod (Link stage B.ByteString) (Link stage (NameType Method)) + | CIfaceMethod (Link stage B.ByteString) (Link stage (NameType Method)) | CString (Link stage B.ByteString) | CInteger Word32 | CFloat Float @@ -510,6 +511,9 @@ deriving instance Eq (Field Direct) deriving instance Show (Field File) deriving instance Show (Field Direct) +fieldNameType :: Field Direct -> NameType Field +fieldNameType f = NameType (fieldName f) (fieldSignature f) + instance Binary (Field File) where put (Field {..}) = do put fieldAccessFlags @@ -539,6 +543,9 @@ deriving instance Eq (Method Direct) deriving instance Show (Method File) deriving instance Show (Method Direct) +methodNameType :: Method Direct -> NameType Method +methodNameType m = NameType (methodName m) (methodSignature m) + instance Binary (Method File) where put (Method {..}) = do put methodAccessFlags diff --git a/Java/ClassPath.hs b/Java/ClassPath.hs index ecc4ae4..944cc36 100644 --- a/Java/ClassPath.hs +++ b/Java/ClassPath.hs @@ -1,41 +1,22 @@ -module Java.ClassPath where - -import Control.Monad -import Control.Monad.State -import System.Directory -import System.FilePath +module Java.ClassPath + (module Java.ClassPath.Types, + module Java.ClassPath.Common, + appendPath, addDirectory, loadClass, + runClassPath, execClassPath, + getEntry + ) where + +import qualified Control.Monad.State as St +import Control.Monad.Trans (liftIO) import System.FilePath.Glob -import Data.Function (on) -import Data.List import Data.String.Utils (split) import JVM.ClassFile import JVM.Converter - -data Tree a = - Directory FilePath [Tree a] - | File a - deriving (Eq) - -instance Show a => Show (Tree a) where - show (Directory dir forest) = dir ++ "/{" ++ intercalate ", " (map show forest) ++ "}" - show (File a) = show a - -data CPEntry = - NotLoaded FilePath - | Loaded FilePath (Class Direct) - | NotLoadedJAR FilePath FilePath - | LoadedJAR FilePath (Class Direct) - deriving (Eq) - -instance Show CPEntry where - show (NotLoaded path) = "" - show (Loaded path cls) = "" - show (NotLoadedJAR jar path) = "" - show (LoadedJAR path cls) = "" - -type ClassPath a = StateT [Tree CPEntry] IO a +import Java.ClassPath.Types +import Java.ClassPath.Common +import Java.JAR.Archive -- | For given list of glob masks, return list of matching files glob :: FilePath -> [FilePath] -> IO [FilePath] @@ -43,59 +24,71 @@ glob dir patterns = do (matches, _) <- globDir (map compile patterns) dir return $ concat matches -mapF :: (t -> a) -> [Tree t] -> [Tree a] -mapF fn forest = map (mapT fn) forest - -mapFM fn forest = mapM (mapTM fn) forest - -mapTM fn (Directory dir forest) = Directory dir `fmap` mapFM fn forest -mapTM fn (File a) = File `fmap` fn a - -mapT :: (t -> a) -> Tree t -> Tree a -mapT fn (Directory dir forest) = Directory dir (mapF fn forest) -mapT fn (File a) = File (fn a) - -buildTree :: [FilePath] -> [Tree FilePath] -buildTree strs = - let build :: [[String]] -> [Tree FilePath] - build [[name]] = [File name] - build ss = map node $ groupBy eq (sort ss) - - node [] = error "Impossible: groupBy give an empty group!" - node ([]:l) = node l - node l | all (null . tail) l = File (head $ head l) - | otherwise = Directory (head $ head l) (build $ map tail l) - - ls = map (split "/") strs - - eq [] [] = True - eq (x:_) (y:_) = x == y - - in build ls - appendPath :: FilePath -> [Tree CPEntry] -> [Tree CPEntry] appendPath path forest = merge $ forest ++ (mapF NotLoaded $ buildTree [path]) -merge :: [Tree CPEntry] -> [Tree CPEntry] -merge [] = [] -merge (t:ts) = foldl merge1 [t] ts - -merge1 :: [Tree CPEntry] -> Tree CPEntry -> [Tree CPEntry] -merge1 [] x = [x] -merge1 (x@(File e): es) y@(File e') | e == e' = x: es - | otherwise = x: merge1 es y -merge1 (d@(Directory _ _):es) f@(File _) = d: merge1 es f -merge1 (x@(Directory dir f):es) y@(Directory dir' f') - | dir == dir' = Directory dir (merge $ f ++ f'): es - | otherwise = x: merge1 es y - addDirectory :: FilePath -> ClassPath () addDirectory dir = do files <- liftIO $ glob dir ["*.class"] - cp <- get + cp <- St.get let cp' = foldr appendPath cp files - put cp' - -runClassPath :: ClassPath () -> IO [Tree CPEntry] -runClassPath m = execStateT m [] + St.put cp' + +runClassPath :: ClassPath a -> IO a +runClassPath m = St.evalStateT m [] + +execClassPath :: ClassPath () -> IO [Tree CPEntry] +execClassPath m = St.execStateT m [] + +loadClass :: String -> ClassPath () +loadClass path = do + cp <- St.get + cp' <- liftIO $ mapM (load xs) cp + St.put cp' + where + xs = split "/" path + + load :: [String] -> Tree CPEntry -> IO (Tree CPEntry) + load [] t = return t + load (p:ps) t@(Directory dir forest) + | p == dir = Directory dir `fmap` mapM (load ps) forest + | otherwise = return t + load [p] t@(File (NotLoaded f)) + | (p ++ ".class") == f = do + cls <- parseClassFile (path ++ ".class") + return (File $ Loaded path cls) + | otherwise = return t + load [p] t@(File (NotLoadedJAR jarfile f)) + | (p ++ ".class") == f = do + cls <- readFromJAR jarfile (path ++ ".class") + return (File $ LoadedJAR jarfile cls) + | otherwise = return t + load ps (File _) = fail $ "Found file when expecting directory! " ++ show ps + +getEntry :: [Tree CPEntry] -> String -> IO (Maybe CPEntry) +getEntry cp path = get cp (split "/" path) + where + get :: [Tree CPEntry] -> [String] -> IO (Maybe CPEntry) + get _ [] = fail "Empty path for ClassPath.getEntry.get!" + get [] _ = return Nothing + get (Directory dir forest: es) (p:ps) + | dir == p = get forest ps + | otherwise = get es (p:ps) + get (File i@(NotLoaded f): es) [p] + | (p ++ ".class" == f) = do + cls <- parseClassFile (path ++ ".class") + return $ Just (Loaded path cls) + | otherwise = get es [p] + get (File i@(NotLoadedJAR jarfile r): es) [p] + | (p ++ ".class" == r) = do + cls <- readFromJAR jarfile (path ++ ".class") + return $ Just (LoadedJAR jarfile cls) + | otherwise = get es [p] + get (File i@(Loaded f c):es) [p] + | f == p = return (Just i) + | otherwise = get es [p] + get (File i@(LoadedJAR f c):es) [p] + | toString (thisClass c) == path = return (Just i) + | otherwise = get es [p] + get x y = fail $ "Unexpected arguments for ClassPath.getEntry.get: " ++ show x ++ ", " ++ show y diff --git a/Java/ClassPath/Common.hs b/Java/ClassPath/Common.hs new file mode 100644 index 0000000..0b8a528 --- /dev/null +++ b/Java/ClassPath/Common.hs @@ -0,0 +1,52 @@ + +module Java.ClassPath.Common where + +import Data.List +import Data.String.Utils (split) + +import Java.ClassPath.Types + +mapF :: (t -> a) -> [Tree t] -> [Tree a] +mapF fn forest = map (mapT fn) forest + +mapFM fn forest = mapM (mapTM fn) forest + +mapTM fn (Directory dir forest) = Directory dir `fmap` mapFM fn forest +mapTM fn (File a) = File `fmap` fn a + +mapT :: (t -> a) -> Tree t -> Tree a +mapT fn (Directory dir forest) = Directory dir (mapF fn forest) +mapT fn (File a) = File (fn a) + +buildTree :: [FilePath] -> [Tree FilePath] +buildTree strs = + let build :: [[String]] -> [Tree FilePath] + build [[name]] = [File name] + build ss = map node $ groupBy eq (sort ss) + + node [] = error "Impossible: groupBy give an empty group!" + node ([]:l) = node l + node l | all (null . tail) l = File (head $ head l) + | otherwise = Directory (head $ head l) (build $ map tail l) + + ls = map (split "/") strs + + eq [] [] = True + eq (x:_) (y:_) = x == y + + in build ls + +merge :: [Tree CPEntry] -> [Tree CPEntry] +merge [] = [] +merge [t1,t2] = merge1 [t1] t2 +merge (t:ts) = foldl merge1 [t] ts + +merge1 :: [Tree CPEntry] -> Tree CPEntry -> [Tree CPEntry] +merge1 [] x = [x] +merge1 (x@(File e): es) y@(File e') | e == e' = x: es + | otherwise = x: merge1 es y +merge1 (d@(Directory _ _):es) f@(File _) = d: merge1 es f +merge1 (x@(Directory dir f):es) y@(Directory dir' f') + | dir == dir' = Directory dir (merge $ f ++ f'): es + | otherwise = x: merge1 es y + diff --git a/Java/ClassPath/Types.hs b/Java/ClassPath/Types.hs new file mode 100644 index 0000000..6efb155 --- /dev/null +++ b/Java/ClassPath/Types.hs @@ -0,0 +1,32 @@ + +module Java.ClassPath.Types where + +import Control.Monad.State +import Data.List + +import JVM.ClassFile + +data Tree a = + Directory FilePath [Tree a] + | File a + deriving (Eq) + +instance Show a => Show (Tree a) where + show (Directory dir forest) = dir ++ "/{" ++ intercalate ", " (map show forest) ++ "}" + show (File a) = show a + +data CPEntry = + NotLoaded FilePath + | Loaded FilePath (Class Direct) + | NotLoadedJAR FilePath FilePath + | LoadedJAR FilePath (Class Direct) + deriving (Eq) + +instance Show CPEntry where + show (NotLoaded path) = "" + show (Loaded path cls) = "" + show (NotLoadedJAR jar path) = "" + show (LoadedJAR path cls) = "" + +type ClassPath a = StateT [Tree CPEntry] IO a + diff --git a/Java/JAR/Archive.hs b/Java/JAR/Archive.hs new file mode 100644 index 0000000..035f1e1 --- /dev/null +++ b/Java/JAR/Archive.hs @@ -0,0 +1,32 @@ + +module Java.JAR.Archive where + +import Control.Monad.Trans +import qualified Control.Monad.State as St +import qualified Codec.Archive.LibZip as Zip +import Data.Binary +import qualified Data.ByteString.Lazy as B + +import Java.ClassPath.Types +import Java.ClassPath.Common +import JVM.ClassFile +import JVM.Converter + +readJAR :: FilePath -> IO [Tree CPEntry] +readJAR jarfile = do + files <- Zip.withArchive [] jarfile $ Zip.fileNames [] + return $ mapF (NotLoadedJAR jarfile) (buildTree files) + +readFromJAR :: FilePath -> FilePath -> IO (Class Direct) +readFromJAR jarfile path = do + content <- Zip.withArchive [] jarfile $ Zip.fileContents [] path + let bstr = B.pack content + return $ classFile2Direct (decode bstr) + +addJAR :: FilePath -> ClassPath () +addJAR jarfile = do + classes <- liftIO $ readJAR jarfile + cp <- St.get + let cp' = merge $ cp ++ classes + St.put cp' + diff --git a/JAR/Tree.hs b/Java/JAR/Tree.hs similarity index 100% rename from JAR/Tree.hs rename to Java/JAR/Tree.hs diff --git a/Java/META.hs b/Java/META.hs index 3293977..47c6de7 100644 --- a/Java/META.hs +++ b/Java/META.hs @@ -9,3 +9,65 @@ import Java.META.Types import Java.META.Parser import Java.META.Spec +data Manifest = Manifest { + manifestVersion :: String, + createdBy :: String, + sealed :: Bool, + signatureVersion :: Maybe String, + classPath :: [String], + mainClass :: Maybe String, + manifestEntries :: [ManifestEntry]} + deriving (Eq, Show) + +data ManifestEntry = ManifestEntry { + meName :: String, + meSealed :: Bool, + meContentType :: Maybe String, + meBean :: Bool } + deriving (Eq, Show) + +instance MetaSpec Manifest where + loadFirstSection s = Manifest { + manifestVersion = s ! "Manifest-Version", + createdBy = s ! "Created-By", + sealed = case M.lookup "Sealed" s of + Nothing -> False + Just str -> string2bool str, + signatureVersion = M.lookup "Signature-Version" s, + classPath = case M.lookup "Class-Path" s of + Nothing -> [] + Just str -> words str, + mainClass = M.lookup "Main-Class" s, + manifestEntries = []} + + loadOtherSection m s = m {manifestEntries = manifestEntries m ++ [entry]} + where + entry = ManifestEntry { + meName = s ! "Name", + meSealed = case M.lookup "Sealed" s of + Nothing -> sealed m + Just str -> string2bool str, + meContentType = M.lookup "Content-Type" s, + meBean = case M.lookup "Java-Bean" s of + Nothing -> False + Just str -> string2bool str } + + storeMeta m = first: map store (manifestEntries m) + where + first = M.fromList $ [ + ("Manifest-Version", manifestVersion m), + ("Created-By", createdBy m)] ++ + lookupList "Signature-Version" (signatureVersion m) ++ + lookupList "Main-Class" (mainClass m) ++ + case classPath m of + [] -> [] + list -> [("Class-Path", unwords list)] + + store e = M.fromList $ [ + ("Name", meName e), + ("Sealed", bool2string $ meSealed e)] ++ + lookupList "Content-Type" (meContentType e) ++ + if meBean e + then [("Java-Bean", "true")] + else [] + diff --git a/Java/META/Spec.hs b/Java/META/Spec.hs index 82d55c1..1e296fb 100644 --- a/Java/META/Spec.hs +++ b/Java/META/Spec.hs @@ -35,65 +35,3 @@ string2bool s | map toLower s == "true" = True | otherwise = False -data Manifest = Manifest { - manifestVersion :: String, - createdBy :: String, - sealed :: Bool, - signatureVersion :: Maybe String, - classPath :: [String], - mainClass :: Maybe String, - manifestEntries :: [ManifestEntry]} - deriving (Eq, Show) - -data ManifestEntry = ManifestEntry { - meName :: String, - meSealed :: Bool, - meContentType :: Maybe String, - meBean :: Bool } - deriving (Eq, Show) - -instance MetaSpec Manifest where - loadFirstSection s = Manifest { - manifestVersion = s ! "Manifest-Version", - createdBy = s ! "Created-By", - sealed = case M.lookup "Sealed" s of - Nothing -> False - Just str -> string2bool str, - signatureVersion = M.lookup "Signature-Version" s, - classPath = case M.lookup "Class-Path" s of - Nothing -> [] - Just str -> words str, - mainClass = M.lookup "Main-Class" s, - manifestEntries = []} - - loadOtherSection m s = m {manifestEntries = manifestEntries m ++ [entry]} - where - entry = ManifestEntry { - meName = s ! "Name", - meSealed = case M.lookup "Sealed" s of - Nothing -> sealed m - Just str -> string2bool str, - meContentType = M.lookup "Content-Type" s, - meBean = case M.lookup "Java-Bean" s of - Nothing -> False - Just str -> string2bool str } - - storeMeta m = first: map store (manifestEntries m) - where - first = M.fromList $ [ - ("Manifest-Version", manifestVersion m), - ("Created-By", createdBy m)] ++ - lookupList "Signature-Version" (signatureVersion m) ++ - lookupList "Main-Class" (mainClass m) ++ - case classPath m of - [] -> [] - list -> [("Class-Path", unwords list)] - - store e = M.fromList $ [ - ("Name", meName e), - ("Sealed", bool2string $ meSealed e)] ++ - lookupList "Content-Type" (meContentType e) ++ - if meBean e - then [("Java-Bean", "true")] - else [] - diff --git a/TestGen.hs b/TestGen.hs index 69786e9..900a422 100644 --- a/TestGen.hs +++ b/TestGen.hs @@ -47,9 +47,7 @@ test = do return () -testClass :: Class Direct -testClass = generate "Test" test - main = do + testClass <- generate [] "Test" test B.writeFile "Test.class" (encodeClass testClass) -- 2.25.1