git.iko.soy/typeable/ether
on master help sign in
MFunctor and MMonad using 'coerce'
357bde6Vladislav Zavialov
src/Ether/TaggedTrans.hs+26−16
compare with master
unifiedsplit
@@ -1,4 +1,7 @@
1+-- The use of ImpredicativeTypes here is safe, see discussion under GitHub issue
2+-- #35. It's only needed to allow the visible type application of a polytype.
1−{-# LANGUAGE CPP #-}
3+{-# LANGUAGE ImpredicativeTypes #-}
4+
2module Ether.TaggedTrans
5module Ether.TaggedTrans
3 ( TaggedTrans(..)
6 ( TaggedTrans(..)
4 ) where
7 ) where
@@ -30,17 +33,11 @@ import qualified Control.Monad.Error.Class as Mtl
30import GHC.Generics (Generic)
33import GHC.Generics (Generic)
31import Data.Coerce (coerce)
34import Data.Coerce (coerce)
32
35
33−#define TRAC_11837_PRESENT \
34− __GLASGOW_HASKELL__ == 800 && __GLASGOW_HASKELL_PATCHLEVEL1__ == 1
35−
36newtype TaggedTrans tag trans m a = TaggedTrans (trans m a)
36newtype TaggedTrans tag trans m a = TaggedTrans (trans m a)
37 deriving
37 deriving
38 ( Generic
38 ( Generic
39 , Functor, Applicative, Alternative, Monad, MonadPlus
39 , Functor, Applicative, Alternative, Monad, MonadPlus
40 , MonadFix, MonadTrans, MonadIO
40 , MonadFix, MonadTrans, MonadIO
41−#if !(TRAC_11837_PRESENT)
42− , MFunctor, MMonad
43−#endif
44 , MonadThrow, MonadCatch, MonadMask )
41 , MonadThrow, MonadCatch, MonadMask )
45
42
46type Pack tag trans m a = trans m a -> TaggedTrans tag trans m a
43type Pack tag trans m a = trans m a -> TaggedTrans tag trans m a
@@ -182,15 +179,28 @@ instance
182 throwError = lift . Mtl.throwError
179 throwError = lift . Mtl.throwError
183 catchError = Lift.liftCatch Mtl.catchError
180 catchError = Lift.liftCatch Mtl.catchError
184
181
185−#if TRAC_11837_PRESENT
182+type Hoist trans =
186−-- NB: Don't use GeneralizedNewtypeDeriving to create these instances on
183+ forall m n b . Monad m =>
187−-- GHC 8.0.1, as they will trigger GHC Trac #11837
184+ (forall a . m a -> n a) -> trans m b -> trans n b
188
185
186+-- NB: Don't use GeneralizedNewtypeDeriving to create this instance, as it will
187+-- trigger GHC Trac #11837 on GHC 8.0.1 and older.
189instance MFunctor trans => MFunctor (TaggedTrans tag trans) where
188instance MFunctor trans => MFunctor (TaggedTrans tag trans) where
190− hoist f (TaggedTrans t) = TaggedTrans (hoist f t)
189+ hoist =
191−
190+ coerce
191+ @(Hoist trans)
192+ @(Hoist (TaggedTrans tag trans))
193+ hoist
194+
195+type Embed trans =
196+ forall n m b . Monad n =>
197+ (forall a . m a -> trans n a) -> trans m b -> trans n b
198+
199+-- NB: Don't use GeneralizedNewtypeDeriving to create this instance, as it will
200+-- trigger GHC Trac #11837 on GHC 8.0.1 and older.
192instance MMonad trans => MMonad (TaggedTrans tag trans) where
201instance MMonad trans => MMonad (TaggedTrans tag trans) where
193− embed f (TaggedTrans t) = TaggedTrans (embed (runTaggedTrans . f) t)
202+ embed =
194− where
203+ coerce
195− runTaggedTrans (TaggedTrans x) = x
204+ @(Embed trans)
196−#endif
205+ @(Embed (TaggedTrans tag trans))
206+ embed
stack.yaml+4−1
@@ -1,2 +1,5 @@
1−resolver: nightly-2017-05-17
1+resolver: lts-7.23
2packages: ['.']
2packages: ['.']
3+extra-deps:
4+- transformers-lift-0.2.0.1
5+- mmorph-1.1.0