WIP: Adapt to MonadFail-related changes in base-4.13

`base-4.13` removes the `fail` method from the `Monad` class, leaving
it exclusively as a method of `MonadFail`, which is now re-exported
from the `Prelude`. This patch mirrors these changes on the
`singletons` side:

* `Fail`/`sFail` has been ripped out of `{P,S}Monad` in favor of new
  `{P,S}MonadFail` classes.
* A couple of functions in `singletons` needed to have their `Monad`
  constraints strengthened to `MonadFail` to mirror similar changes
  in `th-desugar`.

Addresses one bullet point of #356.

[ci skip]

CHANGES.md

@@ -78,6 +78,10 @@ Changelog for singletons project
   One benefit of this change is that one no longer needs defunctionalization
   symbols in order to partially apply `Σ`. As a result, `ΣSym0`, `ΣSym1`,
   and `ΣSym2` have been removed.
+* In line with corresponding changes in `base-4.13`, the `Fail`/`sFail` methods
+  of `{P,S}Monad` have been removed in favor of new `{P,S}MonadFail` classes
+  introduced in the `Data.Singletons.Prelude.Monad.Fail` module. These classes
+  are also re-exported from `Data.Singletons.Prelude`.
 * Fix a bug where expressions with explicit signatures involving function types
   would fail to single.
 

cabal.project

@@ -4,4 +4,4 @@ packages: .
 source-repository-package
   type: git
   location: https://github.com/goldfirere/th-desugar
-  tag: c67e84d2f6fdfd2aab1af3a86f646a7cc805d668
+  tag: ac631ac2ca5af38e785419c88cd8cb6437c36ee5

singletons.cabal

@@ -91,6 +91,7 @@ library
                       Data.Singletons.Prelude.List.NonEmpty
                       Data.Singletons.Prelude.Maybe
                       Data.Singletons.Prelude.Monad
+                      Data.Singletons.Prelude.Monad.Fail
                       Data.Singletons.Prelude.Monad.Zip
                       Data.Singletons.Prelude.Monoid
                       Data.Singletons.Prelude.Num

src/Data/Singletons/Partition.hs

@@ -35,6 +35,7 @@ import Language.Haskell.TH.Desugar.OMap.Strict (OMap)
 import Data.Singletons.Util
 
 import Control.Monad
+import qualified Control.Monad.Fail as Fail
 import Data.Bifunctor (bimap)
 import qualified Data.Map as Map
 import Data.Map (Map)
@@ -153,7 +154,7 @@ partitionDec (DStandaloneDerivD mb_strat ctxt ty) =
 partitionDec dec =
   fail $ "Declaration cannot be promoted: " ++ pprint (decToTH dec)
 
-partitionClassDec :: Monad m => DDec -> m (ULetDecEnv, [OpenTypeFamilyDecl])
+partitionClassDec :: Fail.MonadFail m => DDec -> m (ULetDecEnv, [OpenTypeFamilyDecl])
 partitionClassDec (DLetDec (DSigD name ty)) =
   pure (typeBinding name ty, mempty)
 partitionClassDec (DLetDec (DValD (DVarP name) exp)) =
@@ -172,9 +173,9 @@ partitionClassDec (DTySynInstD {}) =
   -- we already record the type family itself separately.
   pure (mempty, mempty)
 partitionClassDec _ =
-  fail "Only method declarations can be promoted within a class."
+  Fail.fail "Only method declarations can be promoted within a class."
 
-partitionInstanceDec :: Monad m => DDec
+partitionInstanceDec :: Fail.MonadFail m => DDec
                      -> m ( Maybe (Name, ULetDecRHS) -- right-hand sides of methods
                           , OMap Name DType          -- method type signatures
                           )
@@ -191,7 +192,7 @@ partitionInstanceDec (DTySynInstD {}) =
   -- There's no need to track associated type family instances, since
   -- we already record the type family itself separately.
 partitionInstanceDec _ =
-  fail "Only method bodies can be promoted within an instance."
+  Fail.fail "Only method bodies can be promoted within an instance."
 
 partitionDeriving
   :: forall m. DsMonad m

src/Data/Singletons/Prelude.hs

@@ -65,12 +65,14 @@ module Data.Singletons.Prelude (
   PSemigroup(type (<>)), SSemigroup((%<>)),
   PMonoid(..), SMonoid(..),
 
-  -- * Singleton 'Functor', 'Applicative', and 'Monad'
+  -- * Singleton 'Functor', 'Applicative', 'Monad', and 'MonadFail'
   PFunctor(Fmap, type (<$)), SFunctor(sFmap, (%<$)), type (<$>), (%<$>),
   PApplicative(Pure, type (<*>), type (*>), type (<*)),
   SApplicative(sPure, (%<*>), (%*>), (%<*)),
-  PMonad(type (>>=), type (>>), Return, Fail),
-  SMonad((%>>=), (%>>), sReturn, sFail),
+  PMonad(type (>>=), type (>>), Return),
+  SMonad((%>>=), (%>>), sReturn),
+  PMonadFail(Fail), SMonadFail(sFail),
+
   MapM_, sMapM_,
   Sequence_, sSequence_,
   type (=<<), (%=<<),
@@ -262,6 +264,7 @@ import Data.Singletons.Prelude.Functor
 import Data.Singletons.Prelude.List
 import Data.Singletons.Prelude.Maybe
 import Data.Singletons.Prelude.Monad
+import Data.Singletons.Prelude.Monad.Fail
 import Data.Singletons.Prelude.Tuple
 import Data.Singletons.Prelude.Eq
 import Data.Singletons.Prelude.Ord

src/Data/Singletons/Prelude/Monad.hs

@@ -52,7 +52,7 @@ module Data.Singletons.Prelude.Monad (
   FmapSym0, FmapSym1, FmapSym2,
   type (>>=@#@$), type (>>=@#@$$), type (>>=@#@$$$),
   type (>>@#@$),  type (>>@#@$$),  type (>>@#@$$$),
-  ReturnSym0, ReturnSym1, FailSym0, FailSym1,
+  ReturnSym0, ReturnSym1,
   MzeroSym0, MplusSym0, MplusSym1, MplusSym2,
 
   MapMSym0,  MapMSym1,  MapMSym2,

src/Data/Singletons/Prelude/Monad/Fail.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Singletons.Prelude.Monad.Fail
+-- Copyright   :  (C) 2019 Ryan Scott
+-- License     :  BSD-style (see LICENSE)
+-- Maintainer  :  Ryan Scott
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Defines the promoted and singled versions of the 'MonadFail' type class.
+--
+----------------------------------------------------------------------------
+
+module Data.Singletons.Prelude.Monad.Fail (
+  PMonadFail(..), SMonadFail(..),
+
+  -- * Defunctionalization symbols
+  FailSym0, FailSym1
+  ) where
+
+import Data.Kind
+import Data.Singletons.Prelude.Instances
+import Data.Singletons.Prelude.Monad.Internal
+import Data.Singletons.Single
+
+$(singletonsOnly [d|
+  -- -| When a value is bound in @do@-notation, the pattern on the left
+  -- hand side of @<-@ might not match. In this case, this class
+  -- provides a function to recover.
+  --
+  -- A 'Monad' without a 'MonadFail' instance may only be used in conjunction
+  -- with pattern that always match, such as newtypes, tuples, data types with
+  -- only a single data constructor, and irrefutable patterns (@~pat@).
+  --
+  -- Instances of 'MonadFail' should satisfy the following law: @fail s@ should
+  -- be a left zero for 'Control.Monad.>>=',
+  --
+  -- @
+  -- fail s >>= f  =  fail s
+  -- @
+  --
+  -- If your 'Monad' is also 'Control.Monad.MonadPlus', a popular definition is
+  --
+  -- @
+  -- fail _ = mzero
+  -- @
+  --
+  -- @since 4.9.0.0
+  class Monad m => MonadFail (m :: Type -> Type) where
+      fail :: String -> m a
+
+  instance MonadFail Maybe where
+      fail _ = Nothing
+
+  instance MonadFail [] where
+      fail _ = []
+  |])

src/Data/Singletons/Prelude/Monad/Internal.hs

@@ -44,7 +44,6 @@ import Data.List.NonEmpty (NonEmpty(..))
 import Data.Singletons.Prelude.Base
 import Data.Singletons.Prelude.Instances
 import Data.Singletons.Single
-import Data.Singletons.TypeLits.Internal
 
 {-
 Note [How to get the right kinds when promoting Functor and friends]
@@ -276,17 +275,6 @@ $(singletonsOnly [d|
       return      :: a -> m a
       return      = pure
 
-      -- -| Fail with a message.  This operation is not part of the
-      -- mathematical definition of a monad, but is invoked on pattern-match
-      -- failure in a @do@ expression.
-      --
-      -- As part of the MonadFail proposal (MFP), this function is moved
-      -- to its own class 'MonadFail' (see "Control.Monad.Fail" for more
-      -- details). The definition here will be removed in a future
-      -- release.
-      fail        :: Symbol -> m a
-      fail s      = error s
-
   {- Note [Recursive bindings for Applicative/Monad]
   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
@@ -490,8 +478,6 @@ $(singletonsOnly [d|
 
       (>>) = (*>)
 
-      fail _              = Nothing
-
   instance Monad NonEmpty where
     (a :| as) >>= f = b :| (bs ++ bs')
       where b :| bs = f a
@@ -500,7 +486,6 @@ $(singletonsOnly [d|
 
   instance Monad []  where
       xs >>= f = foldr ((++) . f) [] xs
-      fail _ = []
 
   instance Monad (Either e) where
       Left  l >>= _ = Left l

src/Data/Singletons/Promote.hs

@@ -35,6 +35,7 @@ import Prelude hiding (exp)
 import Control.Applicative (Alternative(..))
 import Control.Arrow (second)
 import Control.Monad
+import qualified Control.Monad.Fail as Fail
 import Control.Monad.Trans.Maybe
 import Control.Monad.Writer
 import qualified Data.Map.Strict as Map
@@ -829,12 +830,12 @@ promoteLitExp (StringL str) = do
 promoteLitExp lit =
   fail ("Only string and natural number literals can be promoted: " ++ show lit)
 
-promoteLitPat :: Monad m => Lit -> m DType
+promoteLitPat :: Fail.MonadFail m => Lit -> m DType
 promoteLitPat (IntegerL n)
   | n >= 0    = return $ (DLitT (NumTyLit n))
   | otherwise =
-    fail $ "Negative literal patterns are not allowed,\n" ++
-           "because literal patterns are promoted to natural numbers."
+    Fail.fail $ "Negative literal patterns are not allowed,\n" ++
+                "because literal patterns are promoted to natural numbers."
 promoteLitPat (StringL str) = return $ DLitT (StrTyLit str)
 promoteLitPat lit =
   fail ("Only string and natural number literals can be promoted: " ++ show lit)

src/Data/Singletons/Promote/Monad.hs

@@ -28,7 +28,7 @@ import qualified Language.Haskell.TH.Desugar.OSet as OSet
 import Language.Haskell.TH.Desugar.OSet (OSet)
 import Data.Singletons.Names
 import Data.Singletons.Syntax
-import Control.Monad.Fail ( MonadFail )
+import qualified Control.Monad.Fail as Fail
 
 type LetExpansions = OMap Name DType  -- from **term-level** name
 
@@ -50,7 +50,7 @@ emptyPrEnv = PrEnv { pr_lambda_bound = OMap.empty
 newtype PrM a = PrM (ReaderT PrEnv (WriterT [DDec] Q) a)
   deriving ( Functor, Applicative, Monad, Quasi
            , MonadReader PrEnv, MonadWriter [DDec]
-           , MonadFail, MonadIO )
+           , Fail.MonadFail, MonadIO )
 
 instance DsMonad PrM where
   localDeclarations = asks pr_local_decls

src/Data/Singletons/Promote/Type.hs

@@ -13,20 +13,21 @@ module Data.Singletons.Promote.Type
 import Language.Haskell.TH.Desugar
 import Data.Singletons.Names
 import Language.Haskell.TH
+import qualified Control.Monad.Fail as Fail
 
 -- the only monadic thing we do here is fail. This allows the function
 -- to be used from the Singletons module
-promoteType :: Monad m => DType -> m DKind
+promoteType :: Fail.MonadFail m => DType -> m DKind
 promoteType = go []
   where
-    go :: Monad m => [DTypeArg] -> DType -> m DKind
+    go :: Fail.MonadFail m => [DTypeArg] -> DType -> m DKind
     -- We don't need to worry about constraints: they are used to express
     -- static guarantees at runtime. But, because we don't need to do
     -- anything special to keep static guarantees at compile time, we don't
     -- need to promote them.
     go []       (DForallT _tvbs _cxt ty) = go [] ty
     go []       (DAppT (DAppT DArrowT (DForallT (_:_) _ _)) _) =
-      fail "Cannot promote types of rank above 1."
+      Fail.fail "Cannot promote types of rank above 1."
     go args     (DAppT t1 t2) = do
       k2 <- go [] t2
       go (DTANormal k2 : args) t1
@@ -56,15 +57,15 @@ promoteType = go []
       = return $ DConT tyFunArrowName `DAppT` k1 `DAppT` k2
     go _        ty@DLitT{} = pure ty
 
-    go args     hd = fail $ "Illegal Haskell construct encountered:\n" ++
-                            "headed by: " ++ show hd ++ "\n" ++
-                            "applied to: " ++ show args
+    go args     hd = Fail.fail $ "Illegal Haskell construct encountered:\n" ++
+                                 "headed by: " ++ show hd ++ "\n" ++
+                                 "applied to: " ++ show args
 
-promoteTypeArg :: Monad m => DTypeArg -> m DTypeArg
+promoteTypeArg :: Fail.MonadFail m => DTypeArg -> m DTypeArg
 promoteTypeArg (DTANormal t) = DTANormal <$> promoteType t
 promoteTypeArg ta@(DTyArg _) = pure ta -- Kinds are already promoted
 
-promoteUnraveled :: Monad m => DType -> m ([DKind], DKind)
+promoteUnraveled :: Fail.MonadFail m => DType -> m ([DKind], DKind)
 promoteUnraveled ty = do
   arg_kis <- mapM promoteType arg_tys
   res_ki  <- promoteType res_ty

src/Data/Singletons/Single/Monad.hs

@@ -29,7 +29,7 @@ import Language.Haskell.TH.Desugar
 import Control.Monad.Reader
 import Control.Monad.Writer
 import Control.Applicative
-import Control.Monad.Fail
+import qualified Control.Monad.Fail as Fail
 
 -- environment during singling
 data SgEnv =
@@ -48,7 +48,7 @@ emptySgEnv = SgEnv { sg_let_binds   = Map.empty
 newtype SgM a = SgM (ReaderT SgEnv (WriterT [DDec] Q) a)
   deriving ( Functor, Applicative, Monad
            , MonadReader SgEnv, MonadWriter [DDec]
-           , MonadFail, MonadIO )
+           , Fail.MonadFail, MonadIO )
 
 liftSgM :: Q a -> SgM a
 liftSgM = SgM . lift . lift

src/Data/Singletons/Util.hs

@@ -33,7 +33,7 @@ import Data.Traversable
 import Data.Generics
 import Data.Maybe
 import Data.Void
-import Control.Monad.Fail ( MonadFail )
+import qualified Control.Monad.Fail as Fail
 
 -- The list of types that singletons processes by default
 basicTypes :: [Name]
@@ -357,7 +357,7 @@ wrapDesugar f th = do
 newtype QWithAux m q a = QWA { runQWA :: WriterT m q a }
   deriving ( Functor, Applicative, Monad, MonadTrans
            , MonadWriter m, MonadReader r
-           , MonadFail, MonadIO )
+           , Fail.MonadFail, MonadIO )
 
 -- make a Quasi instance for easy lifting
 instance (Quasi q, Monoid m) => Quasi (QWithAux m q) where