{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}

module U.Codebase.Sync where

import Control.Monad (when)
import Data.Foldable (traverse_)
import Debug.Trace (traceM)

debug :: Bool
debug :: Bool
debug = Bool
False

data TrySyncResult entity = Missing [entity] | Done | PreviouslyDone | NonFatalError
  deriving (Int -> TrySyncResult entity -> ShowS
[TrySyncResult entity] -> ShowS
TrySyncResult entity -> String
(Int -> TrySyncResult entity -> ShowS)
-> (TrySyncResult entity -> String)
-> ([TrySyncResult entity] -> ShowS)
-> Show (TrySyncResult entity)
forall entity. Show entity => Int -> TrySyncResult entity -> ShowS
forall entity. Show entity => [TrySyncResult entity] -> ShowS
forall entity. Show entity => TrySyncResult entity -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall entity. Show entity => Int -> TrySyncResult entity -> ShowS
showsPrec :: Int -> TrySyncResult entity -> ShowS
$cshow :: forall entity. Show entity => TrySyncResult entity -> String
show :: TrySyncResult entity -> String
$cshowList :: forall entity. Show entity => [TrySyncResult entity] -> ShowS
showList :: [TrySyncResult entity] -> ShowS
Show)

data Sync m entity = Sync {forall (m :: * -> *) entity.
Sync m entity -> entity -> m (TrySyncResult entity)
trySync :: entity -> m (TrySyncResult entity)}

transformSync :: (forall a. m a -> n a) -> Sync m h -> Sync n h
transformSync :: forall (m :: * -> *) (n :: * -> *) h.
(forall a. m a -> n a) -> Sync m h -> Sync n h
transformSync forall a. m a -> n a
f (Sync h -> m (TrySyncResult h)
t) = (h -> n (TrySyncResult h)) -> Sync n h
forall (m :: * -> *) entity.
(entity -> m (TrySyncResult entity)) -> Sync m entity
Sync (m (TrySyncResult h) -> n (TrySyncResult h)
forall a. m a -> n a
f (m (TrySyncResult h) -> n (TrySyncResult h))
-> (h -> m (TrySyncResult h)) -> h -> n (TrySyncResult h)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. h -> m (TrySyncResult h)
t)

data Progress m h = Progress
  { forall (m :: * -> *) h. Progress m h -> h -> m ()
need :: h -> m (),
    forall (m :: * -> *) h. Progress m h -> h -> m ()
done :: h -> m (),
    forall (m :: * -> *) h. Progress m h -> h -> m ()
error :: h -> m (),
    forall (m :: * -> *) h. Progress m h -> m ()
allDone :: m ()
  }

transformProgress :: (forall a. m a -> n a) -> Progress m h -> Progress n h
transformProgress :: forall (m :: * -> *) (n :: * -> *) h.
(forall a. m a -> n a) -> Progress m h -> Progress n h
transformProgress forall a. m a -> n a
f (Progress h -> m ()
a h -> m ()
b h -> m ()
c m ()
d) = (h -> n ()) -> (h -> n ()) -> (h -> n ()) -> n () -> Progress n h
forall (m :: * -> *) h.
(h -> m ()) -> (h -> m ()) -> (h -> m ()) -> m () -> Progress m h
Progress (m () -> n ()
forall a. m a -> n a
f (m () -> n ()) -> (h -> m ()) -> h -> n ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. h -> m ()
a) (m () -> n ()
forall a. m a -> n a
f (m () -> n ()) -> (h -> m ()) -> h -> n ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. h -> m ()
b) (m () -> n ()
forall a. m a -> n a
f (m () -> n ()) -> (h -> m ()) -> h -> n ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. h -> m ()
c) (m () -> n ()
forall a. m a -> n a
f m ()
d)

-- the Show constraint is just for debugging
sync, sync' :: forall m h. (Monad m, Show h) => Sync m h -> Progress m h -> [h] -> m ()

-- | Calls `allDone` at the end
sync :: forall (m :: * -> *) h.
(Monad m, Show h) =>
Sync m h -> Progress m h -> [h] -> m ()
sync Sync m h
s Progress m h
p [h]
roots = Sync m h -> Progress m h -> [h] -> m ()
forall (m :: * -> *) h.
(Monad m, Show h) =>
Sync m h -> Progress m h -> [h] -> m ()
sync' Sync m h
s Progress m h
p [h]
roots m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Progress m h -> m ()
forall (m :: * -> *) h. Progress m h -> m ()
allDone Progress m h
p

-- | Doesn't call `allDone` at the end, in case you plan to call sync more than once.
sync' :: forall (m :: * -> *) h.
(Monad m, Show h) =>
Sync m h -> Progress m h -> [h] -> m ()
sync' Sync {h -> m (TrySyncResult h)
trySync :: forall (m :: * -> *) entity.
Sync m entity -> entity -> m (TrySyncResult entity)
trySync :: h -> m (TrySyncResult h)
..} Progress {m ()
h -> m ()
need :: forall (m :: * -> *) h. Progress m h -> h -> m ()
done :: forall (m :: * -> *) h. Progress m h -> h -> m ()
error :: forall (m :: * -> *) h. Progress m h -> h -> m ()
allDone :: forall (m :: * -> *) h. Progress m h -> m ()
need :: h -> m ()
done :: h -> m ()
error :: h -> m ()
allDone :: m ()
..} [h]
roots = [h] -> m ()
go [h]
roots
  where
    go :: [h] -> m ()
    go :: [h] -> m ()
go (h
h : [h]
hs) = do
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (String -> m ()
forall (f :: * -> *). Applicative f => String -> f ()
traceM (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Sync.sync.go " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ([h] -> String
forall a. Show a => a -> String
show ([h] -> String) -> [h] -> String
forall a b. (a -> b) -> a -> b
$ h
h h -> [h] -> [h]
forall a. a -> [a] -> [a]
: [h]
hs))
      h -> m (TrySyncResult h)
trySync h
h m (TrySyncResult h) -> (TrySyncResult h -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Missing [h]
deps -> (h -> m ()) -> [h] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ h -> m ()
need [h]
deps m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [h] -> m ()
go ([h]
deps [h] -> [h] -> [h]
forall a. [a] -> [a] -> [a]
++ h
h h -> [h] -> [h]
forall a. a -> [a] -> [a]
: [h]
hs)
        TrySyncResult h
Done -> h -> m ()
done h
h m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [h] -> m ()
go [h]
hs
        TrySyncResult h
PreviouslyDone -> [h] -> m ()
go [h]
hs
        TrySyncResult h
NonFatalError -> h -> m ()
error h
h m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [h] -> m ()
go [h]
hs
    go [] = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()