Add Fail effect (#199)

* Add Fail effect

* Add inlining to Fail interpreters, make Fail newtype

* Hide visibility of Polysemy.Fixpoint.bomb, fix changelog

* Revert "Hide visibility of Polysemy.Fixpoint.bomb, fix changelog"

This reverts commit 5b043ed215.

* Move Polysemy.Internal.Fail to Polysemy.Fail.Type. Fixed inconsistency in docs

polysemy.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 8270550ff4f07c1da7b354658c67baeb52909c17c4627b20cc55779789133beb
+-- hash: ff7213d283da75830205760ef903cd73a3feb2c082b648ce653ab85d1291db8f
 
 name:           polysemy
 version:        1.0.0.0
@@ -44,6 +44,8 @@ library
       Polysemy.Embed
       Polysemy.Embed.Type
       Polysemy.Error
+      Polysemy.Fail
+      Polysemy.Fail.Type
       Polysemy.Fixpoint
       Polysemy.Input
       Polysemy.Internal
@@ -113,6 +115,7 @@ test-suite polysemy-test
       AsyncSpec
       BracketSpec
       DoctestSpec
+      FailSpec
       FixpointSpec
       FusionSpec
       HigherOrderSpec

src/Polysemy/Fail.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+
+module Polysemy.Fail
+  ( -- * Effect
+    Fail(..)
+
+    -- * Interpretations
+  , runFail
+  , failToError
+  , failToNonDet
+  , failToEmbed
+  ) where
+
+import Control.Applicative
+import Polysemy
+import Polysemy.Fail.Type
+import Polysemy.Error
+import Polysemy.NonDet
+import Control.Monad.Fail as Fail
+
+------------------------------------------------------------------------------
+-- | Run a 'Fail' effect purely.
+runFail :: Sem (Fail ': r) a
+        -> Sem r (Either String a)
+runFail = runError . reinterpret (\(Fail s) -> throw s)
+{-# INLINE runFail #-}
+
+------------------------------------------------------------------------------
+-- | Transform a 'Fail' effect into an @'Error' e@ effect,
+-- through providing a function for transforming any failure
+-- to an exception.
+failToError :: Member (Error e) r
+            => (String -> e)
+            -> Sem (Fail ': r) a
+            -> Sem r a
+failToError f = interpret $ \(Fail s) -> throw (f s)
+{-# INLINE failToError #-}
+
+------------------------------------------------------------------------------
+-- | Transform a 'Fail' effect into a 'NonDet' effect,
+-- through mapping any failure to 'empty'.
+failToNonDet :: Member NonDet r
+             => Sem (Fail ': r) a
+             -> Sem r a
+failToNonDet = interpret $ \(Fail _) -> empty
+{-# INLINE failToNonDet #-}
+
+------------------------------------------------------------------------------
+-- | Run a 'Fail' effect in terms of an underlying 'MonadFail' instance.
+failToEmbed :: forall m a r
+             . (Member (Embed m) r, MonadFail m)
+            => Sem (Fail ': r) a
+            -> Sem r a
+failToEmbed = interpret $ \(Fail s) -> embed @m (Fail.fail s)
+{-# INLINE failToEmbed #-}

src/Polysemy/Fail/Type.hs

@@ -0,0 +1,3 @@
+module Polysemy.Fail.Type where
+
+newtype Fail m a = Fail String

src/Polysemy/Internal.hs

@@ -33,8 +33,9 @@ import Control.Monad.Fix
 import Control.Monad.IO.Class
 import Data.Functor.Identity
 import Data.Kind
-import Polysemy.Internal.Fixpoint
 import Polysemy.Embed.Type
+import Polysemy.Fail.Type
+import Polysemy.Internal.Fixpoint
 import Polysemy.Internal.NonDet
 import Polysemy.Internal.PluginLookup
 import Polysemy.Internal.Union
@@ -271,9 +272,10 @@ instance (Member NonDet r) => MonadPlus (Sem r) where
   mzero = empty
   mplus = (<|>)
 
--- | @since 0.2.1.0
-instance (Member NonDet r) => MonadFail (Sem r) where
-  fail = const empty
+-- | TODO: @since _
+instance (Member Fail r) => MonadFail (Sem r) where
+  fail = send . Fail
+  {-# INLINE fail #-}
 
 
 ------------------------------------------------------------------------------

test/AlternativeSpec.hs

@@ -6,11 +6,6 @@ import Test.Hspec
 import Control.Applicative
 import Polysemy.Trace
 
-semFail :: Member NonDet r => Maybe Bool -> Sem r Bool
-semFail mb = do
-  Just b <- pure mb
-  pure b
-
 runAlt :: Alternative f => Sem '[NonDet] a -> f a
 runAlt = run . runNonDet
 
@@ -31,14 +26,6 @@ spec = parallel $ do
       runAlt (empty <|> pure '2') `shouldBe` (Just '2')
       runAlt (pure '1' <|> empty) `shouldBe` (Just '1')
 
-  describe "MonadFail instance" $ do
-    it "should call empty via fail" $ do
-      runAlt (semFail Nothing) `shouldBe` Nothing
-      runAlt (semFail Nothing) `shouldBe` []
-    it "should work fine for non-failing patterns" $ do
-      runAlt (semFail $ Just True) `shouldBe` Just True
-      runAlt (semFail $ Just False) `shouldBe` [False]
-
   describe "runNonDetMaybe" $ do
     it "should skip second branch if the first branch succeeds" $ do
       (run . runNonDetMaybe . runTraceList) failtrace

test/FailSpec.hs

@@ -0,0 +1,25 @@
+module FailSpec where
+
+import Polysemy
+import Polysemy.Fail
+import Polysemy.NonDet
+import Test.Hspec
+import Control.Applicative
+
+semFail :: Member Fail r => Maybe Bool -> Sem r Bool
+semFail mb = do
+  Just b <- pure mb
+  pure b
+
+runAlt :: Alternative f => Sem '[Fail, NonDet] a -> f a
+runAlt = run . runNonDet . failToNonDet
+
+spec :: Spec
+spec = parallel $ do
+  describe "MonadFail instance with failToNonDet" $ do
+    it "should call empty via fail" $ do
+      runAlt (semFail Nothing) `shouldBe` Nothing
+      runAlt (semFail Nothing) `shouldBe` []
+    it "should work fine for non-failing patterns" $ do
+      runAlt (semFail $ Just True) `shouldBe` Just True
+      runAlt (semFail $ Just False) `shouldBe` [False]