moto-0.0.1: test/Main.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}

module Main where

import Control.Concurrent
import qualified Control.Exception as Ex (evaluate)
import qualified Control.Exception.Safe as Ex
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Data.Either (isRight)
import Data.Foldable (toList)
import Data.Function (fix)
import Data.Maybe (isNothing)
import Data.String (fromString)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Word (Word64)
import qualified Di
import qualified Di.Core
import qualified System.Directory as Dir
import qualified System.Environment (getEnv)
import System.FilePath ((</>))
import qualified System.IO.Error as IO
import qualified System.Random
import qualified Test.Tasty as Tasty
import Test.Tasty.HUnit ((@?=), (@=?))
import qualified Test.Tasty.HUnit as HU
import qualified Test.Tasty.QuickCheck as QC
import Test.Tasty.QuickCheck ((===))
import qualified Test.Tasty.Runners as Tasty

import qualified Moto.Internal as U
import qualified Moto.File

--------------------------------------------------------------------------------

data Fail = Fail String deriving (Show)
instance Ex.Exception Fail

fail_sync :: String -> IO a
fail_sync s = Ex.throwM (Fail s)

--------------------------------------------------------------------------------

backup_noop :: x -> U.Backup x
backup_noop x = U.Backup (\_ k -> k x)

backup_fail_sync :: String -> U.Backup x
backup_fail_sync s = U.Backup (\_ _ -> fail_sync s)

--------------------------------------------------------------------------------

store_noop :: x -> U.Store x
store_noop x =
  U.Store (\_ _ _ -> pure ()) (\_ _ k -> k x) (\_ _ -> pure ())

store_fail_sync_save :: x -> String -> U.Store x
store_fail_sync_save x s =
  U.Store (\_ _ _ -> fail_sync s) (\_ _ k -> k x) (\_ _ -> pure ())

store_fail_sync_load :: String -> U.Store x
store_fail_sync_load s =
  U.Store (\_ _ _ -> pure ()) (\_ _ k -> fail_sync s) (\_ _ -> pure ())

store_fail_sync_delete :: x -> String -> U.Store x
store_fail_sync_delete x s =
  U.Store (\_ _ _ -> pure ()) (\_ _ k -> k x) (\_ _ -> fail_sync s)

--------------------------------------------------------------------------------

change_noop :: U.Change x
change_noop = U.Change (\_ _ _ _ -> pure ())

change_fail_sync :: String -> U.Change x
change_fail_sync s = U.Change (\_ _ _ _ -> fail_sync s)

--------------------------------------------------------------------------------

mig_noop :: x -> U.Mig id deps
mig_noop x = U.Mig (store_noop x) (backup_noop x) change_noop

--------------------------------------------------------------------------------
-- Here we just write some things that we expect to compile over time.

_migs_0 :: U.Migs '[]
_migs_0 = U.migs

_migs_1 :: U.Migs '[ '("a",'[])]
_migs_1 = U.migs U.* mig_noop ()

-- Type inferred
_migs_1' = U.migs U.* (mig_noop () :: U.Mig "a" '[])

_migs_2 :: U.Migs '[ '("b",'[]), '("a",'[])]
_migs_2 = U.migs U.* mig_noop () U.* mig_noop ()

_migs_2' :: U.Migs '[ '("b",'["a"]), '("a",'[])]
_migs_2' = U.migs U.* mig_noop () U.* mig_noop ()

_migs_3 :: U.Migs '[ '("c",'[]), '("b",'[]), '("a",'[])]
_migs_3 = U.migs U.* mig_noop () U.* mig_noop () U.* mig_noop ()

_migs_3' :: U.Migs '[ '("c",'["a"]), '("b",'["a"]), '("a",'[])]
_migs_3' = U.migs U.* mig_noop () U.* mig_noop () U.* mig_noop ()

_migs_3'' :: U.Migs '[ '("c",'["b"]), '("b",'["a"]), '("a",'[])]
_migs_3'' = U.migs U.* mig_noop () U.* mig_noop () U.* mig_noop ()

_migs_3''' :: U.Migs '[ '("c",'["b","a"]), '("b",'["a"]), '("a",'[])]
_migs_3''' = U.migs U.* mig_noop () U.* mig_noop () U.* mig_noop ()

--------------------------------------------------------------------------------

main :: IO ()
main = Di.new $ \di -> do
  Tasty.defaultMainWithIngredients
    [ Tasty.consoleTestReporter
    , Tasty.listingTests
    ] (tt di)

--------------------------------------------------------------------------------

tt :: Di.Df1 -> Tasty.TestTree
tt di = Tasty.testGroup "main"
  [ ttPlan
  , ttRun
  ]

ttPlan :: Tasty.TestTree
ttPlan = Tasty.testGroup "plan"
  [ HU.testCase "empty migs, empty ran, forwards implicit" $ do
      True @=? isRight (U.mkPlan U.migs [] (U.Target U.Forwards []))

  , QC.testProperty "empty migs, empty ran, explicit targets" $ do
      let g = (,) <$> genDirection
                  <*> fmap Set.fromList (QC.listOf1 genMigId)
      QC.forAll g $ \(d, mIds) -> do
        qcEqLeft (U.Err_Plan_TargetsNotFound mIds)
          (U.mkPlan U.migs [] (U.Target d mIds))

  , HU.testCase "empty migs, empty ran, backwards implicit" $ do
      True @=? isRight (U.mkPlan U.migs [] (U.Target U.Backwards []))

  , QC.testProperty "empty migs, some ran, forwards implicit" $ do
      let g = (,) <$> genDirection <*> QC.listOf1 genMigId
      QC.forAll g $ \(d, mIds) -> do
        qcEqLeft U.Err_Plan_HistoryUnknown
          (U.mkPlan U.migs mIds (U.Target d []))

  , QC.testProperty "one mig, different ran" $ do
      let g = (,) <$> genDirection
                  <*> QC.suchThat (QC.listOf1 genMigId) (/= ["a"])
      QC.forAll g $ \(d, mIds) -> do
        qcEqLeft U.Err_Plan_HistoryUnknown
          (U.mkPlan U.migs mIds (U.Target d []))

  , HU.testCase "one mig, empty ran, forwards implicit" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
      Right (U.Forwards, ["a"])
         @=? fmap plan_bits
                  (U.mkPlan migs [] (U.Target U.Forwards []))

  , HU.testCase "one mig, empty ran, forwards explicit" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
      Right (U.Forwards, ["a"])
         @=? fmap plan_bits
                  (U.mkPlan migs [] (U.Target U.Forwards ["a"]))

  , HU.testCase "one mig, same ran, forwards implicit" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
      Right (U.Forwards, [])
         @=? fmap plan_bits
                  (U.mkPlan migs ["a"] (U.Target U.Forwards []))

  , HU.testCase "one mig, same ran, forwards explicit" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
      Right (U.Forwards, [])
         @=? fmap plan_bits
                  (U.mkPlan migs ["a"] (U.Target U.Forwards ["a"]))

  , HU.testCase "one mig, empty ran, backwards implicit" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
      Right (U.Backwards, [])
         @=? fmap plan_bits
                  (U.mkPlan migs [] (U.Target U.Backwards []))

  , HU.testCase "one mig, empty ran, backwards explicit" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
      Right (U.Backwards, [])
         @=? fmap plan_bits
                  (U.mkPlan migs [] (U.Target U.Backwards ["a"]))

  , HU.testCase "one mig, same ran, backwards implicit" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
      Right (U.Backwards, ["a"])
         @=? fmap plan_bits
                  (U.mkPlan migs ["a"] (U.Target U.Backwards []))

  , HU.testCase "one mig, same ran, backwards explicit" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
      Right (U.Backwards, ["a"])
         @=? fmap plan_bits
                  (U.mkPlan migs ["a"] (U.Target U.Backwards ["a"]))

  , HU.testCase "five migs, empty ran, forwards implicit" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
                        U.* (mig_noop () :: U.Mig "b" '[])
                        U.* (mig_noop () :: U.Mig "c" '["b"])
                        U.* (mig_noop () :: U.Mig "d" '["a","c"])
                        U.* (mig_noop () :: U.Mig "e" '["c"])
      Right (U.Forwards, ["a","b","c","d","e"])
         @=? fmap plan_bits
                  (U.mkPlan migs [] (U.Target U.Forwards []))

  , HU.testCase "five migs, empty ran, forwards explicit" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
                        U.* (mig_noop () :: U.Mig "b" '[])
                        U.* (mig_noop () :: U.Mig "c" '["b"])
                        U.* (mig_noop () :: U.Mig "d" '["a","c"])
                        U.* (mig_noop () :: U.Mig "e" '["c"])
      Right (U.Forwards, ["b","c","e"])
         @=? fmap plan_bits
                  (U.mkPlan migs [] (U.Target U.Forwards ["e","b","c"]))

  , HU.testCase "five migs, empty ran, forwards impossible" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
                        U.* (mig_noop () :: U.Mig "b" '[])
                        U.* (mig_noop () :: U.Mig "c" '["b"])
                        U.* (mig_noop () :: U.Mig "d" '["a","c"])
                        U.* (mig_noop () :: U.Mig "e" '["c"])
      huEqLeft U.Err_Plan_TargetImpossible
        (U.mkPlan migs [] (U.Target U.Forwards ["e","c"]))

  , HU.testCase "five migs, empty ran, backwards implicit" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
                        U.* (mig_noop () :: U.Mig "b" '[])
                        U.* (mig_noop () :: U.Mig "c" '["b"])
                        U.* (mig_noop () :: U.Mig "d" '["a","c"])
                        U.* (mig_noop () :: U.Mig "e" '["c"])
      Right (U.Backwards, [])
         @=? fmap plan_bits
                  (U.mkPlan migs [] (U.Target U.Backwards []))

  , HU.testCase "five migs, empty ran, backwards explicit" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
                        U.* (mig_noop () :: U.Mig "b" '[])
                        U.* (mig_noop () :: U.Mig "c" '["b"])
                        U.* (mig_noop () :: U.Mig "d" '["a","c"])
                        U.* (mig_noop () :: U.Mig "e" '["c"])
      Right (U.Backwards, [])
         @=? fmap plan_bits
                  (U.mkPlan migs [] (U.Target U.Backwards ["e","b","c"]))

  , HU.testCase "five migs, empty ran, backwards for impossible forwards" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
                        U.* (mig_noop () :: U.Mig "b" '[])
                        U.* (mig_noop () :: U.Mig "c" '["b"])
                        U.* (mig_noop () :: U.Mig "d" '["a","c"])
                        U.* (mig_noop () :: U.Mig "e" '["c"])
      Right (U.Backwards, [])
         @=? fmap plan_bits
                  (U.mkPlan migs [] (U.Target U.Backwards ["d","a"]))

  , QC.testProperty "five migs, bad ran all" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
                        U.* (mig_noop () :: U.Mig "b" '[])
                        U.* (mig_noop () :: U.Mig "c" '["b"])
                        U.* (mig_noop () :: U.Mig "d" '["a","c"])
                        U.* (mig_noop () :: U.Mig "e" '["c"])
      let g = (,) <$> genDirection
                  <*> fmap Set.fromList (QC.sublistOf ["a","b","c","d","e"])
      QC.forAll g $ \(d, mIds) -> do
        qcEqLeft U.Err_Plan_HistoryUnknown
          (U.mkPlan migs ["a","e","c","b","d"] (U.Target d mIds))

  , QC.testProperty "five migs, bad ran some" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
                        U.* (mig_noop () :: U.Mig "b" '[])
                        U.* (mig_noop () :: U.Mig "c" '["b"])
                        U.* (mig_noop () :: U.Mig "d" '["a","c"])
                        U.* (mig_noop () :: U.Mig "e" '["c"])
      let g = (,) <$> genDirection
                  <*> fmap Set.fromList (QC.sublistOf ["a","b","c","d","e"])
      QC.forAll g $ \(d, mIds) -> do
        qcEqLeft U.Err_Plan_HistoryUnknown
          (U.mkPlan migs ["a","d"] (U.Target d mIds))

  , HU.testCase "five migs, same ran, forwards implicit" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
                        U.* (mig_noop () :: U.Mig "b" '[])
                        U.* (mig_noop () :: U.Mig "c" '["b"])
                        U.* (mig_noop () :: U.Mig "d" '["a","c"])
                        U.* (mig_noop () :: U.Mig "e" '["c"])
      Right (U.Forwards, [])
         @=? fmap plan_bits
                  (U.mkPlan migs ["b","a","c","e","d"]
                            (U.Target U.Forwards []))

  , HU.testCase "five migs, same ran, forwards explicit" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
                        U.* (mig_noop () :: U.Mig "b" '[])
                        U.* (mig_noop () :: U.Mig "c" '["b"])
                        U.* (mig_noop () :: U.Mig "d" '["a","c"])
                        U.* (mig_noop () :: U.Mig "e" '["c"])
      Right (U.Forwards, [])
         @=? fmap plan_bits
                  (U.mkPlan migs ["a","b","c","e","d"]
                            (U.Target U.Forwards ["e","b","c"]))

  , HU.testCase "five migs, same ran, backwards implicit" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
                        U.* (mig_noop () :: U.Mig "b" '[])
                        U.* (mig_noop () :: U.Mig "c" '["b"])
                        U.* (mig_noop () :: U.Mig "d" '["a","c"])
                        U.* (mig_noop () :: U.Mig "e" '["c"])
      Right (U.Backwards, ["b","a","c","e","d"])
         @=? fmap plan_bits
                  (U.mkPlan migs ["b","a","c","e","d"]
                            (U.Target U.Backwards []))

  , HU.testCase "five migs, same ran, some backwards explicit" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
                        U.* (mig_noop () :: U.Mig "b" '[])
                        U.* (mig_noop () :: U.Mig "c" '["b"])
                        U.* (mig_noop () :: U.Mig "d" '["a","c"])
                        U.* (mig_noop () :: U.Mig "e" '["c"])
      Right (U.Backwards, ["a","d"])
         @=? fmap plan_bits
                  (U.mkPlan migs ["a","b","c","e","d"]
                            (U.Target U.Backwards ["a","d"]))

  , HU.testCase "five migs, same ran, backwards impossible" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
                        U.* (mig_noop () :: U.Mig "b" '[])
                        U.* (mig_noop () :: U.Mig "c" '["b"])
                        U.* (mig_noop () :: U.Mig "d" '["a","c"])
                        U.* (mig_noop () :: U.Mig "e" '["c"])
      huEqLeft U.Err_Plan_TargetImpossible
        (U.mkPlan migs ["a","b","c","d","e"]
           (U.Target U.Backwards ["b"]))

  , HU.testCase "five migs, some ran, one backwards explicit" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
                        U.* (mig_noop () :: U.Mig "b" '[])
                        U.* (mig_noop () :: U.Mig "c" '["b"])
                        U.* (mig_noop () :: U.Mig "d" '["a","c"])
                        U.* (mig_noop () :: U.Mig "e" '["c"])
      Right (U.Backwards, ["c"])
         @=? fmap plan_bits
                  (U.mkPlan migs ["a","b","c"]
                            (U.Target U.Backwards ["c"]))

  , HU.testCase "five migs, some ran, forwards impossible" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
                        U.* (mig_noop () :: U.Mig "b" '[])
                        U.* (mig_noop () :: U.Mig "c" '["b"])
                        U.* (mig_noop () :: U.Mig "d" '["a","c"])
                        U.* (mig_noop () :: U.Mig "e" '["c"])
      huEqLeft U.Err_Plan_TargetImpossible
        (U.mkPlan migs ["a","b"] (U.Target U.Forwards ["e"]))

  , HU.testCase "five migs, some ran, backwards impossible" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
                        U.* (mig_noop () :: U.Mig "b" '[])
                        U.* (mig_noop () :: U.Mig "c" '["b"])
                        U.* (mig_noop () :: U.Mig "d" '["a","c"])
                        U.* (mig_noop () :: U.Mig "e" '["c"])
      huEqLeft U.Err_Plan_TargetImpossible
        (U.mkPlan migs ["a","b","c"] (U.Target U.Backwards ["b"]))

  , HU.testCase "five migs, some ran, one backwards explicit gone" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
                        U.* (mig_noop () :: U.Mig "b" '[])
                        U.* (U.Gone :: U.Mig "c" '["b"])
                        U.* (mig_noop () :: U.Mig "d" '["a","c"])
                        U.* (mig_noop () :: U.Mig "e" '["c"])
      huEqLeft (U.Err_Plan_TargetsGone ["c"])
        (U.mkPlan migs ["a","b","c"] (U.Target U.Backwards ["c"]))

  , HU.testCase "five migs, some ran, some backwards explicit gone" $ do
      let migs = U.migs U.* (U.Gone :: U.Mig "a" '[])
                        U.* (mig_noop () :: U.Mig "b" '[])
                        U.* (U.Gone :: U.Mig "c" '["b"])
                        U.* (mig_noop () :: U.Mig "d" '["a","c"])
                        U.* (mig_noop () :: U.Mig "e" '["c"])
      huEqLeft (U.Err_Plan_TargetsGone ["c"])
        (U.mkPlan migs ["a","b","c"] (U.Target U.Backwards ["c","b"]))

  , HU.testCase "five migs, some ran, one backwards explicit one path gone" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
                        U.* (mig_noop () :: U.Mig "b" '[])
                        U.* (U.Gone :: U.Mig "c" '["b"])
                        U.* (mig_noop () :: U.Mig "d" '["a","c"])
                        U.* (mig_noop () :: U.Mig "e" '["c"])
      Right (U.Backwards, ["a"])
         @=? fmap plan_bits
             (U.mkPlan migs ["a","b","c","d"] (U.Target U.Backwards ["a"]))

  , HU.testCase "five migs, some ran, two backwards explicit gone" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
                        U.* (mig_noop () :: U.Mig "b" '[])
                        U.* (U.Gone :: U.Mig "c" '["b"])
                        U.* (mig_noop () :: U.Mig "d" '["a","c"])
                        U.* (mig_noop () :: U.Mig "e" '["c"])
      huEqLeft (U.Err_Plan_TargetsGone ["c"])
        (U.mkPlan migs ["a","b","c"] (U.Target U.Backwards ["c","b"]))

  , HU.testCase "five migs, some ran, backwards implicit gone" $ do
      let migs = U.migs U.* (U.Gone :: U.Mig "a" '[])
                        U.* (mig_noop () :: U.Mig "b" '[])
                        U.* (U.Gone :: U.Mig "c" '["b"])
                        U.* (mig_noop () :: U.Mig "d" '["a","c"])
                        U.* (mig_noop () :: U.Mig "e" '["c"])
      huEqLeft (U.Err_Plan_TargetsGone ["c","a"])
        (U.mkPlan migs ["a","b","c"] (U.Target U.Backwards []))

  , HU.testCase "five migs, some ran, backwards diamond implicit gone" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
                        U.* (U.Gone :: U.Mig "b" '["a"])
                        U.* (U.Gone :: U.Mig "c" '["a"])
                        U.* (mig_noop () :: U.Mig "d" '["a","c"])
                        U.* (mig_noop () :: U.Mig "e" '["c"])
      huEqLeft (U.Err_Plan_TargetsGone ["b","c"])
        (U.mkPlan migs ["a","b","c"] (U.Target U.Backwards []))

  , HU.testCase "five migs, some ran, one forwards explicit gone" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
                        U.* (mig_noop () :: U.Mig "b" '[])
                        U.* (U.Gone :: U.Mig "c" '["b"])
                        U.* (mig_noop () :: U.Mig "d" '["a","c"])
                        U.* (mig_noop () :: U.Mig "e" '["c"])
      huEqLeft (U.Err_Plan_TargetsGone ["c"])
        (U.mkPlan migs ["a","b"] (U.Target U.Forwards ["c"]))

  , HU.testCase "five migs, some ran, some forwards explicit gone" $ do
      let migs = U.migs U.* (U.Gone :: U.Mig "a" '[])
                        U.* (mig_noop () :: U.Mig "b" '[])
                        U.* (U.Gone :: U.Mig "c" '["b"])
                        U.* (mig_noop () :: U.Mig "d" '["a","c"])
                        U.* (mig_noop () :: U.Mig "e" '["c"])
      huEqLeft (U.Err_Plan_TargetsGone ["c","a"])
        (U.mkPlan migs ["b"] (U.Target U.Forwards ["c","b","a"]))

  , HU.testCase "five migs, some ran, one forwards explicit one path gone" $ do
      let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[])
                        U.* (mig_noop () :: U.Mig "b" '[])
                        U.* (U.Gone :: U.Mig "c" '["b"])
                        U.* (mig_noop () :: U.Mig "d" '["a","b"])
                        U.* (mig_noop () :: U.Mig "e" '["d"])
      Right (U.Forwards, ["a","b","d","e"])
         @=? fmap plan_bits
             (U.mkPlan migs [] (U.Target U.Forwards ["a","b","d","e"]))

  , HU.testCase "five migs, some ran, forwards implicit gone" $ do
      let migs = U.migs U.* (U.Gone :: U.Mig "a" '[])
                        U.* (mig_noop () :: U.Mig "b" '[])
                        U.* (U.Gone :: U.Mig "c" '["b"])
                        U.* (mig_noop () :: U.Mig "d" '["a","c"])
                        U.* (mig_noop () :: U.Mig "e" '["c"])
      huEqLeft (U.Err_Plan_TargetsGone ["c","a"])
        (U.mkPlan migs ["b"] (U.Target U.Forwards []))

  ]


ttRun :: Tasty.TestTree
ttRun = Tasty.testGroup "run"
  [ HU.testCase "empty registry, empty migs, forwards implicit" $
      withTestDi $ \di ->
      withExpectedTestRegistry di U.Clean [] $ \reg ->
      huExpect [] $ \f -> do
         Right plan <- U.getPlan di U.migs reg (U.Target U.Forwards [])
         U.run di reg plan

  , HU.testCase "empty registry, two migs, forwards implicit" $
      withTestDi $ \di ->
      withExpectedTestRegistry di U.Clean ["a","b"] $ \reg ->
      huExpect [4,1,2,5] $ \f -> do
         let migs = U.migs
                U.* (mig_noop () :: U.Mig "a" '[])
                U.* (U.Mig (U.Store (\_ _ () -> f 1)
                                    (\_ _ k -> f 2 >> k ())
                                    (\_ _ -> f 3))
                           (U.Backup (\_ k -> f 4 >> k ()))
                           (U.Change (\_ _ _ _ -> f 5))
                       :: U.Mig "b" '["a"])
         Right plan <- U.getPlan di migs reg (U.Target U.Forwards [])
         U.run di reg plan

  , HU.testCase "empty registry, two migs, fail sync backup, forwards implicit" $
      withTestDi $ \di ->
      withExpectedTestRegistry di U.Clean ["a"] $ \reg ->
      huExpectFailSync "x" [] $ \f -> do
         let migs = U.migs
                U.* (mig_noop () :: U.Mig "a" '[])
                U.* (U.Mig (U.Store (\_ _ () -> f 1)
                                    (\_ _ k -> f 2 >> k ())
                                    (\_ _ -> f 3))
                           (U.Backup (\_ k -> fail_sync "x" >> f 4 >> k ()))
                           (U.Change (\_ _ _ _ -> f 5))
                       :: U.Mig "b" '[])
         Right plan <- U.getPlan di migs reg (U.Target U.Forwards [])
         U.run di reg plan

  , HU.testCase "empty registry, two migs, fail sync save, forwards implicit" $
      withTestDi $ \di ->
      withExpectedTestRegistry di U.Clean ["a"] $ \reg ->
      huExpectFailSync "x" [4] $ \f -> do
         let migs = U.migs
                U.* (mig_noop () :: U.Mig "a" '[])
                U.* (U.Mig (U.Store (\_ _ () -> fail_sync "x" >> f 1)
                                    (\_ _ k -> f 2 >> k ())
                                    (\_ _ -> f 3))
                           (U.Backup (\_ k -> f 4 >> k ()))
                           (U.Change (\_ _ _ _ -> f 5))
                       :: U.Mig "b" '[])
         Right plan <- U.getPlan di migs reg (U.Target U.Forwards [])
         U.run di reg plan

  , HU.testCase "empty registry, two migs, fail sync load, forwards implicit" $
      withTestDi $ \di ->
      withExpectedTestRegistry di U.Clean ["a"] $ \reg ->
      huExpectFailSync "x" [4,1] $ \f -> do
         let migs = U.migs
                U.* (mig_noop () :: U.Mig "a" '[])
                U.* (U.Mig (U.Store (\_ _ () -> f 1)
                                    (\_ _ k -> fail_sync "x" >> f 2 >> k ())
                                    (\_ _ -> f 3))
                           (U.Backup (\_ k -> f 4 >> k ()))
                           (U.Change (\_ _ _ _ -> f 5))
                       :: U.Mig "b" '[])
         Right plan <- U.getPlan di migs reg (U.Target U.Forwards [])
         U.run di reg plan

  , HU.testCase "empty registry, two migs, fail sync change normal, forwards implicit" $
      withTestDi $ \di ->
      withExpectedTestRegistry di U.Clean ["a"] $ \reg ->
      huExpectFailSync "x" [4,1,2,6,3] $ \f -> do
         let migs = U.migs
                U.* (mig_noop () :: U.Mig "a" '[])
                U.* (U.Mig (U.Store (\_ _ () -> f 1)
                                    (\_ _ k -> f 2 >> k ())
                                    (\_ _ -> f 3))
                           (U.Backup (\_ k -> f 4 >> k ()))
                           (U.Change (\_ d m _ -> case (d,m) of
                                        (U.Forwards, U.Normal) ->
                                           fail_sync "x" >> f 5
                                        (U.Backwards, U.Recovery) -> f 6
                                        _ -> error "impossible"))
                       :: U.Mig "b" '[])
         Right plan <- U.getPlan di migs reg (U.Target U.Forwards [])
         U.run di reg plan

  , HU.testCase "empty registry, two migs, fail sync change normal and recovery, forwards implicit" $
      withTestDi $ \di ->
      withExpectedTestRegistry di (U.Dirty "b" U.Forwards) ["a"] $ \reg ->
      huExpectFailSync "x" [4,1,2] $ \f -> do
         let migs = U.migs
                U.* (mig_noop () :: U.Mig "a" '[])
                U.* (U.Mig (U.Store (\_ _ () -> f 1)
                                    (\_ _ k -> f 2 >> k ())
                                    (\_ _ -> f 3))
                           (U.Backup (\_ k -> f 4 >> k ()))
                           (U.Change (\_ d m _ -> case (d,m) of
                                        (U.Forwards, U.Normal) ->
                                           fail_sync "x" >> f 5
                                        (U.Backwards, U.Recovery) ->
                                           fail_sync "y" >> f 6
                                        _ -> error "impossible"))
                       :: U.Mig "b" '[])
         Right plan <- U.getPlan di migs reg (U.Target U.Forwards [])
         U.run di reg plan
  ]

--------------------------------------------------------------------------------
huExpect :: [Int] -> ((Int -> IO ()) -> IO x) -> IO x
huExpect as0 k = do
  mv <- newMVar []
  x <- k (\a -> modifyMVar_ mv (\as -> pure $! (a:as)))
  as <- takeMVar mv
  as0 @=? reverse as
  pure x

huExpectFailSync :: String -> [Int] -> ((Int -> IO ()) -> IO ()) -> IO ()
huExpectFailSync s as0 k = do
  mv <- newMVar []
  x <- Ex.catch
    (k (\a -> modifyMVar_ mv (\as -> pure $! (a:as))))
    (\e@(Fail s') -> when (s' /= s) (Ex.throwM e))
  as <- takeMVar mv
  as0 @=? reverse as
  pure x

withTestDi :: (Di.Core.Di level path message -> IO a) -> IO a
withTestDi = Di.Core.new (\_ -> pure ())

withExpectedTestRegistry
  :: forall a. Di.Df1 -> U.Status -> [U.MigId] -> (U.Registry -> IO a) -> IO a
withExpectedTestRegistry di sex idsex k = do
  dir <- getTempDir
  Moto.File.withRegistry (dir ++ "/reg") $ \reg -> do
    Ex.finally (k reg) $ do
      s <- Ex.evaluate =<< U.registry_state reg di
      (sex, idsex) @=? (U.state_status s, map fst (U.state_committed s))

getTempDir :: IO FilePath
getTempDir = do
  tmp_dir <- Dir.getTemporaryDirectory
  fix $ \k -> do
    w :: Word64 <- System.Random.randomIO
    let fn :: FilePath = tmp_dir </> ('d' : show w)
    Ex.try (Dir.createDirectory fn) >>= \case
      Right () -> pure fn
      Left e | IO.isAlreadyExistsError e -> k
             | otherwise -> Ex.throwM e

plan_bits :: U.Plan -> (U.Direction, [U.MigId])
plan_bits (U.Plan d s) = (d, toList (fmap fst s))

state_bits :: U.State -> (U.Status, [U.MigId])
state_bits s = (U.state_status s, fst <$> U.state_committed s)

genDirection :: QC.Gen U.Direction
genDirection = QC.oneof [ pure U.Backwards, pure U.Forwards ]

genMigId :: QC.Gen U.MigId
genMigId = do c <- QC.arbitrary
              cs <- QC.arbitrary
              pure (fromString (c:cs))

--------------------------------------------------------------------------------

-- Compare some @'Left' a@ without requiring constraints on @b@.
huEqLeft :: forall a b. (Eq a, Show a) => a -> Either a b -> HU.Assertion
huEqLeft a (Left a') = Left a @=? (Left a' :: Either a ())
huEqLeft a _ = fail (show (Left a :: Either a ()) ++ " /= Right _")

-- Compare some @'Left' a@ without requiring constraints on @b@.
qcEqLeft :: forall a b. (Eq a, Show a) => a -> Either a b -> QC.Property
qcEqLeft a (Left a') = Left a === (Left a' :: Either a ())
qcEqLeft a _ = show (Left a :: Either a ()) === "Right _"