First implementation of CLASSPATH and JAR files reading.

[hs-java.git] / Java / ClassPath.hs

diff --git a/Java/ClassPath.hs b/Java/ClassPath.hs
new file mode 100644 (file)
index 0000000..ecc4ae4
--- /dev/null
+++ b/Java/ClassPath.hs
@@ -0,0 +1,101 @@
+
+module Java.ClassPath where
+
+import Control.Monad
+import Control.Monad.State
+import System.Directory
+import System.FilePath
+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
+
+-- | For given list of glob masks, return list of matching files
+glob :: FilePath -> [FilePath] -> IO [FilePath]
+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
+  let cp' = foldr appendPath cp files
+  put cp'
+
+runClassPath :: ClassPath () -> IO [Tree CPEntry]
+runClassPath m = execStateT m []
+