Proposal: allow automatic derivation of HFunctor instances.

ChangeLog.md

@@ -6,6 +6,7 @@
 
 ## Other changes
 
+- Adds the ability to derive default instances of `HFunctor` and `Effect` for first-order effects, using the `-XDeriveAnyClass` extension.
 - Adds a generic `Interpose` effect that enables arbitrary "eavesdropping" on other effects.
 
 # 0.3.1.0

docs/defining_effects.md

@@ -25,21 +25,15 @@ The `Read` operation returns a `String`, and hence its continuation is represent
 
 On the other hand, the `Write` operation returns `()`. Since a function `() -> k` is equivalent to a (non-strict) `k`, we can omit the function parameter.
 
-In addition to a `Functor` instance (derived here using `-XDeriveFunctor`), we need two other instances: `HFunctor` and `Effect`. `HFunctor`, named for “higher-order functor,” has one non-default operation, `hmap`, which applies a function to any embedded computations inside an effect. Since `Teletype` is first-order (i.e. it doesn’t have any embedded computations), the definition of `hmap` can be given using `coerce`:
+In addition to a `Functor` instance (derived here using `-XDeriveFunctor`), we need two other instances: `HFunctor` and `Effect`. `HFunctor`, named for “higher-order functor,” has one non-default operation, `hmap`, which applies a function to any embedded computations inside an effect. `Effect` plays a similar role to the combination of `Functor` (which operates on continuations) and `HFunctor` (which operates on embedded computations). It’s used by `Carrier` instances to service any requests for their effect occurring inside other computations—whether embedded or in the continuations. Since these may require some state to be maintained, `handle` takes an initial state parameter (encoded as some arbitrary functor filled with `()`), and its function is phrased as a _distributive law_, mapping state functors containing unhandled computations to handled computations producing the state functor alongside any results.
 
-```haskell
-instance HFunctor Teletype where
-  hmap _ = coerce
-```
-
-`Effect` plays a similar role to the combination of `Functor` (which operates on continuations) and `HFunctor` (which operates on embedded computations). It’s used by `Carrier` instances to service any requests for their effect occurring inside other computations—whether embedded or in the continuations. Since these may require some state to be maintained, `handle` takes an initial state parameter (encoded as some arbitrary functor filled with `()`), and its function is phrased as a _distributive law_, mapping state functors containing unhandled computations to handled computations producing the state functor alongside any results.
-
-Since `Teletype`’s operations don’t have any embedded computations, the `Effect` instance only has to operate on the continuations, by wrapping the computations in the state and applying the handler:
+Since `Teletype` is a first-order effect (i.e., its operations don’t have any embedded computations), we can derive instances both of `HFunctor` and `Effect`:
 
 ```haskell
-instance Effect Teletype where
-  handle state handler (Read    k) = Read (handler . (<$ state) . k)
-  handle state handler (Write s k) = Write s (handler (k <$ state))
+data Teletype (m :: * -> *) k
+  = Read (String -> k)
+  | Write String k
+  deriving (Functor, HFunctor, Effect)
 ```
 
 Now that we have our effect datatype, we can give definitions for `read` and `write`:

examples/Teletype.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE DeriveAnyClass, DeriveFunctor, DerivingStrategies, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
 
 module Teletype where
 
@@ -28,15 +28,7 @@ spec = describe "teletype" $ do
 data Teletype (m :: * -> *) k
   = Read (String -> k)
   | Write String k
-  deriving (Functor)
-
-instance HFunctor Teletype where
-  hmap _ = coerce
-  {-# INLINE hmap #-}
-
-instance Effect Teletype where
-  handle state handler (Read    k) = Read (handler . (<$ state) . k)
-  handle state handler (Write s k) = Write s (handler (k <$ state))
+  deriving (Functor, HFunctor, Effect)
 
 read :: (Member Teletype sig, Carrier sig m) => m String
 read = send (Read pure)
@@ -49,7 +41,7 @@ runTeletypeIO :: TeletypeIOC m a -> m a
 runTeletypeIO = runTeletypeIOC
 
 newtype TeletypeIOC m a = TeletypeIOC { runTeletypeIOC :: m a }
-  deriving (Applicative, Functor, Monad, MonadIO)
+  deriving newtype (Applicative, Functor, Monad, MonadIO)
 
 instance (MonadIO m, Carrier sig m) => Carrier (Teletype :+: sig) (TeletypeIOC m) where
   eff (L (Read    k)) = liftIO getLine      >>= k
@@ -61,7 +53,7 @@ runTeletypeRet :: [String] -> TeletypeRetC m a -> m ([String], ([String], a))
 runTeletypeRet i = runWriter . runState i . runTeletypeRetC
 
 newtype TeletypeRetC m a = TeletypeRetC { runTeletypeRetC :: StateC [String] (WriterC [String] m) a }
-  deriving (Applicative, Functor, Monad)
+  deriving newtype (Applicative, Functor, Monad)
 
 instance (Carrier sig m, Effect sig) => Carrier (Teletype :+: sig) (TeletypeRetC m) where
   eff (L (Read    k)) = do

src/Control/Effect/Carrier.hs

@@ -19,13 +19,30 @@ class HFunctor h where
   {-# INLINE fmap' #-}
 
   -- | Higher-order functor map of a natural transformation over higher-order positions within the effect.
+  -- A definition for 'hmap' over first-order effects can be derived automatically.
   hmap :: (forall x . m x -> n x) -> (h m a -> h n a)
 
+  default hmap :: Coercible (h m a) (h n a)
+               => (forall x . m x -> n x)
+               -> (h m a -> h n a)
+  hmap _ = coerce
+  {-# INLINE hmap #-}
+
 
 -- | The class of effect types, which must:
 --
 --   1. Be functorial in their last two arguments, and
 --   2. Support threading effects in higher-order positions through using the carrier’s suspended state.
+--
+-- All first-order effects (those without recursive occurrences of @m@) admit a default definition
+-- of 'handle'. The @-XDeriveAnyClass@ extension allows derivation of both 'HFunctor' and 'Effect':
+--
+-- @
+--   data State s (m :: * -> *) k
+--     = Get (s -> k)
+--     | Put s k
+--       deriving (Functor, HFunctor, Effect)
+-- @
 class HFunctor sig => Effect sig where
   -- | Handle any effects in a signature by threading the carrier’s state all the way through to the continuation.
   handle :: Functor f
@@ -34,6 +51,15 @@ class HFunctor sig => Effect sig where
          -> sig m (m a)
          -> sig n (n (f a))
 
+  default handle :: (Functor f, Coercible (sig m (n (f a))) (sig n (n (f a))))
+                 => f ()
+                 -> (forall x . f (m x) -> n (f x))
+                 -> sig m (m a)
+                 -> sig n (n (f a))
+  handle state handler = coerce . fmap' (handler . (<$ state))
+  {-# INLINE handle #-}
+
+
 
 -- | The class of carriers (results) for algebras (effect handlers) over signatures (effects), whose actions are given by the 'eff' method.
 class (HFunctor sig, Monad m) => Carrier sig m | m -> sig where

src/Control/Effect/Fail.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveFunctor, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE DeriveAnyClass, DeriveFunctor, DerivingStrategies, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
 module Control.Effect.Fail
 ( Fail(..)
 , MonadFail(..)
@@ -14,20 +14,11 @@ import Control.Monad (MonadPlus(..))
 import Control.Monad.Fail
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
-import Data.Coerce
 import Prelude hiding (fail)
 
 newtype Fail (m :: * -> *) k = Fail String
-  deriving (Functor)
-
-instance HFunctor Fail where
-  hmap _ = coerce
-  {-# INLINE hmap #-}
-
-instance Effect Fail where
-  handle _ _ = coerce
-  {-# INLINE handle #-}
-
+  deriving stock Functor
+  deriving anyclass (HFunctor, Effect)
 
 -- | Run a 'Fail' effect, returning failure messages in 'Left' and successful computations’ results in 'Right'.
 --
@@ -36,7 +27,7 @@ runFail :: FailC m a -> m (Either String a)
 runFail = runError . runFailC
 
 newtype FailC m a = FailC { runFailC :: ErrorC String m a }
-  deriving (Alternative, Applicative, Functor, Monad, MonadIO, MonadPlus, MonadTrans)
+  deriving newtype (Alternative, Applicative, Functor, Monad, MonadIO, MonadPlus, MonadTrans)
 
 instance (Carrier sig m, Effect sig) => MonadFail (FailC m) where
   fail s = FailC (throwError s)

src/Control/Effect/Lift.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses #-}
+{-# LANGUAGE DeriveAnyClass, DeriveFunctor, DerivingStrategies, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses #-}
 module Control.Effect.Lift
 ( Lift(..)
 , sendM
@@ -14,18 +14,10 @@ import Control.Monad.Fail
 import Control.Monad.IO.Class
 import Control.Monad.IO.Unlift
 import Control.Monad.Trans.Class
-import Data.Coerce
 
 newtype Lift sig (m :: * -> *) k = Lift { unLift :: sig k }
-  deriving (Functor)
-
-instance Functor sig => HFunctor (Lift sig) where
-  hmap _ = coerce
-  {-# INLINE hmap #-}
-
-instance Functor sig => Effect (Lift sig) where
-  handle state handler (Lift op) = Lift (fmap (handler . (<$ state)) op)
-
+  deriving stock Functor
+  deriving anyclass (HFunctor, Effect)
 
 -- | Extract a 'Lift'ed 'Monad'ic action from an effectful computation.
 runM :: LiftC m a -> m a
@@ -38,7 +30,7 @@ sendM :: (Member (Lift n) sig, Carrier sig m, Functor n) => n a -> m a
 sendM = send . Lift . fmap pure
 
 newtype LiftC m a = LiftC { runLiftC :: m a }
-  deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus)
+  deriving newtype (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus)
 
 instance MonadTrans LiftC where
   lift = LiftC

src/Control/Effect/NonDet.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveFunctor, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, RankNTypes, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE DeriveAnyClass, DeriveFunctor, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, RankNTypes, TypeOperators, UndecidableInstances #-}
 module Control.Effect.NonDet
 ( NonDet(..)
 , Alternative(..)
@@ -13,21 +13,12 @@ import Control.Monad (MonadPlus(..))
 import Control.Monad.Fail
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
-import Data.Coerce
 import Prelude hiding (fail)
 
 data NonDet (m :: * -> *) k
   = Empty
   | Choose (Bool -> k)
-  deriving (Functor)
-
-instance HFunctor NonDet where
-  hmap _ = coerce
-  {-# INLINE hmap #-}
-
-instance Effect NonDet where
-  handle _     _       Empty      = Empty
-  handle state handler (Choose k) = Choose (handler . (<$ state) . k)
+  deriving (Functor, HFunctor, Effect)
 
 
 -- | Run a 'NonDet' effect, collecting all branches’ results into an 'Alternative' functor.

src/Control/Effect/Resumable.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE DeriveAnyClass, DeriveFunctor, DerivingStrategies, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
 module Control.Effect.Resumable
 ( Resumable(..)
 , throwResumable
@@ -19,21 +19,15 @@ import Control.Monad (MonadPlus(..))
 import Control.Monad.Fail
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
-import Data.Coerce
 import Data.Functor.Classes
 
 -- | Errors which can be resumed with values of some existentially-quantified type.
 data Resumable err (m :: * -> *) k
   = forall a . Resumable (err a) (a -> k)
 
 deriving instance Functor (Resumable err m)
-
-instance HFunctor (Resumable err) where
-  hmap _ = coerce
-  {-# INLINE hmap #-}
-
-instance Effect (Resumable err) where
-  handle state handler (Resumable err k) = Resumable err (handler . (<$ state) . k)
+deriving instance HFunctor (Resumable err)
+deriving instance Effect (Resumable err)
 
 -- | Throw an error which can be resumed with a value of its result type.
 --
@@ -88,7 +82,7 @@ runResumable :: ResumableC err m a -> m (Either (SomeError err) a)
 runResumable = runError . runResumableC
 
 newtype ResumableC err m a = ResumableC { runResumableC :: ErrorC (SomeError err) m a }
-  deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus, MonadTrans)
+  deriving newtype (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus, MonadTrans)
 
 instance (Carrier sig m, Effect sig) => Carrier (Resumable err :+: sig) (ResumableC err m) where
   eff (L (Resumable err _)) = ResumableC (throwError (SomeError err))
@@ -110,7 +104,7 @@ runResumableWith :: (forall x . err x -> m x)
 runResumableWith with = runReader (Handler with) . runResumableWithC
 
 newtype ResumableWithC err m a = ResumableWithC { runResumableWithC :: ReaderC (Handler err m) m a }
-  deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus)
+  deriving newtype (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus)
 
 instance MonadTrans (ResumableWithC err) where
   lift = ResumableWithC . lift

src/Control/Effect/State/Internal.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveFunctor, ExplicitForAll, FlexibleContexts, FlexibleInstances, KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE DeriveAnyClass, DeriveFunctor, ExplicitForAll, FlexibleContexts, FlexibleInstances, KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
 module Control.Effect.State.Internal
 ( State(..)
 , get
@@ -10,21 +10,12 @@ module Control.Effect.State.Internal
 
 import Control.Effect.Carrier
 import Control.Effect.Sum
-import Data.Coerce
 import Prelude hiding (fail)
 
 data State s (m :: * -> *) k
   = Get (s -> k)
   | Put s k
-  deriving (Functor)
-
-instance HFunctor (State s) where
-  hmap _ = coerce
-  {-# INLINE hmap #-}
-
-instance Effect (State s) where
-  handle state handler (Get k)   = Get   (handler . (<$ state) . k)
-  handle state handler (Put s k) = Put s (handler . (<$ state) $ k)
+  deriving (Functor, HFunctor, Effect)
 
 -- | Get the current state value.
 --

src/Control/Effect/Trace.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE DeriveAnyClass, DeriveFunctor, DerivingStrategies, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
 module Control.Effect.Trace
 ( Trace(..)
 , trace
@@ -19,21 +19,13 @@ import Control.Monad.Fail
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
 import Data.Bifunctor (first)
-import Data.Coerce
 import System.IO
 
 data Trace (m :: * -> *) k = Trace
   { traceMessage :: String
   , traceCont    :: k
-  }
-  deriving (Functor)
-
-instance HFunctor Trace where
-  hmap _ = coerce
-  {-# INLINE hmap #-}
-
-instance Effect Trace where
-  handle state handler (Trace s k) = Trace s (handler (k <$ state))
+  } deriving stock Functor
+    deriving anyclass (HFunctor, Effect)
 
 -- | Append a message to the trace log.
 trace :: (Member Trace sig, Carrier sig m) => String -> m ()
@@ -45,7 +37,7 @@ runTraceByPrinting :: TraceByPrintingC m a -> m a
 runTraceByPrinting = runTraceByPrintingC
 
 newtype TraceByPrintingC m a = TraceByPrintingC { runTraceByPrintingC :: m a }
-  deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus)
+  deriving newtype (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus)
 
 instance MonadTrans TraceByPrintingC where
   lift = TraceByPrintingC
@@ -64,7 +56,7 @@ runTraceByIgnoring :: TraceByIgnoringC m a -> m a
 runTraceByIgnoring = runTraceByIgnoringC
 
 newtype TraceByIgnoringC m a = TraceByIgnoringC { runTraceByIgnoringC :: m a }
-  deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus)
+  deriving newtype (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus)
 
 instance MonadTrans TraceByIgnoringC where
   lift = TraceByIgnoringC
@@ -83,7 +75,7 @@ runTraceByReturning :: Functor m => TraceByReturningC m a -> m ([String], a)
 runTraceByReturning = fmap (first reverse) . runState [] . runTraceByReturningC
 
 newtype TraceByReturningC m a = TraceByReturningC { runTraceByReturningC :: StateC [String] m a }
-  deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus, MonadTrans)
+  deriving newtype (Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus, MonadTrans)
 
 instance (Carrier sig m, Effect sig) => Carrier (Trace :+: sig) (TraceByReturningC m) where
   eff (L (Trace m k)) = TraceByReturningC (modify (m :)) *> k