cabal-install-solver/src/Distribution/Solver/Modular/RetryLog.hs

   1 {-# LANGUAGE Rank2Types #-}
   2 module Distribution.Solver.Modular.RetryLog
   3     ( RetryLog
   4     , toProgress
   5     , fromProgress
   6     , mapFailure
   7     , retry
   8     , failWith
   9     , succeedWith
  10     , continueWith
  11     , tryWith
  12     ) where
  13
  14 import Distribution.Solver.Compat.Prelude
  15 import Prelude ()
  16
  17 import Distribution.Solver.Modular.Message
  18 import Distribution.Solver.Types.Progress
  19
  20 -- | 'Progress' as a difference list that allows efficient appends at failures.
  21 newtype RetryLog step fail done = RetryLog {
  22     unRetryLog :: forall fail2 . (fail -> Progress step fail2 done)
  23                -> Progress step fail2 done
  24   }
  25
  26 -- | /O(1)/. Convert a 'RetryLog' to a 'Progress'.
  27 toProgress :: RetryLog step fail done -> Progress step fail done
  28 toProgress (RetryLog f) = f Fail
  29
  30 -- | /O(N)/. Convert a 'Progress' to a 'RetryLog'.
  31 fromProgress :: Progress step fail done -> RetryLog step fail done
  32 fromProgress l = RetryLog $ \f -> go f l
  33   where
  34     go :: (fail1 -> Progress step fail2 done)
  35        -> Progress step fail1 done
  36        -> Progress step fail2 done
  37     go _ (Done d) = Done d
  38     go f (Fail failure) = f failure
  39     go f (Step m ms) = Step m (go f ms)
  40
  41 -- | /O(1)/. Apply a function to the failure value in a log.
  42 mapFailure :: (fail1 -> fail2)
  43            -> RetryLog step fail1 done
  44            -> RetryLog step fail2 done
  45 mapFailure f l = retry l $ \failure -> RetryLog $ \g -> g (f failure)
  46
  47 -- | /O(1)/. If the first log leads to failure, continue with the second.
  48 retry :: RetryLog step fail1 done
  49       -> (fail1 -> RetryLog step fail2 done)
  50       -> RetryLog step fail2 done
  51 retry (RetryLog f) g =
  52     RetryLog $ \extendLog -> f $ \failure -> unRetryLog (g failure) extendLog
  53
  54 -- | /O(1)/. Create a log with one message before a failure.
  55 failWith :: step -> fail -> RetryLog step fail done
  56 failWith m failure = RetryLog $ \f -> Step m (f failure)
  57
  58 -- | /O(1)/. Create a log with one message before a success.
  59 succeedWith :: step -> done -> RetryLog step fail done
  60 succeedWith m d = RetryLog $ const $ Step m (Done d)
  61
  62 -- | /O(1)/. Prepend a message to a log.
  63 continueWith :: step
  64              -> RetryLog step fail done
  65              -> RetryLog step fail done
  66 continueWith m (RetryLog f) = RetryLog $ Step m . f
  67
  68 -- | /O(1)/. Prepend the given message and 'Enter' to the log, and insert
  69 -- 'Leave' before the failure if the log fails.
  70 tryWith :: Message -> RetryLog Message fail done -> RetryLog Message fail done
  71 tryWith m f =
  72   RetryLog $ Step m . Step Enter . unRetryLog (retry f (failWith Leave))