From 407bb56ef45877cd2f3113bbedf9b3ef4d77e3f4 Mon Sep 17 00:00:00 2001
From: Patrick Thomson <patrickt@github.com>
Date: Fri, 12 Apr 2019 13:15:52 -0400
Subject: [PATCH] Remove HFunctor's fmap' with GHCs supporting
 QuantifiedConstraints.

As was mentioned in the `HFunctor` documentation, we can eliminate the
vestigial `fmap'` method with QuantifiedConstraints. This implementation
is provided by Bottu et al.'s _Quantified Class Constraints_.

The advantage of this patch is that it expresses the nature of
`HFunctor` in a more direct manner, rather than with the
dummy-function workaround. The disadvantage is that only GHC 8.6
supports QuantifiedConstraints, so we have to use CPP to define the
polyfill (as it were) to handle it.

This changes the `HFunctor` interface but should maintain
compatibility, as `fmap'` was never implemented by hand outside of `Sum`.
---
 src/Control/Effect/Carrier.hs | 23 +++++++++++++++++++++--
 src/Control/Effect/Sum.hs     |  4 +++-
 2 files changed, 24 insertions(+), 3 deletions(-)

diff --git a/src/Control/Effect/Carrier.hs b/src/Control/Effect/Carrier.hs
index d65e0dc2a..b6e06a529 100644
--- a/src/Control/Effect/Carrier.hs
+++ b/src/Control/Effect/Carrier.hs
@@ -1,4 +1,7 @@
-{-# LANGUAGE DefaultSignatures, DeriveFunctor, FlexibleInstances, FunctionalDependencies, RankNTypes, UndecidableInstances #-}
+{-# LANGUAGE CPP, DefaultSignatures, DeriveFunctor, FlexibleInstances, FunctionalDependencies, RankNTypes, UndecidableInstances #-}
+#if __GLASGOW_HASKELL__ >= 861
+{-# LANGUAGE QuantifiedConstraints #-}
+#endif
 module Control.Effect.Carrier
 ( HFunctor(..)
 , Effect(..)
@@ -15,6 +18,18 @@ module Control.Effect.Carrier
 import Control.Monad (join)
 import Data.Coerce
 
+-- | A higher-order functor, as defined by Johann and Ghani in
+-- /Foundations for Structured Programming with GADTs/. In versions of
+-- GHC without support for the @QuantifiedConstraints@ extension, this
+-- is expressed with an additional @fmap'@ function. In neither case
+-- do you need to supply a definition for @fmap'@, as it is handled
+-- with a @default@ case.
+#if __GLASGOW_HASKELL__ >= 861
+class (forall f . Functor f => Functor (h f)) => HFunctor h where
+  -- | Higher-order functor map of a natural transformation over higher-order positions within the effect.
+
+  hmap :: (Functor f , Functor g) => (forall x . f x -> g x) -> (forall x . h f x -> h g x)
+#else
 class HFunctor h where
   -- | Functor map. This is required to be 'fmap'.
   --
@@ -26,7 +41,7 @@ class HFunctor h where
 
   -- | Higher-order functor map of a natural transformation over higher-order positions within the effect.
   hmap :: (forall x . m x -> n x) -> (h m a -> h n a)
-
+#endif
 
 -- | The class of effect types, which must:
 --
@@ -54,7 +69,11 @@ class (HFunctor sig, Monad m) => Carrier sig m | m -> sig where
 
 -- | Apply a handler specified as a natural transformation to both higher-order and continuation positions within an 'HFunctor'.
 handlePure :: HFunctor sig => (forall x . f x -> g x) -> sig f (f a) -> sig g (g a)
+#if __GLASGOW_HASKELL__ >= 861
+handlePure handler = hmap handler . fmap handler
+#else
 handlePure handler = hmap handler . fmap' handler
+#endif
 {-# INLINE handlePure #-}
 
 -- | Thread a 'Coercible' carrier through an 'HFunctor'.
diff --git a/src/Control/Effect/Sum.hs b/src/Control/Effect/Sum.hs
index 59a4739a4..ccd2db3a9 100644
--- a/src/Control/Effect/Sum.hs
+++ b/src/Control/Effect/Sum.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveFunctor, FlexibleInstances, KindSignatures, MultiParamTypeClasses, TypeOperators #-}
+{-# LANGUAGE CPP, DeriveFunctor, FlexibleInstances, KindSignatures, MultiParamTypeClasses, TypeOperators #-}
 module Control.Effect.Sum
 ( (:+:)(..)
 , handleSum
@@ -19,8 +19,10 @@ instance (HFunctor l, HFunctor r) => HFunctor (l :+: r) where
   hmap f (L l) = L (hmap f l)
   hmap f (R r) = R (hmap f r)
 
+#if __GLASGOW_HASKELL__ <= 861
   fmap' f (L l) = L (fmap' f l)
   fmap' f (R r) = R (fmap' f r)
+#endif
 
 instance (Effect l, Effect r) => Effect (l :+: r) where
   handle state handler (L l) = L (handle state handler l)