{-|
Module      :  Database.Persist.Migration.Utils.Plan
Maintainer  :  Brandon Chinn <brandonchinn178@gmail.com>
Stability   :  experimental
Portability :  portable

Define functions useful for compiling a plan of migration.
-}
{-# LANGUAGE TupleSections #-}

module Database.Persist.Migration.Utils.Plan
  ( getPath
  ) where

import Data.Graph.Inductive (Gr, mkGraph, sp)
import Data.HashMap.Lazy ((!))
import qualified Data.HashMap.Lazy as HashMap
import qualified Data.IntSet as IntSet

type Node = Int
type Edge = (Int, Int)

-- | Given a list of edges and their data and a start/end node, return the shortest path.
--
-- Errors if no path is found.
getPath :: [(Edge, a)] -> Node -> Node -> Maybe [a]
getPath :: [(Edge, a)] -> Node -> Node -> Maybe [a]
getPath [(Edge, a)]
edgeData Node
start Node
end = (Edge -> a) -> [Edge] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (HashMap Edge a
edgeMap HashMap Edge a -> Edge -> a
forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
!) ([Edge] -> [a]) -> ([Node] -> [Edge]) -> [Node] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> [Edge]
forall b. [b] -> [(b, b)]
nodesToEdges ([Node] -> [a]) -> Maybe [Node] -> Maybe [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> Node -> Gr () Node -> Maybe [Node]
forall (gr :: * -> * -> *) b a.
(Graph gr, Real b) =>
Node -> Node -> gr a b -> Maybe [Node]
sp Node
start Node
end Gr () Node
graph
  where
    graph :: Gr () Node
graph = [Edge] -> Gr () Node
mkGraph' ([Edge] -> Gr () Node) -> [Edge] -> Gr () Node
forall a b. (a -> b) -> a -> b
$ ((Edge, a) -> Edge) -> [(Edge, a)] -> [Edge]
forall a b. (a -> b) -> [a] -> [b]
map (Edge, a) -> Edge
forall a b. (a, b) -> a
fst [(Edge, a)]
edgeData
    nodesToEdges :: [b] -> [(b, b)]
nodesToEdges [b]
nodes = [b] -> [b] -> [(b, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [b]
nodes ([b] -> [(b, b)]) -> [b] -> [(b, b)]
forall a b. (a -> b) -> a -> b
$ [b] -> [b]
forall a. [a] -> [a]
tail [b]
nodes
    edgeMap :: HashMap Edge a
edgeMap = [(Edge, a)] -> HashMap Edge a
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList [(Edge, a)]
edgeData

mkGraph' :: [Edge] -> Gr () Int
mkGraph' :: [Edge] -> Gr () Node
mkGraph' [Edge]
edgeData = [LNode ()] -> [LEdge Node] -> Gr () Node
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [LNode ()]
nodes [LEdge Node]
edges
  where
    detuple :: (a, a) -> [a]
detuple (a
a, a
b) = [a
a, a
b]
    nodes :: [LNode ()]
nodes = (Node -> LNode ()) -> [Node] -> [LNode ()]
forall a b. (a -> b) -> [a] -> [b]
map (, ()) ([Node] -> [LNode ()])
-> ([Edge] -> [Node]) -> [Edge] -> [LNode ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> [Node]
IntSet.toList (IntSet -> [Node]) -> ([Edge] -> IntSet) -> [Edge] -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> IntSet
IntSet.fromList ([Node] -> IntSet) -> ([Edge] -> [Node]) -> [Edge] -> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Edge -> [Node]) -> [Edge] -> [Node]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Edge -> [Node]
forall a. (a, a) -> [a]
detuple ([Edge] -> [LNode ()]) -> [Edge] -> [LNode ()]
forall a b. (a -> b) -> a -> b
$ [Edge]
edgeData
    edges :: [LEdge Node]
edges = (Edge -> LEdge Node) -> [Edge] -> [LEdge Node]
forall a b. (a -> b) -> [a] -> [b]
map ((Node -> Node -> LEdge Node) -> Edge -> LEdge Node
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (,,Node
1)) [Edge]
edgeData