module Language.Haskell.TH.TypeGraph.Graph
( GraphEdges
, graphFromMap
, cut
, cutM
, isolate
, isolateM
, dissolve
, dissolveM
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Lens (over, _2)
import Control.Monad (filterM)
import Data.Foldable as Foldable
import Data.Graph hiding (edges)
import Data.List as List (intercalate, map)
import Data.Map as Map (Map, elems, filterWithKey, keys, map, mapWithKey, partitionWithKey)
import qualified Data.Map as Map (toList)
import Data.Set as Set (Set, delete, empty, filter, member, fromList, union, unions)
import Language.Haskell.TH (Ppr(ppr))
import Language.Haskell.TH.PprLib (ptext)
import Language.Haskell.TH.TypeGraph.Core (pprint')
import Prelude hiding (foldr)
type GraphEdges label key = Map key (label, Set key)
instance Ppr key => Ppr (GraphEdges label key) where
ppr x =
ptext $ intercalate "\n " $
"edges:" : (List.map
(\(k, (_, ks)) -> intercalate "\n " ((pprint' k ++ " ->") : List.map pprint' (toList ks)))
(Map.toList x))
graphFromMap :: forall label key. (Ord key) =>
GraphEdges label key -> (Graph, Vertex -> (label, key, [key]), key -> Maybe Vertex)
graphFromMap mp =
graphFromEdges triples
where
triples :: [(label, key, [key])]
triples = List.map (\ (k, (node, ks)) -> (node, k, toList ks)) $ Map.toList mp
cut :: (Eq a, Ord a) => Set a -> GraphEdges label a -> GraphEdges label a
cut victims edges = Map.filterWithKey (\v _ -> not (Set.member v victims)) (isolate victims edges)
cutM :: (Functor m, Monad m, Eq a, Ord a) => (a -> m Bool) -> GraphEdges label a -> m (GraphEdges label a)
cutM victim edges = do
victims <- Set.fromList <$> filterM victim (Map.keys edges)
return $ cut victims edges
isolate :: (Eq a, Ord a) => Set a -> GraphEdges label a -> GraphEdges label a
isolate victims edges =
edges''
where
edges' = Map.mapWithKey (\v (h, s) -> (h, if Set.member v victims then Set.empty else s)) edges
edges'' = Map.map (over _2 (Set.filter (not . (`Set.member` victims)))) edges'
isolateM :: (Functor m, Monad m, Eq a, Ord a) => (a -> m Bool) -> GraphEdges label a -> m (GraphEdges label a)
isolateM victim edges = do
victims <- Set.fromList <$> filterM victim (Map.keys edges)
return $ isolate victims edges
dissolve :: (Eq a, Ord a) => Set a -> GraphEdges label a -> GraphEdges label a
dissolve victims edges0 = foldr dissolve1 edges0 victims
where
dissolve1 :: (Eq a, Ord a) => a -> GraphEdges label a -> GraphEdges label a
dissolve1 victim edges =
Map.mapWithKey (\k (h, s) -> (h, extend k s)) survivorEdges
where
extend k s = if Set.member victim s then Set.union (Set.delete victim s) (Set.delete k vOut) else s
vOut = Set.delete victim $ Set.unions $ List.map snd $ Map.elems victimEdges
(victimEdges, survivorEdges) = partitionWithKey (\v _ -> (v == victim)) edges
dissolveM :: (Functor m, Monad m, Eq a, Ord a) => (a -> m Bool) -> GraphEdges label a -> m (GraphEdges label a)
dissolveM victim edges = do
victims <- Set.fromList <$> filterM victim (Map.keys edges)
return $ dissolve victims edges