{-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-}
-- |This module types and functions for representing a dependency
-- graph of arbitrary objects and functions for querying such graphs
-- to get dependency and reverse dependency information.
module Database.Schema.Migrations.Dependencies
    ( Dependable(..)
    , DependencyGraph(..)
    , mkDepGraph
    , dependencies
    , reverseDependencies
    )
where

import Data.Text ( Text )
import Data.Maybe ( fromJust )
import Data.Monoid ( (<>) )
import Data.Graph.Inductive.Graph ( Graph(..), nodes, edges, Node, suc, pre, lab )
import Data.Graph.Inductive.PatriciaTree ( Gr )

import Database.Schema.Migrations.CycleDetection ( hasCycle )

-- |'Dependable' objects supply a representation of their identifiers,
-- and a list of other objects upon which they depend.
class (Eq a, Ord a) => Dependable a where
    -- |The identifiers of the objects on which @a@ depends.
    depsOf :: a -> [Text]
    -- |The identifier of a 'Dependable' object.
    depId :: a -> Text

-- |A 'DependencyGraph' represents a collection of objects together
-- with a graph of their dependency relationships.  This is intended
-- to be used with instances of 'Dependable'.
data DependencyGraph a = DG { DependencyGraph a -> [(a, Int)]
depGraphObjectMap :: [(a, Int)]
                            -- ^ A mapping of 'Dependable' objects to
                            -- their graph vertex indices.
                            , DependencyGraph a -> [(Text, Int)]
depGraphNameMap :: [(Text, Int)]
                            -- ^ A mapping of 'Dependable' object
                            -- identifiers to their graph vertex
                            -- indices.
                            , DependencyGraph a -> Gr Text Text
depGraph :: Gr Text Text
                            -- ^ A directed 'Gr' (graph) of the
                            -- 'Dependable' objects' dependency
                            -- relationships, with 'Text' vertex and
                            -- edge labels.
                            }

instance (Eq a) => Eq (DependencyGraph a) where
    DependencyGraph a
g1 == :: DependencyGraph a -> DependencyGraph a -> Bool
== DependencyGraph a
g2 = ((Gr Text Text -> [Int]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Int]
nodes (Gr Text Text -> [Int]) -> Gr Text Text -> [Int]
forall a b. (a -> b) -> a -> b
$ DependencyGraph a -> Gr Text Text
forall a. DependencyGraph a -> Gr Text Text
depGraph DependencyGraph a
g1) [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== (Gr Text Text -> [Int]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Int]
nodes (Gr Text Text -> [Int]) -> Gr Text Text -> [Int]
forall a b. (a -> b) -> a -> b
$ DependencyGraph a -> Gr Text Text
forall a. DependencyGraph a -> Gr Text Text
depGraph DependencyGraph a
g2) Bool -> Bool -> Bool
&&
                (Gr Text Text -> [Edge]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Edge]
edges (Gr Text Text -> [Edge]) -> Gr Text Text -> [Edge]
forall a b. (a -> b) -> a -> b
$ DependencyGraph a -> Gr Text Text
forall a. DependencyGraph a -> Gr Text Text
depGraph DependencyGraph a
g1) [Edge] -> [Edge] -> Bool
forall a. Eq a => a -> a -> Bool
== (Gr Text Text -> [Edge]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Edge]
edges (Gr Text Text -> [Edge]) -> Gr Text Text -> [Edge]
forall a b. (a -> b) -> a -> b
$ DependencyGraph a -> Gr Text Text
forall a. DependencyGraph a -> Gr Text Text
depGraph DependencyGraph a
g2))

instance (Show a) => Show (DependencyGraph a) where
    show :: DependencyGraph a -> String
show DependencyGraph a
g = String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ([Int] -> String
forall a. Show a => a -> String
show ([Int] -> String) -> [Int] -> String
forall a b. (a -> b) -> a -> b
$ Gr Text Text -> [Int]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Int]
nodes (Gr Text Text -> [Int]) -> Gr Text Text -> [Int]
forall a b. (a -> b) -> a -> b
$ DependencyGraph a -> Gr Text Text
forall a. DependencyGraph a -> Gr Text Text
depGraph DependencyGraph a
g) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ([Edge] -> String
forall a. Show a => a -> String
show ([Edge] -> String) -> [Edge] -> String
forall a b. (a -> b) -> a -> b
$ Gr Text Text -> [Edge]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [Edge]
edges (Gr Text Text -> [Edge]) -> Gr Text Text -> [Edge]
forall a b. (a -> b) -> a -> b
$ DependencyGraph a -> Gr Text Text
forall a. DependencyGraph a -> Gr Text Text
depGraph DependencyGraph a
g) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

-- XXX: provide details about detected cycles
-- |Build a dependency graph from a list of 'Dependable's.  Return the
-- graph on success or return an error message if the graph cannot be
-- constructed (e.g., if the graph contains a cycle).
mkDepGraph :: (Dependable a) => [a] -> Either String (DependencyGraph a)
mkDepGraph :: [a] -> Either String (DependencyGraph a)
mkDepGraph [a]
objects = if Gr Text Text -> Bool
forall (g :: * -> * -> *) a b. Graph g => g a b -> Bool
hasCycle Gr Text Text
theGraph
                     then String -> Either String (DependencyGraph a)
forall a b. a -> Either a b
Left String
"Invalid dependency graph; cycle detected"
                     else DependencyGraph a -> Either String (DependencyGraph a)
forall a b. b -> Either a b
Right (DependencyGraph a -> Either String (DependencyGraph a))
-> DependencyGraph a -> Either String (DependencyGraph a)
forall a b. (a -> b) -> a -> b
$ DG :: forall a.
[(a, Int)] -> [(Text, Int)] -> Gr Text Text -> DependencyGraph a
DG { depGraphObjectMap :: [(a, Int)]
depGraphObjectMap = [(a, Int)]
ids
                                     , depGraphNameMap :: [(Text, Int)]
depGraphNameMap = [(Text, Int)]
names
                                     , depGraph :: Gr Text Text
depGraph = Gr Text Text
theGraph
                                     }
    where
      theGraph :: Gr Text Text
theGraph = [LNode Text] -> [LEdge Text] -> Gr Text Text
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [LNode Text]
n [LEdge Text]
e
      n :: [LNode Text]
n = [ (Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ a -> [(a, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
o [(a, Int)]
ids, a -> Text
forall a. Dependable a => a -> Text
depId a
o) | a
o <- [a]
objects ]
      e :: [LEdge Text]
e = [ ( Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ a -> [(a, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
o [(a, Int)]
ids
            , Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ a -> [(a, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
d [(a, Int)]
ids
            , a -> Text
forall a. Dependable a => a -> Text
depId a
o Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Dependable a => a -> Text
depId a
d) | a
o <- [a]
objects, a
d <- a -> [a]
forall a. Dependable a => a -> [a]
depsOf' a
o ]
      depsOf' :: a -> [a]
depsOf' a
o = (Text -> a) -> [Text] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
i -> Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, a)] -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
i [(Text, a)]
objMap) ([Text] -> [a]) -> [Text] -> [a]
forall a b. (a -> b) -> a -> b
$ a -> [Text]
forall a. Dependable a => a -> [Text]
depsOf a
o

      objMap :: [(Text, a)]
objMap = (a -> (Text, a)) -> [a] -> [(Text, a)]
forall a b. (a -> b) -> [a] -> [b]
map (\a
o -> (a -> Text
forall a. Dependable a => a -> Text
depId a
o, a
o)) [a]
objects
      ids :: [(a, Int)]
ids = [a] -> [Int] -> [(a, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
objects [Int
1..]
      names :: [(Text, Int)]
names = ((a, Int) -> (Text, Int)) -> [(a, Int)] -> [(Text, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\(a
o,Int
i) -> (a -> Text
forall a. Dependable a => a -> Text
depId a
o, Int
i)) [(a, Int)]
ids

type NextNodesFunc = Gr Text Text -> Node -> [Node]

cleanLDups :: (Eq a) => [a] -> [a]
cleanLDups :: [a] -> [a]
cleanLDups [] = []
cleanLDups [a
e] = [a
e]
cleanLDups (a
e:[a]
es) = if a
e a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
es then ([a] -> [a]
forall a. Eq a => [a] -> [a]
cleanLDups [a]
es) else (a
ea -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a] -> [a]
forall a. Eq a => [a] -> [a]
cleanLDups [a]
es)

-- |Given a dependency graph and an ID, return the IDs of objects that
-- the object depends on.  IDs are returned with least direct
-- dependencies first (i.e., the apply order).
dependencies :: (Dependable d) => DependencyGraph d -> Text -> [Text]
dependencies :: DependencyGraph d -> Text -> [Text]
dependencies DependencyGraph d
g Text
m = [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. Eq a => [a] -> [a]
cleanLDups ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ NextNodesFunc -> DependencyGraph d -> Text -> [Text]
forall d.
Dependable d =>
NextNodesFunc -> DependencyGraph d -> Text -> [Text]
dependenciesWith NextNodesFunc
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> [Int]
suc DependencyGraph d
g Text
m

-- |Given a dependency graph and an ID, return the IDs of objects that
-- depend on it.  IDs are returned with least direct reverse
-- dependencies first (i.e., the revert order).
reverseDependencies :: (Dependable d) => DependencyGraph d -> Text -> [Text]
reverseDependencies :: DependencyGraph d -> Text -> [Text]
reverseDependencies DependencyGraph d
g Text
m = [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. Eq a => [a] -> [a]
cleanLDups ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ NextNodesFunc -> DependencyGraph d -> Text -> [Text]
forall d.
Dependable d =>
NextNodesFunc -> DependencyGraph d -> Text -> [Text]
dependenciesWith NextNodesFunc
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> [Int]
pre DependencyGraph d
g Text
m

dependenciesWith :: (Dependable d) => NextNodesFunc -> DependencyGraph d -> Text -> [Text]
dependenciesWith :: NextNodesFunc -> DependencyGraph d -> Text -> [Text]
dependenciesWith NextNodesFunc
nextNodes dg :: DependencyGraph d
dg@(DG [(d, Int)]
_ [(Text, Int)]
nMap Gr Text Text
theGraph) Text
name =
    let lookupId :: Int
lookupId = Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
name [(Text, Int)]
nMap
        depNodes :: [Int]
depNodes = NextNodesFunc
nextNodes Gr Text Text
theGraph Int
lookupId
        recurse :: [Text] -> [[Text]]
recurse [Text]
theNodes = (Text -> [Text]) -> [Text] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map (NextNodesFunc -> DependencyGraph d -> Text -> [Text]
forall d.
Dependable d =>
NextNodesFunc -> DependencyGraph d -> Text -> [Text]
dependenciesWith NextNodesFunc
nextNodes DependencyGraph d
dg) [Text]
theNodes
        getLabel :: Int -> Text
getLabel Int
node = Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Gr Text Text -> Int -> Maybe Text
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Int -> Maybe a
lab Gr Text Text
theGraph Int
node
        labels :: [Text]
labels = (Int -> Text) -> [Int] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Text
getLabel [Int]
depNodes
    in [Text]
labels [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ ([[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> [Text]) -> [[Text]] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [[Text]]
recurse [Text]
labels)