+++ /dev/null
-
-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
-
+++ /dev/null
-
-module JAR.Tree where
-
import JVM.Common () -- import instances only
import JVM.ClassFile
import JVM.Assembler
+import Java.ClassPath
-- | Generator state
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)
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)
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],
-- * Misc
HasSignature (..), HasAttributes (..),
NameType (..),
+ fieldNameType, methodNameType,
toString,
className,
apsize, arsize, arlist
-- | 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
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
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
-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) = "<Not loaded file: " ++ path ++ ">"
- show (Loaded path cls) = "<Loaded from " ++ path ++ ": " ++ toString (thisClass cls) ++ ">"
- show (NotLoadedJAR jar path) = "<Not loaded JAR: " ++ jar ++ ": " ++ path ++ ">"
- show (LoadedJAR path cls) = "<Read JAR: " ++ path ++ ": " ++ toString (thisClass 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]
(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
--- /dev/null
+
+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
+
--- /dev/null
+
+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) = "<Not loaded file: " ++ path ++ ">"
+ show (Loaded path cls) = "<Loaded from " ++ path ++ ": " ++ toString (thisClass cls) ++ ">"
+ show (NotLoadedJAR jar path) = "<Not loaded JAR: " ++ jar ++ ": " ++ path ++ ">"
+ show (LoadedJAR path cls) = "<Read JAR: " ++ path ++ ": " ++ toString (thisClass cls) ++ ">"
+
+type ClassPath a = StateT [Tree CPEntry] IO a
+
--- /dev/null
+
+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'
+
--- /dev/null
+
+module JAR.Tree where
+
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 []
+
| 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 []
-
return ()
-testClass :: Class Direct
-testClass = generate "Test" test
-
main = do
+ testClass <- generate [] "Test" test
B.writeFile "Test.class" (encodeClass testClass)
projects / hs-java.git / commitdiff