Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

2 changed files:

Changes:

  • testsuite/tests/MiniQuickCheck.hs
    ... ... @@ -2,6 +2,7 @@
    2 2 
     {-# LANGUAGE DerivingStrategies         #-}
    3 3 
     {-# LANGUAGE GeneralisedNewtypeDeriving #-}
    4 4 
     {-# LANGUAGE RecordWildCards            #-}
    5 
    +{-# LANGUAGE TypeApplications           #-}
    5 6 
     {-# LANGUAGE TypeFamilies               #-}
    6 7
    7 8 
     -- | A minimal QuickCheck-like property testing framework for use in the GHC
    ... ... @@ -52,6 +53,8 @@ module MiniQuickCheck
    52 53 
       ) where
    53 54
    54 55 
     -- base
    56 
    +import Control.Exception
    57 
    +  ( SomeException, displayException, evaluate, try )
    55 58 
     import Control.Monad.IO.Class
    56 59 
       ( liftIO )
    57 60 
     import Data.Bits
    ... ... @@ -181,16 +184,39 @@ nest :: String -> ReaderT RunS IO a -> ReaderT RunS IO a
    181 184 
     nest c = local (\s -> s { depth = depth s + 1, context = c : context s })
    182 185
    183 186 
     runPropertyCheck :: PropertyCheck -> ReaderT RunS IO Result
    184 
    -runPropertyCheck (PropertyBinaryOp ok desc s1 s2) =
    185 
    -  if ok
    186 
    -    then return Success
    187 
    -    else do
    188 
    -      ctx <- context <$> ask
    189 
    -      let msg = "Failure: " ++ s1 ++ " " ++ desc ++ " " ++ s2
    190 
    -      putMsg msg
    191 
    -      return (Failure [msg : ctx])
    192 
    -runPropertyCheck (PropertyAnd a b) =
    193 
    -  (<>) <$> runPropertyCheck a <*> runPropertyCheck b
    187 
    +runPropertyCheck pcThunk = do
    188 
    +  -- See Note [Catching exceptions in property evaluation].
    189 
    +  pcRes <- liftIO $ try @SomeException (evaluate pcThunk)
    190 
    +  case pcRes of
    191 
    +    Left  e -> reportFailure ("Failure: exception: " ++ displayException e)
    192 
    +    Right (PropertyAnd a b) ->
    193 
    +      (<>) <$> runPropertyCheck a <*> runPropertyCheck b
    194 
    +    Right (PropertyBinaryOp ok desc s1 s2) -> do
    195 
    +      okRes <- liftIO $ try @SomeException (evaluate ok)
    196 
    +      case okRes of
    197 
    +        Right True  -> return Success
    198 
    +        Right False -> reportFailure ("Failure: " ++ s1 ++ " " ++ desc ++ " " ++ s2)
    199 
    +        Left  e     -> reportFailure ("Failure: exception: " ++ displayException e)
    200 
    +
    201 
    +reportFailure :: String -> ReaderT RunS IO Result
    202 
    +reportFailure msg = do
    203 
    +  ctx <- context <$> ask
    204 
    +  putMsg msg
    205 
    +  return (Failure [msg : ctx])
    206 
    +
    207 
    +-- Note [Catching exceptions in property evaluation]
    208 
    +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    209 
    +-- A property like `\a b -> let !r = a `div` 0 in r === b` builds a
    210 
    +-- `PropertyCheck` thunk whose forcing raises an exception -- in this case
    211 
    +-- already at the `PropertyBinaryOp` constructor, before its `ok` field is
    212 
    +-- ever inspected. Other properties may force `ok = (s1 == s2)` instead and
    213 
    +-- raise from there.
    214 
    +--
    215 
    +-- To handle both, we `evaluate` first the `PropertyCheck` thunk and then
    216 
    +-- the `ok` field, each inside `try`, and report any exception through the
    217 
    +-- normal `reportFailure` path. The surrounding loop then still prints
    218 
    +-- "With arguments ... (Seed: ...)" and the test driver continues with
    219 
    +-- subsequent properties instead of aborting.
    194 220
    195 221 
     runProperty :: Iterations -> Property -> ReaderT RunS IO Result
    196 222 
     runProperty (Iterations iters) (Prop p) = do

  • testsuite/tests/numeric/should_run/foundation.hs
    ... ... @@ -77,13 +77,42 @@ testMultiplicative _ = Group "Multiplicative"
    77 77 
         , Property "a * b == Integer(a) * Integer(b)" $ \(a :: a) (b :: a) -> a * b === fromInteger (toInteger a * toInteger b)
    78 78 
         ]
    79 79
    80 
    -testDividible :: forall a . (Show a, Eq a, Integral a, Num a, Arbitrary a, Typeable a)
    80 
    +-- | Divisibility test for Bounded Integral types (Int, Int{8,16,32,64},
    81 
    +-- Word, Word{8,16,32,64}).
    82 
    +testDivisible :: forall a . (Show a, Eq a, Bounded a, Integral a, Num a, Arbitrary a, Typeable a)
    81 83 
                   => Proxy a -> Test
    82 
    -testDividible _ = Group "Divisible"
    84 
    +testDivisible _ = Group "Divisible"
    85 
    +    [ Property "(x `div` y) * y + (x `mod` y) == x" $ \(a :: a) (NonZero b) ->
    86 
    +            -- See Note [Skipping minBound `div` (-1)].
    87 
    +            if (minBound :: a) < 0 && a == minBound && b == (-1)
    88 
    +              then True === True
    89 
    +              else a === (a `div` b) * b + (a `mod` b)
    90 
    +    ]
    91 
    +
    92 
    +-- | Divisibility test for unbounded Integral types (Integer). No overflow
    93 
    +-- can occur here, so the property holds without exception for all NonZero b.
    94 
    +testDivisibleUnbounded :: forall a . (Show a, Eq a, Integral a, Num a, Arbitrary a, Typeable a)
    95 
    +                       => Proxy a -> Test
    96 
    +testDivisibleUnbounded _ = Group "Divisible"
    83 97 
         [ Property "(x `div` y) * y + (x `mod` y) == x" $ \(a :: a) (NonZero b) ->
    84 98 
                 a === (a `div` b) * b + (a `mod` b)
    85 99 
         ]
    86 100
    101 
    +-- Note [Skipping minBound `div` (-1)]
    102 
    +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    103 
    +-- For a fixed-width *signed* Integral type, `minBound `div` (-1)` raises
    104 
    +-- ArithException(Overflow) because `-minBound` is not representable in the
    105 
    +-- type (e.g., for Int8, `-(-128)` would be 128, out of range). The div/mod
    106 
    +-- identity property cannot hold there, so we skip exactly that one pair.
    107 
    +--
    108 
    +-- We detect "signed Bounded" with `(minBound :: a) < 0`: True for Int{N},
    109 
    +-- False for Word{N}. This way unsigned Bounded types lose no coverage,
    110 
    +-- and only the genuine overflow sample is skipped for signed types.
    111 
    +--
    112 
    +-- For the unbounded `Integer`, no overflow can occur and we use a separate
    113 
    +-- 'testDivisibleUnbounded' (without the Bounded constraint or the skip).
    114 
    +-- See #27222.
    115 
    +
    87 116 
     testOperatorPrecedence :: forall a . (Show a, Eq a, Prelude.Num a, Integral a, Num a,  Arbitrary a, Typeable a)
    88 117 
                            => Proxy a -> Test
    89 118 
     testOperatorPrecedence _ = Group "Precedence"
    ... ... @@ -101,14 +130,26 @@ testOperatorPrecedence _ = Group "Precedence"
    101 130 
         ]
    102 131
    103 132
    104 
    -testNumber :: (Show a, Eq a, Prelude.Num a, Integral a, Num a, Arbitrary a, Typeable a)
    133 
    +testNumber :: (Show a, Eq a, Prelude.Num a, Bounded a, Integral a, Num a, Arbitrary a, Typeable a)
    105 134 
                => String -> Proxy a -> Test
    106 135 
     testNumber name proxy = Group name
    107 136 
         [ testIntegral proxy
    108 137 
         , testEqOrd proxy
    109 138 
         , testAdditive proxy
    110 139 
         , testMultiplicative proxy
    111 
    -    , testDividible proxy
    140 
    +    , testDivisible proxy
    141 
    +    , testOperatorPrecedence proxy
    142 
    +    ]
    143 
    +
    144 
    +-- | Variant of 'testNumber' for unbounded Integral types (e.g., Integer).
    145 
    +testNumberUnbounded :: (Show a, Eq a, Prelude.Num a, Integral a, Num a, Arbitrary a, Typeable a)
    146 
    +                    => String -> Proxy a -> Test
    147 
    +testNumberUnbounded name proxy = Group name
    148 
    +    [ testIntegral proxy
    149 
    +    , testEqOrd proxy
    150 
    +    , testAdditive proxy
    151 
    +    , testMultiplicative proxy
    152 
    +    , testDivisibleUnbounded proxy
    112 153 
         , testOperatorPrecedence proxy
    113 154 
         ]
    114 155
    ... ... @@ -119,7 +160,7 @@ testNumberRefs = Group "ALL"
    119 160 
         , testNumber "Int16" (Proxy :: Proxy Int16)
    120 161 
         , testNumber "Int32" (Proxy :: Proxy Int32)
    121 162 
         , testNumber "Int64" (Proxy :: Proxy Int64)
    122 
    -    , testNumber "Integer" (Proxy :: Proxy Integer)
    163 
    +    , testNumberUnbounded "Integer" (Proxy :: Proxy Integer)
    123 164 
         , testNumber "Word" (Proxy :: Proxy Word)
    124 165 
         , testNumber "Word8" (Proxy :: Proxy Word8)
    125 166 
         , testNumber "Word16" (Proxy :: Proxy Word16)
    ... ... @@ -399,7 +440,7 @@ testPrimops = Group "primop"
    399 440 
       , testPrimop "-#" (Primop.-#) (Wrapper.-#)
    400 441 
       , testPrimop "*#" (Primop.*#) (Wrapper.*#)
    401 442 
       , testPrimop "timesInt2#" Primop.timesInt2# Wrapper.timesInt2#
    402 
    -  , testPrimop "mulIntMayOflo#" Primop.mulIntMayOflo# Wrapper.mulIntMayOflo#
    443 
    +  , testPrimopMayOflo "mulIntMayOflo#" Primop.mulIntMayOflo# Wrapper.mulIntMayOflo#
    403 444 
       , testPrimopDivLike "quotInt#" Primop.quotInt# Wrapper.quotInt#
    404 445 
       , testPrimopDivLike "remInt#" Primop.remInt# Wrapper.remInt#
    405 446 
       , testPrimopDivLike "quotRemInt#" Primop.quotRemInt# Wrapper.quotRemInt#
    ... ... @@ -497,6 +538,31 @@ instance TestPrimop (Int# -> Int# -> Int#) where
    497 538 
       testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
    498 539 
       testPrimopShift s l r = Property s $ \ (uInt#-> x0) (BoundedShiftAmount @Int shift) -> wInt# (l x0 (uInt# shift)) === wInt# (r x0 (uInt# shift))
    499 540
    541 
    +-- | Compare two 'mulIntMayOflo#'-like primops only on whether their result
    542 
    +-- is zero. See Note [Comparing mulIntMayOflo# results].
    543 
    +testPrimopMayOflo :: String
    544 
    +                  -> (Int# -> Int# -> Int#)
    545 
    +                  -> (Int# -> Int# -> Int#)
    546 
    +                  -> Test
    547 
    +testPrimopMayOflo s l r =
    548 
    +    Property s $ \ (uInt# -> x0) (uInt# -> x1) ->
    549 
    +        (wInt# (l x0 x1) == 0) === (wInt# (r x0 x1) == 0)
    550 
    +
    551 
    +-- Note [Comparing mulIntMayOflo# results]
    552 
    +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    553 
    +-- The 'mulIntMayOflo#' primop is only specified to return 0 if the signed
    554 
    +-- multiplication does not overflow, and a non-zero value if it /may/
    555 
    +-- overflow (see Note [MO_S_MulMayOflo significant width] in
    556 
    +-- GHC.Cmm.MachOp). The exact non-zero value is unspecified and legitimately
    557 
    +-- differs between backends and between inlined vs. non-inlined call sites
    558 
    +-- (e.g., the LLVM backend's `isSMulOK` returns `sext_signbit(low) - high`,
    559 
    +-- which is some arbitrary non-zero word on overflow).
    560 
    +--
    561 
    +-- Comparing the raw Int# results bit-for-bit is therefore too strict and
    562 
    +-- causes spurious test failures whenever the random arguments happen to
    563 
    +-- overflow. We compare zero/non-zero instead, which matches the spec.
    564 
    +-- See #27222.
    565 
    +
    500 566 
     instance TestPrimop (Int# -> Int# -> (# Int#,Int# #)) where
    501 567 
       testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP2(wInt#,wInt#, (l x0 x1)) === WTUP2(wInt#,wInt#, (r x0 x1))
    502 568 
       testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP2(wInt#,wInt#, (l x0 x1)) === WTUP2(wInt#,wInt#, (r x0 x1))

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help