module Drifter.Graph
    ( resolveDependencyOrder
    , Drifter(..)
    , migrate
    ) where

-------------------------------------------------------------------------------
import           Control.Applicative  as A
import           Control.Monad
import           Control.Monad.Fail   as Fail
import           Data.Graph.Inductive (Edge, Gr, UEdge, mkGraph, topsort')
import qualified Data.Map.Strict      as Map
import           Data.Maybe
-------------------------------------------------------------------------------
import           Drifter.Types
-------------------------------------------------------------------------------


labUEdges :: [Edge] -> [UEdge]
labUEdges :: [Edge] -> [UEdge]
labUEdges = (Edge -> UEdge) -> [Edge] -> [UEdge]
forall a b. (a -> b) -> [a] -> [b]
map (\(Node
a, Node
b) -> (Node
a, Node
b, ()))

-- | Take an unordered list of changes and put them in dependency
-- order. 'migrate' will do this automatically.
resolveDependencyOrder :: [Change a] -> [Change a]
resolveDependencyOrder :: [Change a] -> [Change a]
resolveDependencyOrder [Change a]
cs = Gr (Change a) () -> [Change a]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [a]
topsort' (Gr (Change a) () -> [Change a]) -> Gr (Change a) () -> [Change a]
forall a b. (a -> b) -> a -> b
$ [Change a] -> Gr (Change a) ()
forall a. [Change a] -> Gr (Change a) ()
graphDependencies [Change a]
cs

graphDependencies :: [Change a] -> Gr (Change a) ()
graphDependencies :: [Change a] -> Gr (Change a) ()
graphDependencies [Change a]
cs = [LNode (Change a)] -> [UEdge] -> Gr (Change a) ()
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [LNode (Change a)]
nodes ([Edge] -> [UEdge]
labUEdges [Edge]
edges)
    where nodes :: [LNode (Change a)]
nodes = [Node] -> [Change a] -> [LNode (Change a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Node
1..] [Change a]
cs
          nMap :: Map ChangeName Node
nMap  = [(ChangeName, Node)] -> Map ChangeName Node
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ChangeName, Node)] -> Map ChangeName Node)
-> [(ChangeName, Node)] -> Map ChangeName Node
forall a b. (a -> b) -> a -> b
$ (LNode (Change a) -> (ChangeName, Node))
-> [LNode (Change a)] -> [(ChangeName, Node)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Node
i, Change a
c) -> (Change a -> ChangeName
forall a. Change a -> ChangeName
changeName Change a
c, Node
i)) [LNode (Change a)]
nodes
          edges :: [Edge]
edges = [Maybe Edge] -> [Edge]
forall a. [Maybe a] -> [a]
catMaybes
                ([Maybe Edge] -> [Edge]) -> [Maybe Edge] -> [Edge]
forall a b. (a -> b) -> a -> b
$ ((Maybe Node, Maybe Node) -> Maybe Edge)
-> [(Maybe Node, Maybe Node)] -> [Maybe Edge]
forall a b. (a -> b) -> [a] -> [b]
map (\(Maybe Node
a, Maybe Node
b) -> (,) (Node -> Node -> Edge) -> Maybe Node -> Maybe (Node -> Edge)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Node
a Maybe (Node -> Edge) -> Maybe Node -> Maybe Edge
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Node
b)
                ([(Maybe Node, Maybe Node)] -> [Maybe Edge])
-> [(Maybe Node, Maybe Node)] -> [Maybe Edge]
forall a b. (a -> b) -> a -> b
$ [[(Maybe Node, Maybe Node)]] -> [(Maybe Node, Maybe Node)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                ([[(Maybe Node, Maybe Node)]] -> [(Maybe Node, Maybe Node)])
-> [[(Maybe Node, Maybe Node)]] -> [(Maybe Node, Maybe Node)]
forall a b. (a -> b) -> a -> b
$ (Change a -> [(Maybe Node, Maybe Node)])
-> [Change a] -> [[(Maybe Node, Maybe Node)]]
forall a b. (a -> b) -> [a] -> [b]
map (\Change a
c -> (ChangeName -> (Maybe Node, Maybe Node))
-> [ChangeName] -> [(Maybe Node, Maybe Node)]
forall a b. (a -> b) -> [a] -> [b]
map (\ChangeName
dn -> ( ChangeName -> Map ChangeName Node -> Maybe Node
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ChangeName
dn Map ChangeName Node
nMap
                                         , ChangeName -> Map ChangeName Node -> Maybe Node
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Change a -> ChangeName
forall a. Change a -> ChangeName
changeName Change a
c) Map ChangeName Node
nMap))
                                 (Change a -> [ChangeName]
forall a. Change a -> [ChangeName]
changeDependencies Change a
c))
                      [Change a]
cs


class Drifter a where
    -- | How to run a single, isolated migration.
    migrateSingle :: DBConnection a -> Change a -> IO (Either String ())


-- | Runs a list of changes. They will automatically be sorted and run
-- in dependency order. Will terminate early on error.
migrate :: Drifter a => DBConnection a -> [Change a] -> IO (Either String ())
migrate :: DBConnection a -> [Change a] -> IO (Either String ())
migrate DBConnection a
conn [Change a]
csUnsorted = EitherT String IO () -> IO (Either String ())
forall e (m :: * -> *) a. EitherT e m a -> m (Either e a)
runEitherT ((Change a -> EitherT String IO ())
-> [Change a] -> EitherT String IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Change a -> EitherT String IO ()
go [Change a]
cs)
  where cs :: [Change a]
cs = [Change a] -> [Change a]
forall a. [Change a] -> [Change a]
resolveDependencyOrder [Change a]
csUnsorted
        go :: Change a -> EitherT String IO ()
go = IO (Either String ()) -> EitherT String IO ()
forall e (m :: * -> *) a. m (Either e a) -> EitherT e m a
EitherT (IO (Either String ()) -> EitherT String IO ())
-> (Change a -> IO (Either String ()))
-> Change a
-> EitherT String IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DBConnection a -> Change a -> IO (Either String ())
forall a.
Drifter a =>
DBConnection a -> Change a -> IO (Either String ())
migrateSingle DBConnection a
conn


newtype EitherT e m a = EitherT { EitherT e m a -> m (Either e a)
runEitherT :: m (Either e a) }


instance Monad m => Functor (EitherT e m) where
  fmap :: (a -> b) -> EitherT e m a -> EitherT e m b
fmap a -> b
f = m (Either e b) -> EitherT e m b
forall e (m :: * -> *) a. m (Either e a) -> EitherT e m a
EitherT (m (Either e b) -> EitherT e m b)
-> (EitherT e m a -> m (Either e b))
-> EitherT e m a
-> EitherT e m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either e a -> Either e b) -> m (Either e a) -> m (Either e b)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((a -> b) -> Either e a -> Either e b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) (m (Either e a) -> m (Either e b))
-> (EitherT e m a -> m (Either e a))
-> EitherT e m a
-> m (Either e b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EitherT e m a -> m (Either e a)
forall e (m :: * -> *) a. EitherT e m a -> m (Either e a)
runEitherT
  {-# INLINE fmap #-}

instance Monad m => A.Applicative (EitherT e m) where
  pure :: a -> EitherT e m a
pure a
a  = m (Either e a) -> EitherT e m a
forall e (m :: * -> *) a. m (Either e a) -> EitherT e m a
EitherT (m (Either e a) -> EitherT e m a)
-> m (Either e a) -> EitherT e m a
forall a b. (a -> b) -> a -> b
$ Either e a -> m (Either e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either e a
forall a b. b -> Either a b
Right a
a)
  {-# INLINE pure #-}
  EitherT m (Either e (a -> b))
f <*> :: EitherT e m (a -> b) -> EitherT e m a -> EitherT e m b
<*> EitherT m (Either e a)
v = m (Either e b) -> EitherT e m b
forall e (m :: * -> *) a. m (Either e a) -> EitherT e m a
EitherT (m (Either e b) -> EitherT e m b)
-> m (Either e b) -> EitherT e m b
forall a b. (a -> b) -> a -> b
$ m (Either e (a -> b))
f m (Either e (a -> b))
-> (Either e (a -> b) -> m (Either e b)) -> m (Either e b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Either e (a -> b)
mf -> case Either e (a -> b)
mf of
    Left  e
e -> Either e b -> m (Either e b)
forall (m :: * -> *) a. Monad m => a -> m a
return (e -> Either e b
forall a b. a -> Either a b
Left e
e)
    Right a -> b
k -> m (Either e a)
v m (Either e a) -> (Either e a -> m (Either e b)) -> m (Either e b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Either e a
mv -> case Either e a
mv of
      Left  e
e -> Either e b -> m (Either e b)
forall (m :: * -> *) a. Monad m => a -> m a
return (e -> Either e b
forall a b. a -> Either a b
Left e
e)
      Right a
x -> Either e b -> m (Either e b)
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Either e b
forall a b. b -> Either a b
Right (a -> b
k a
x))
  {-# INLINE (<*>) #-}

instance Monad m => Monad (EitherT e m) where
  return :: a -> EitherT e m a
return a
a = m (Either e a) -> EitherT e m a
forall e (m :: * -> *) a. m (Either e a) -> EitherT e m a
EitherT (m (Either e a) -> EitherT e m a)
-> m (Either e a) -> EitherT e m a
forall a b. (a -> b) -> a -> b
$ Either e a -> m (Either e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either e a
forall a b. b -> Either a b
Right a
a)
  {-# INLINE return #-}
  EitherT e m a
m >>= :: EitherT e m a -> (a -> EitherT e m b) -> EitherT e m b
>>= a -> EitherT e m b
k  = m (Either e b) -> EitherT e m b
forall e (m :: * -> *) a. m (Either e a) -> EitherT e m a
EitherT (m (Either e b) -> EitherT e m b)
-> m (Either e b) -> EitherT e m b
forall a b. (a -> b) -> a -> b
$ do
    Either e a
a <- EitherT e m a -> m (Either e a)
forall e (m :: * -> *) a. EitherT e m a -> m (Either e a)
runEitherT EitherT e m a
m
    case Either e a
a of
      Left  e
l -> Either e b -> m (Either e b)
forall (m :: * -> *) a. Monad m => a -> m a
return (e -> Either e b
forall a b. a -> Either a b
Left e
l)
      Right a
r -> EitherT e m b -> m (Either e b)
forall e (m :: * -> *) a. EitherT e m a -> m (Either e a)
runEitherT (a -> EitherT e m b
k a
r)
  {-# INLINE (>>=) #-}

instance MonadFail m => MonadFail (EitherT e m) where
  fail :: String -> EitherT e m a
fail = m (Either e a) -> EitherT e m a
forall e (m :: * -> *) a. m (Either e a) -> EitherT e m a
EitherT (m (Either e a) -> EitherT e m a)
-> (String -> m (Either e a)) -> String -> EitherT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m (Either e a)
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail
  {-# INLINE fail #-}