{-# LANGUAGE Haskell2010 #-} {-# OPTIONS -Wall -fno-warn-name-shadowing #-} -- | Functions for partitioning package dependency graphs and -- class dependency graphs. module Segments where import Prelude hiding (print) import Types import Utils import Control.Monad import Haskell.X import Foreign.Java import Foreign.Java.IO import Data.Graph import Data.Tree import Data.Map (Map) import MultiMap (MultiMap) import Data.Set (Set) import qualified Data.Map as Map import qualified Data.Set as Set import qualified MultiMap as MultiMap import System.IO hiding (print) -- Finds strongly connected components in the dependencies graph -- between classes and groups them in independent ranks, i.e. -- two scc within the same rank are mutually independent. findClassClusters :: Map String JavaClass -> Java [[[String]]] findClassClusters classInfo = do print "Attempting to find clusters... " let edges = Map.foldlWithKey mkNode [] classInfo mkNode vs name clazz = (name, name, classDependencies clazz) : vs (graph, label, _) = graphFromEdges edges components :: [[Vertex]] components = map flatten $ scc graph ranks :: [[[Vertex]]] ranks = let (a, b) = foldl rank (Set.empty, []) components in if Set.null a then b else Set.toList a : b rank :: (Set [Vertex], [[[Vertex]]]) -> [Vertex] -> (Set [Vertex], [[[Vertex]]]) rank (rs, vss) vs | Set.null ins = (Set.insert vs rs, vss) | otherwise = (Set.singleton vs, vss') where deps = Set.fromList (concatMap (reachable graph) vs) ins = deps `Set.intersection` Set.fromList (Set.foldr (++) [] rs) vss' = if Set.null rs then vss else Set.toList rs : vss labeledRanks = reverse $ map (map (map (\x -> let (z,_,_) = label x in z))) ranks numClusters = sum (map length labeledRanks) numRanks = length labeledRanks println ((\_ -> let { __ = {-# LINE 69 "Segments.hss" #-} concat ["Done (found ", (show $ numClusters), " strongly connected components in ", (show $ numRanks), " ranks)."] {-# LINE 70 "Segments.hss" #-} } in __) undefined) return labeledRanks -- Find strongly connected components in the dependencies graph -- between packages. findPackageClusters :: MultiMap String String -> Map String JavaClass -> Java [[String]] findPackageClusters classesByPackage classInfo = do let packageDependencies :: Map String (Set String) packageDependencies = Map.map findDependencies (MultiMap.toMap classesByPackage) where findDependencies classes = Set.fromList packageDependencies where dependencies = concatMap (classDependencies . (classInfo Map.!)) classes packageDependencies = map (fst . splitClassName) dependencies graph = Map.foldlWithKey mkNode [] packageDependencies mkNode vs name deps = (name, name, Set.toList deps) : vs scc = map flattenSCC (stronglyConnComp graph) return $ reverse scc -- Find the core packages of Java by resolving all dependencies -- of all packages and taking the intersection of all these sets. findJavaCore :: MultiMap String String -> Map String JavaClass -> Java (Set String) findJavaCore classesByPackage classInfo = do let packageDependencies :: Map String (Set String) packageDependencies = Map.map findDependencies (MultiMap.toMap classesByPackage) where findDependencies classes = Set.fromList packageDependencies where dependencies = concatMap (classDependencies . (classInfo Map.!)) classes packageDependencies = map (fst . splitClassName) dependencies resolve :: Set String -> Set String resolve = Set.fromList . concatMap (Set.toList . (packageDependencies Map.!)) . Set.toList fullPackageDependencies = Map.map (exhaustively resolve) packageDependencies coreJava = intersections (Map.elems fullPackageDependencies) return coreJava -- This creates a graphviz file which can be used to -- visualize inter-package dependencies visualizeDependencies :: Map String (Set String) -> IO () visualizeDependencies packageDependencies = do file <- openFile "dependencies.neato" WriteMode hPutStrLn file ((\_ -> let { __ = {-# LINE 132 "Segments.hss" #-} concat ["digraph G {\n overlap = false;"] {-# LINE 132 "Segments.hss" #-} } in __) undefined) forM_ (Map.toList packageDependencies) $ \(pkg, deps) -> do forM_ (Set.toList deps) $ \dep -> do let augment = map (\x -> if x == '.' then '_' else x) pkg' = augment pkg dep' = augment dep hPutStr file ((\_ -> let { __ = {-# LINE 139 "Segments.hss" #-} concat [" ", (pkg'), " -> ", (dep'), "\n"] {-# LINE 139 "Segments.hss" #-} } in __) undefined) hPutStrLn file ((\_ -> let { __ = {-# LINE 141 "Segments.hss" #-} concat ["}"] {-# LINE 141 "Segments.hss" #-} } in __) undefined) hClose file