-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
projects / hs-java.git / blobdiff