j2hs-0.99: src/Segments.hss

{-# 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 """Done (found #{show $ numClusters} strongly connected \
               components in #{show $ numRanks} ranks)."""

    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 """digraph G {\n  overlap = false;"""

    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 """  #{pkg'} -> #{dep'}\n"""

    hPutStrLn file """}"""
    hClose file