Java/ClassPath.hs

   1
   2 module Java.ClassPath where
   3
   4 import Control.Monad
   5 import Control.Monad.State
   6 import System.Directory
   7 import System.FilePath
   8 import System.FilePath.Glob
   9 import Data.Function (on)
  10 import Data.List
  11 import Data.String.Utils (split)
  12
  13 import JVM.ClassFile
  14 import JVM.Converter
  15
  16 data Tree a =
  17     Directory FilePath [Tree a]
  18   | File a
  19   deriving (Eq)
  20
  21 instance Show a => Show (Tree a) where
  22   show (Directory dir forest) = dir ++ "/{" ++ intercalate ", " (map show forest) ++ "}"
  23   show (File a) = show a
  24
  25 data CPEntry =
  26     NotLoaded FilePath
  27   | Loaded FilePath (Class Direct)
  28   | NotLoadedJAR FilePath FilePath
  29   | LoadedJAR FilePath (Class Direct)
  30   deriving (Eq)
  31
  32 instance Show CPEntry where
  33   show (NotLoaded path) = "<Not loaded file: " ++ path ++ ">"
  34   show (Loaded path cls) = "<Loaded from " ++ path ++ ": " ++ toString (thisClass cls) ++ ">"
  35   show (NotLoadedJAR jar path) = "<Not loaded JAR: " ++ jar ++ ": " ++ path ++ ">"
  36   show (LoadedJAR path cls) = "<Read JAR: " ++ path ++ ": " ++ toString (thisClass cls) ++ ">"
  37
  38 type ClassPath a = StateT [Tree CPEntry] IO a
  39
  40 -- | For given list of glob masks, return list of matching files
  41 glob :: FilePath -> [FilePath] -> IO [FilePath]
  42 glob dir patterns = do
  43   (matches, _) <- globDir (map compile patterns) dir
  44   return $ concat matches
  45
  46 mapF ::  (t -> a) -> [Tree t] -> [Tree a]
  47 mapF fn forest = map (mapT fn) forest
  48
  49 mapFM fn forest = mapM (mapTM fn) forest
  50
  51 mapTM fn (Directory dir forest) = Directory dir `fmap` mapFM fn forest
  52 mapTM fn (File a) = File `fmap` fn a
  53
  54 mapT ::  (t -> a) -> Tree t -> Tree a
  55 mapT fn (Directory dir forest) = Directory dir (mapF fn forest)
  56 mapT fn (File a) = File (fn a)
  57
  58 buildTree :: [FilePath] -> [Tree FilePath]
  59 buildTree strs =
  60   let build :: [[String]] -> [Tree FilePath]
  61       build [[name]] = [File name]
  62       build ss = map node $ groupBy eq (sort ss)
  63
  64       node [] = error "Impossible: groupBy give an empty group!"
  65       node ([]:l) = node l
  66       node l | all (null . tail) l = File (head $ head l)
  67              | otherwise           = Directory (head $ head l) (build $ map tail l)
  68
  69       ls = map (split "/") strs
  70
  71       eq [] []       = True
  72       eq (x:_) (y:_) = x == y
  73
  74   in  build ls
  75
  76 appendPath :: FilePath -> [Tree CPEntry] -> [Tree CPEntry]
  77 appendPath path forest = merge $ forest ++ (mapF NotLoaded $ buildTree [path])
  78
  79 merge :: [Tree CPEntry] -> [Tree CPEntry]
  80 merge [] = []
  81 merge (t:ts) = foldl merge1 [t] ts
  82
  83 merge1 :: [Tree CPEntry] -> Tree CPEntry -> [Tree CPEntry]
  84 merge1 [] x = [x]
  85 merge1 (x@(File e): es) y@(File e') | e == e'   = x: es
  86                                     | otherwise = x: merge1 es y
  87 merge1 (d@(Directory _ _):es) f@(File _) = d: merge1 es f
  88 merge1 (x@(Directory dir f):es) y@(Directory dir' f')
  89   | dir == dir' = Directory dir (merge $ f ++ f'): es
  90   | otherwise   = x: merge1 es y
  91
  92 addDirectory :: FilePath -> ClassPath ()
  93 addDirectory dir = do
  94   files <- liftIO $ glob dir ["*.class"]
  95   cp <- get
  96   let cp' = foldr appendPath cp files
  97   put cp'
  98
  99 runClassPath :: ClassPath () -> IO [Tree CPEntry]
 100 runClassPath m = execStateT m []
 101