Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Add MonadFail instances where appropriate #233

Merged
merged 2 commits into from Mar 19, 2019

Conversation

Projects
None yet
3 participants
@HuwCampbell
Copy link
Contributor

HuwCampbell commented Nov 15, 2018

Some folks might use generators in do notation with a partial pattern match, this won't work with GHC 8.6 without a MonadFail instance.

Although it's probably not the best practice, I would imagine that discarding the non-matching sample is better than throwing an exception.

Other that that I just turned on a few warnings and fixed them.

@moodmosaic
Copy link
Member

moodmosaic left a comment

As an attempt to keep the campground clean until @jystic is back, a MonadFail instance is all we need. This also aligns pretty well with the MonadFail proposal:

diff --git a/hedgehog/hedgehog.cabal b/hedgehog/hedgehog.cabal
index 63aafae..24558f3 100644
--- a/hedgehog/hedgehog.cabal
+++ b/hedgehog/hedgehog.cabal
@@ -58,6 +58,7 @@ library
     , containers                      >= 0.4        && < 0.7
     , directory                       >= 1.2        && < 1.4
     , exceptions                      >= 0.7        && < 0.11
+    , fail                            == 4.9.*
     , lifted-async                    >= 0.7        && < 0.11
     , mmorph                          >= 1.0        && < 1.2
     , monad-control                   >= 1.0        && < 1.1
diff --git a/hedgehog/src/Hedgehog/Internal/Gen.hs b/hedgehog/src/Hedgehog/Internal/Gen.hs
index 466beb5..58ce255 100644
--- a/hedgehog/src/Hedgehog/Internal/Gen.hs
+++ b/hedgehog/src/Hedgehog/Internal/Gen.hs
@@ -158,6 +158,7 @@ import           Control.Monad (MonadPlus(..), filterM, replicateM, ap, join)
 import           Control.Monad.Base (MonadBase(..))
 import           Control.Monad.Catch (MonadThrow(..), MonadCatch(..))
 import           Control.Monad.Error.Class (MonadError(..))
+import           Control.Monad.Fail (MonadFail(..))
 import           Control.Monad.IO.Class (MonadIO(..))
 import           Control.Monad.Morph (MFunctor(..), MMonad(..), generalize)
 import           Control.Monad.Primitive (PrimMonad(..))
@@ -553,6 +554,10 @@ instance Monad m => Monad (GenT m) where
           runGenT size sk . k =<<
           runGenT size sm m
 
+instance Monad m => MonadFail (GenT m) where
+  fail _ =
+    mzero
+
 instance Monad m => Alternative (GenT m) where
   empty =
     mzero

/cc @thumphries @jystic

ghc-options:
-Wall
-Wall -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances

This comment has been minimized.

@moodmosaic

moodmosaic Nov 15, 2018

Member

Could we add those (and address them) on a separate pull request?

This comment has been minimized.

@HuwCampbell

HuwCampbell Nov 15, 2018

Author Contributor

I think that's reasonable.

@@ -76,8 +76,11 @@ library
, transformers-base >= 0.4 && < 0.5
, wl-pprint-annotated >= 0.0 && < 0.2

if !impl(ghc >= 8)
build-depends: fail == 4.9.*

This comment has been minimized.

@moodmosaic

moodmosaic Nov 15, 2018

Member

We may also just add fail, as it turns into an empty package when used with GHC > 8.0.1.

This comment has been minimized.

@HuwCampbell

HuwCampbell Nov 15, 2018

Author Contributor

Ok

@HuwCampbell

This comment has been minimized.

Copy link
Contributor Author

HuwCampbell commented Nov 16, 2018

If we only provide a MonadFail instance for GenT (as in you diff above) without a fail = Fail.fail implementation in Monad, one will see very different behaviours depending on whether -XMonadFailDesugaring is on or off. Wouldn't be ideal.

@HuwCampbell HuwCampbell force-pushed the HuwCampbell:topic/canonical_instances branch 2 times, most recently from 806ba3f to bfa634f Nov 16, 2018

@HuwCampbell

This comment has been minimized.

Copy link
Contributor Author

HuwCampbell commented Nov 16, 2018

I've minimised this PR to the smallest workable solution, will do the canonical versions in another PR.

@HuwCampbell HuwCampbell changed the title Topic/canonical instances Add MonadFail instances where appropriate Nov 16, 2018

@HuwCampbell HuwCampbell force-pushed the HuwCampbell:topic/canonical_instances branch from bfa634f to 45252c0 Nov 16, 2018

@moodmosaic

This comment has been minimized.

Copy link
Member

moodmosaic commented Nov 16, 2018

If we only provide a MonadFail instance for GenT (as in you diff above) without a fail = Fail.fail

There seems to be a pending discussion around this with plans to remove fail in GHC 8.8+

one will see very different behaviours depending on whether -XMonadFailDesugaring is on or off.

I didn't see any difference between GHC 7.10.3, 8.2.2, and 8.6.2 after taking out fail = Fail.fail:

maybeOne :: Gen (Maybe Int)
maybeOne = do
  Just n <-
    pure <$> Gen.constant (Just 1)
  return n

prop_maybeOne :: Property
prop_maybeOne =
  property $ do
    Just x <- forAll maybeOne
    assert $
      x == 1

That's why I didn't include fail = Fail.fail in the diff. Do you have an example?

@HuwCampbell

This comment has been minimized.

Copy link
Contributor Author

HuwCampbell commented Nov 16, 2018

That example never hits the Nothing case in the pattern match and therefore doesn't exercise MonadFail.

A simple change is from the hedgehog project in module Test.Hedgehog.Text. This won't fail on exception (but will fail on excess discards half the time) with this change.

genOdd :: Gen Int64
genOdd =
  let
    isOdd x =
      if odd x then
        Just x
      else
        Nothing
  in do
    Just x <- isOdd <$> Gen.int64 (Range.constant 1 maxBound)
    return x
@moodmosaic
Copy link
Member

moodmosaic left a comment

Awesome! I left two comments:

@moodmosaic

This comment has been minimized.

Copy link
Member

moodmosaic commented Nov 16, 2018

That example never hits the Nothing case in the pattern match and exercise MonadFail.

Indeed, good catch!

@moodmosaic
Copy link
Member

moodmosaic left a comment

Looking good on GHC 7.10.3, 8.2.2, and 8.6.2.

@moodmosaic
Copy link
Member

moodmosaic left a comment

Although it's probably not the best practice, I would imagine that discarding the non-matching sample is better than throwing an exception.

The thing is, we'd have to do a major version bump if we merge this. What if instead of

fail _ =
  mzero

we do something like

fail =
  error

/cc @jystic

Then we would get the exact behavior as on master c368be4.


For example:

diff --git a/hedgehog/test/Test/Hedgehog/Text.hs b/hedgehog/test/Test/Hedgehog/Text.hs
index 0a11e91..87bf960 100644
--- a/hedgehog/test/Test/Hedgehog/Text.hs
+++ b/hedgehog/test/Test/Hedgehog/Text.hs
@@ -19,13 +19,14 @@ genSize =
 genOdd :: Gen Int64
 genOdd =
   let
-    mkOdd x =
+    isOdd x =
       if odd x then
-        x
+        Just x
       else
-        pred x
-  in
-    mkOdd <$> Gen.int64 (Range.constant 1 maxBound)
+        Nothing
+  in do
+    Just x <- isOdd <$> Gen.int64 (Range.constant 1 maxBound)
+    return x
# GHC 8.6.2

#  fail =
#    error

━━━ Test.Hedgehog.Text ━━━
  ✓ prop_show_append_size passed 100 tests.
  ✓ prop_tripping_append_size passed 100 tests.
  ✗ prop_show_append_seed failed after 1 test.

       ┏━━ hedgehog\test\Test\Hedgehog\Text.hs ━━━
    43 ┃ checkShowAppend :: (Typeable a, Show a) => Gen a -> Property
    44 ┃ checkShowAppend gen =
    45 ┃   property $ do
    46 ┃     prec <- forAll genPrecedence
    47 ┃     x <- forAll gen
    48 ┃     xsuffix <- forAll genString
    49 ┃     ysuffix <- forAll genString
    50 ┃     showsPrec prec x xsuffix ++ ysuffix  === showsPrec prec x (xsuffix ++ ysuffix)
       ┃     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
       ┃     │ ━━━ Exception: ErrorCall ━━━
       ┃     │ Pattern match failure in do expression at /snapshot/src/hedgehog/hedgehog/hedgehog/test/Test/Hedgehog/Text.hs:28:5-10
       ┃     │ CallStack (from HasCallStack):
       ┃     │   error, called at /snapshot/src/hedgehog/hedgehog/hedgehog/src/Hedgehog/Internal/Gen.hs:563:5 in main:Hedgehog.Internal.Gen

    This failure can be reproduced by running:
    > recheck (Size 0) (Seed 7364526114514801996 15930828748873102837) prop_show_append_seed

  ✗ prop_tripping_append_seed failed after 2 tests.

       ┏━━ hedgehog\test\Test\Hedgehog\Text.hs ━━━
    52 ┃ trippingReadShow :: (Eq a, Typeable a, Show a, Read a) => Gen a -> Property
    53 ┃ trippingReadShow gen =
    54 ┃   property $ do
    55 ┃     prec <- forAll genPrecedence
    56 ┃     x <- forAll gen
    57 ┃     tripping x (\z -> showsPrec prec z "") readEither
       ┃     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
       ┃     │ ━━━ Exception: ErrorCall ━━━
       ┃     │ Pattern match failure in do expression at /snapshot/src/hedgehog/hedgehog/hedgehog/test/Test/Hedgehog/Text.hs:28:5-10
       ┃     │ CallStack (from HasCallStack):
       ┃     │   error, called at /snapshot/src/hedgehog/hedgehog/hedgehog/src/Hedgehog/Internal/Gen.hs:563:5 in main:Hedgehog.Internal.Gen

    This failure can be reproduced by running:
    > recheck (Size 1) (Seed 15417483394291888538 15013407834460730181) prop_tripping_append_seed

  ✗ 2 failed, 2 succeeded.
━━━ Test.Hedgehog.Seed ━━━
  ✓ prop_avoid_pathological_gamma_values passed 1 test.
  ✓ 1 succeeded.

vs

# GHC 8.6.2, HuwCampbell-topic/canonical_instances

#  fail _ =
#    mzero

━━━ Test.Hedgehog.Text ━━━
  ✓ prop_show_append_size passed 100 tests.
  ✓ prop_tripping_append_size passed 100 tests.
  ⚐ prop_show_append_seed gave up after 100 discards, passed 90 tests.
  ⚐ prop_tripping_append_seed gave up after 100 discards, passed 96 tests.
  ⚐ 2 gave up, 2 succeeded.
━━━ Test.Hedgehog.Seed ━━━
  ✓ prop_avoid_pathological_gamma_values passed 1 test.
  ✓ 1 succeeded.

instance Monad m => MonadFail (GenT m) where
fail _ =
mzero

This comment has been minimized.

@moodmosaic

@HuwCampbell HuwCampbell force-pushed the HuwCampbell:topic/canonical_instances branch from 5e434a4 to d770d50 Dec 6, 2018

@moodmosaic
Copy link
Member

moodmosaic left a comment

LGTM

@@ -58,6 +58,7 @@ library
, containers >= 0.4 && < 0.7
, directory >= 1.2 && < 1.4
, exceptions >= 0.7 && < 0.11
, fail == 4.9.*

This comment has been minimized.

@jystic

jystic Mar 10, 2019

Member

Would you mind keeping the same style as the other version number numbers? Makes it easier to bump the upper bounds in the future. Other than that I'm happy with these changes because I can do a release without bumping a major version. We can talk about the tradeoffs of mzero in another PR perhaps, but in general I don't like breaking changes if I can avoid it.

This comment has been minimized.

@HuwCampbell

HuwCampbell Mar 13, 2019

Author Contributor

Ok

This comment has been minimized.

@moodmosaic

moodmosaic Mar 13, 2019

Member

@jystic, @HuwCampbell just forced-pushed the change so it's looking good now 👍

HuwCampbell added some commits Nov 16, 2018

Add MonadFail instances for TestT and GenT
Use error for fail for GenT.

This is compatible with the current (default) implementation,
but may change in future to discard instead.

@HuwCampbell HuwCampbell force-pushed the HuwCampbell:topic/canonical_instances branch from d770d50 to b400bf1 Mar 13, 2019

@jystic jystic merged commit e6387b2 into hedgehogqa:master Mar 19, 2019

1 check passed

continuous-integration/travis-ci/pr The Travis CI build passed
Details
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.