cabal-install/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs

   1 {-# LANGUAGE StandaloneDeriving #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3
   4 module UnitTests.Distribution.Solver.Modular.RetryLog
   5   ( tests
   6   ) where
   7
   8 import Distribution.Solver.Modular.Message
   9 import Distribution.Solver.Modular.RetryLog
  10 import Distribution.Solver.Types.Progress
  11
  12 import Test.Tasty (TestTree)
  13 import Test.Tasty.HUnit (testCase, (@?=))
  14 import Test.Tasty.QuickCheck
  15   ( Arbitrary (..)
  16   , Blind (..)
  17   , listOf
  18   , oneof
  19   , testProperty
  20   , (===)
  21   )
  22
  23 type Log a = Progress a String String
  24
  25 tests :: [TestTree]
  26 tests =
  27   [ testProperty "'toProgress . fromProgress' is identity" $ \p ->
  28       toProgress (fromProgress p) === (p :: Log Int)
  29   , testProperty "'mapFailure f' is like 'foldProgress Step (Fail . f) Done'" $
  30       let mapFailureProgress f = foldProgress Step (Fail . f) Done
  31        in \(Blind f) p ->
  32             toProgress (mapFailure f (fromProgress p))
  33               === mapFailureProgress (f :: String -> Int) (p :: Log Int)
  34   , testProperty "'retry p f' is like 'foldProgress Step f Done p'" $
  35       \p (Blind f) ->
  36         toProgress (retry (fromProgress p) (fromProgress . f))
  37           === (foldProgress Step f Done (p :: Log Int) :: Log Int)
  38   , testProperty "failWith" $ \step failure ->
  39       toProgress (failWith step failure)
  40         === (Step step (Fail failure) :: Log Int)
  41   , testProperty "succeedWith" $ \step success ->
  42       toProgress (succeedWith step success)
  43         === (Step step (Done success) :: Log Int)
  44   , testProperty "continueWith" $ \step p ->
  45       toProgress (continueWith step (fromProgress p))
  46         === (Step step p :: Log Int)
  47   , testCase "tryWith with failure" $
  48       let failure = Fail "Error"
  49           s = Step Success
  50        in toProgress (tryWith Success $ fromProgress (s (s failure)))
  51             @?= (s (Step Enter (s (s (Step Leave failure)))) :: Log Message)
  52   , testCase "tryWith with success" $
  53       let done = Done "Done"
  54           s = Step Success
  55        in toProgress (tryWith Success $ fromProgress (s (s done)))
  56             @?= (s (Step Enter (s (s done))) :: Log Message)
  57   ]
  58
  59 instance
  60   (Arbitrary step, Arbitrary fail, Arbitrary done)
  61   => Arbitrary (Progress step fail done)
  62   where
  63   arbitrary = do
  64     steps <- listOf arbitrary
  65     end <- oneof [Fail `fmap` arbitrary, Done `fmap` arbitrary]
  66     return $ foldr Step end steps
  67
  68 deriving instance (Eq step, Eq fail, Eq done) => Eq (Progress step fail done)
  69
  70 deriving instance
  71   (Show step, Show fail, Show done)
  72   => Show (Progress step fail done)
  73
  74 deriving instance Eq Message
  75 deriving instance Show Message