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.

Sign up for GitHub

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

Jump to bottom

Proposal: Remove HFunctor's fmap' with GHCs supporting QuantifiedConstraints. #153

Closed
wants to merge 1 commit into from
Closed

Proposal: Remove HFunctor's fmap' with GHCs supporting QuantifiedConstraints. #153

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Jump to
Jump to file
Failed to load files.
Diff view
Diff view
23 changes: 21 additions & 2 deletions src/Control/Effect/Carrier.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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(..)
Expand All @@ -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'.
--
Expand All @@ -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:
--
Expand Down Expand Up @@ -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'.
Expand Down
4 changes: 3 additions & 1 deletion src/Control/Effect/Sum.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
{-# LANGUAGE DeriveFunctor, FlexibleInstances, KindSignatures, MultiParamTypeClasses, TypeOperators #-}
{-# LANGUAGE CPP, DeriveFunctor, FlexibleInstances, KindSignatures, MultiParamTypeClasses, TypeOperators #-}
module Control.Effect.Sum
( (:+:)(..)
, handleSum
Expand All @@ -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)
Expand Down