module Database.Schema.Migrations.Dependencies
( Dependable(..)
, DependencyGraph(..)
, mkDepGraph
, dependencies
, reverseDependencies
)
where
import Data.Maybe ( fromJust )
import Data.Graph.Inductive.Graph ( Graph(..), nodes, edges, Node, suc, pre, lab )
import Data.Graph.Inductive.PatriciaTree ( Gr )
import Database.Schema.Migrations.CycleDetection ( hasCycle )
class (Eq a, Ord a) => Dependable a where
depsOf :: a -> [String]
depId :: a -> String
data DependencyGraph a = DG { depGraphObjectMap :: [(a, Int)]
, depGraphNameMap :: [(String, Int)]
, depGraph :: Gr String String
}
instance (Eq a) => Eq (DependencyGraph a) where
g1 == g2 = ((nodes $ depGraph g1) == (nodes $ depGraph g2) &&
(edges $ depGraph g1) == (edges $ depGraph g2))
instance (Show a) => Show (DependencyGraph a) where
show g = "(" ++ (show $ nodes $ depGraph g) ++ ", " ++ (show $ edges $ depGraph g) ++ ")"
mkDepGraph :: (Dependable a) => [a] -> Either String (DependencyGraph a)
mkDepGraph objects = if hasCycle theGraph
then Left "Invalid dependency graph; cycle detected"
else Right $ DG { depGraphObjectMap = ids
, depGraphNameMap = names
, depGraph = theGraph
}
where
theGraph = mkGraph n e
n = [ (fromJust $ lookup o ids, depId o) | o <- objects ]
e = [ ( fromJust $ lookup o ids
, fromJust $ lookup d ids
, depId o ++ " -> " ++ depId d) | o <- objects, d <- depsOf' o ]
depsOf' o = map (\i -> fromJust $ lookup i objMap) $ depsOf o
objMap = map (\o -> (depId o, o)) objects
ids = zip objects [1..]
names = map (\(o,i) -> (depId o, i)) ids
type NextNodesFunc = Gr String String -> Node -> [Node]
cleanLDups :: (Eq a) => [a] -> [a]
cleanLDups [] = []
cleanLDups [e] = [e]
cleanLDups (e:es) = if e `elem` es then (cleanLDups es) else (e:cleanLDups es)
dependencies :: (Dependable d) => DependencyGraph d -> String -> [String]
dependencies g m = reverse $ cleanLDups $ dependenciesWith suc g m
reverseDependencies :: (Dependable d) => DependencyGraph d -> String -> [String]
reverseDependencies g m = reverse $ cleanLDups $ dependenciesWith pre g m
dependenciesWith :: (Dependable d) => NextNodesFunc -> DependencyGraph d -> String -> [String]
dependenciesWith nextNodes dg@(DG _ nMap theGraph) name =
let lookupId = fromJust $ lookup name nMap
depNodes = nextNodes theGraph lookupId
recurse theNodes = map (dependenciesWith nextNodes dg) theNodes
getLabel node = fromJust $ lab theGraph node
labels = map getLabel depNodes
in labels ++ (concat $ recurse labels)