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

Loosen constraints on Functor, Applicative, Apply, Traversable #186

Closed
wants to merge 9 commits into from
Closed

Loosen constraints on Functor, Applicative, Apply, Traversable #186

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
9 commits
Select commit Hold shift + click to select a range
81dd344
Loosen constraints on Functor, Applicative, Apply, Traversable
hololeap Jan 18, 2019
a52ba21
Fixup Control.Monad.Trans.Free.Ap
hololeap Jan 18, 2019
1d8bb83
Fixup Control.Monad.Trans.Free.Church
hololeap Jan 18, 2019
1b8c193
Fixup Control.Monad.Trans.Free
hololeap Jan 18, 2019
48356b1
Compatibility fixup for Control.Monad.Trans.Free
hololeap Jan 18, 2019
3ff2073
Compatibility fixup for Control.Monad.Trans.Free.Ap
hololeap Jan 19, 2019
667c9b2
Compatibility fixup for Control.Monad.Trans.Free.Church
hololeap Jan 19, 2019
39f210c
Compatibility fixup for Control.Monad.Trans.Iter
hololeap Jan 19, 2019
8dd7912
Remove unneeded Functor constraint
hololeap Jan 19, 2019
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
64 changes: 34 additions & 30 deletions src/Control/Monad/Trans/Free.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -53,7 +53,7 @@ module Control.Monad.Trans.Free
) where

import Control.Applicative
import Control.Monad (liftM, MonadPlus(..), ap, join)
import Control.Monad (liftM, MonadPlus(..), join)
import Control.Monad.Base (MonadBase(..))
import Control.Monad.Catch (MonadThrow(..), MonadCatch(..))
import Control.Monad.Trans.Class
Expand Down Expand Up @@ -284,24 +284,28 @@ instance (Functor f, Read1 f, Functor m, Read1 m, Read a) => Read (FreeT f m a)
#endif
readsPrec = readsPrec1

instance (Functor f, Monad m) => Functor (FreeT f m) where
fmap f (FreeT m) = FreeT (liftM f' m) where
instance (Functor f, Functor m) => Functor (FreeT f m) where
fmap f (FreeT m) = FreeT (fmap f' m) where
f' (Pure a) = Pure (f a)
f' (Free as) = Free (fmap (fmap f) as)

instance (Functor f, Monad m) => Applicative (FreeT f m) where
pure a = FreeT (return (Pure a))
instance (Functor f, Functor m, Applicative m) => Applicative (FreeT f m) where
pure a = FreeT (pure (Pure a))
{-# INLINE pure #-}
(<*>) = ap
FreeT mf <*> FreeT mx = FreeT $ liftA2 q mf mx
where
Pure a `q` Pure b = Pure $ a b
Pure a `q` Free b = Free $ fmap a <$> b
Free a `q` b = Free $ (<*> FreeT (pure b)) <$> a
{-# INLINE (<*>) #-}

instance (Functor f, Monad m) => Apply (FreeT f m) where
instance (Functor f, Functor m, Applicative m) => Apply (FreeT f m) where
(<.>) = (<*>)

instance (Functor f, Monad m) => Bind (FreeT f m) where
instance (Functor f, Functor m, Applicative m, Monad m) => Bind (FreeT f m) where
(>>-) = (>>=)

instance (Functor f, Monad m) => Monad (FreeT f m) where
instance (Functor f, Functor m, Applicative m, Monad m) => Monad (FreeT f m) where
return = pure
{-# INLINE return #-}
FreeT m >>= f = FreeT $ m >>= \v -> case v of
Expand All @@ -310,28 +314,28 @@ instance (Functor f, Monad m) => Monad (FreeT f m) where

fail = Fail.fail

instance (Functor f, Monad m) => Fail.MonadFail (FreeT f m) where
instance (Functor f, Applicative m, Monad m) => Fail.MonadFail (FreeT f m) where
fail e = FreeT (fail e)

instance MonadTrans (FreeT f) where
lift = FreeT . liftM Pure
{-# INLINE lift #-}

instance (Functor f, MonadIO m) => MonadIO (FreeT f m) where
instance (Functor f, Applicative m, MonadIO m) => MonadIO (FreeT f m) where
liftIO = lift . liftIO
{-# INLINE liftIO #-}

instance (Functor f, MonadBase b m) => MonadBase b (FreeT f m) where
liftBase = lift . liftBase
{-# INLINE liftBase #-}

instance (Functor f, MonadReader r m) => MonadReader r (FreeT f m) where
instance (Functor f, Functor m, Applicative m, MonadReader r m) => MonadReader r (FreeT f m) where
ask = lift ask
{-# INLINE ask #-}
local f = hoistFreeT (local f)
{-# INLINE local #-}

instance (Functor f, MonadWriter w m) => MonadWriter w (FreeT f m) where
instance (Functor f, Functor m, Applicative m, MonadWriter w m) => MonadWriter w (FreeT f m) where
tell = lift . tell
{-# INLINE tell #-}
listen (FreeT m) = FreeT $ liftM concat' $ listen (fmap listen `liftM` m)
Expand All @@ -349,7 +353,7 @@ instance (Functor f, MonadWriter w m) => MonadWriter w (FreeT f m) where
{-# INLINE writer #-}
#endif

instance (Functor f, MonadState s m) => MonadState s (FreeT f m) where
instance (Functor f, Applicative m, MonadState s m) => MonadState s (FreeT f m) where
get = lift get
{-# INLINE get #-}
put = lift . put
Expand All @@ -359,34 +363,34 @@ instance (Functor f, MonadState s m) => MonadState s (FreeT f m) where
{-# INLINE state #-}
#endif

instance (Functor f, MonadError e m) => MonadError e (FreeT f m) where
instance (Functor f, Applicative m, MonadError e m) => MonadError e (FreeT f m) where
throwError = lift . throwError
{-# INLINE throwError #-}
FreeT m `catchError` f = FreeT $ liftM (fmap (`catchError` f)) m `catchError` (runFreeT . f)

instance (Functor f, MonadCont m) => MonadCont (FreeT f m) where
instance (Functor f, Applicative m, MonadCont m) => MonadCont (FreeT f m) where
callCC f = FreeT $ callCC (\k -> runFreeT $ f (lift . k . Pure))

instance (Functor f, MonadPlus m) => Alternative (FreeT f m) where
instance (Functor f, Applicative m, MonadPlus m) => Alternative (FreeT f m) where
empty = FreeT mzero
FreeT ma <|> FreeT mb = FreeT (mplus ma mb)
{-# INLINE (<|>) #-}

instance (Functor f, MonadPlus m) => MonadPlus (FreeT f m) where
instance (Functor f, Applicative m, MonadPlus m) => MonadPlus (FreeT f m) where
mzero = FreeT mzero
{-# INLINE mzero #-}
mplus (FreeT ma) (FreeT mb) = FreeT (mplus ma mb)
{-# INLINE mplus #-}

instance (Functor f, Monad m) => MonadFree f (FreeT f m) where
instance (Functor f, Applicative m, Monad m) => MonadFree f (FreeT f m) where
wrap = FreeT . return . Free
{-# INLINE wrap #-}

instance (Functor f, MonadThrow m) => MonadThrow (FreeT f m) where
instance (Functor f, Applicative m, MonadThrow m) => MonadThrow (FreeT f m) where
throwM = lift . throwM
{-# INLINE throwM #-}

instance (Functor f, MonadCatch m) => MonadCatch (FreeT f m) where
instance (Functor f, Applicative m, MonadCatch m) => MonadCatch (FreeT f m) where
FreeT m `catch` f = FreeT $ liftM (fmap (`Control.Monad.Catch.catch` f)) m
`Control.Monad.Catch.catch` (runFreeT . f)
{-# INLINE catch #-}
Expand All @@ -410,14 +414,14 @@ iterTM f (FreeT m) = do
instance (Foldable m, Foldable f) => Foldable (FreeT f m) where
foldMap f (FreeT m) = foldMap (bifoldMap f (foldMap f)) m

instance (Monad m, Traversable m, Traversable f) => Traversable (FreeT f m) where
instance (Applicative m, Traversable m, Traversable f) => Traversable (FreeT f m) where
traverse f (FreeT m) = FreeT <$> traverse (bitraverse f (traverse f)) m

-- | Lift a monad homomorphism from @m@ to @n@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' f n@
--
-- @'hoistFreeT' :: ('Monad' m, 'Functor' f) => (m ~> n) -> 'FreeT' f m ~> 'FreeT' f n@
hoistFreeT :: (Monad m, Functor f) => (forall a. m a -> n a) -> FreeT f m b -> FreeT f n b
hoistFreeT mh = FreeT . mh . liftM (fmap (hoistFreeT mh)) . runFreeT
hoistFreeT :: (Functor m, Functor f) => (forall a. m a -> n a) -> FreeT f m b -> FreeT f n b
hoistFreeT mh = FreeT . mh . fmap (fmap (hoistFreeT mh)) . runFreeT

-- | The very definition of a free monad transformer is that given a natural
-- transformation you get a monad transformer homomorphism.
Expand All @@ -429,8 +433,8 @@ foldFreeT f (FreeT m) = lift m >>= foldFreeF
foldFreeF (Free as) = f as >>= foldFreeT f

-- | Lift a natural transformation from @f@ to @g@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' g m@
transFreeT :: (Monad m, Functor g) => (forall a. f a -> g a) -> FreeT f m b -> FreeT g m b
transFreeT nt = FreeT . liftM (fmap (transFreeT nt) . transFreeF nt) . runFreeT
transFreeT :: (Functor m, Functor g) => (forall a. f a -> g a) -> FreeT f m b -> FreeT g m b
transFreeT nt = FreeT . fmap (fmap (transFreeT nt) . transFreeF nt) . runFreeT

-- | Pull out and join @m@ layers of @'FreeT' f m a@.
joinFreeT :: (Monad m, Traversable f) => FreeT f m a -> m (Free f a)
Expand Down Expand Up @@ -474,9 +478,9 @@ iterM phi = iterT phi . hoistFreeT (return . runIdentity)
--
-- Calling @'retract' '.' 'cutoff' n@ is always terminating, provided each of the
-- steps in the iteration is terminating.
cutoff :: (Functor f, Monad m) => Integer -> FreeT f m a -> FreeT f m (Maybe a)
cutoff n _ | n <= 0 = return Nothing
cutoff n (FreeT m) = FreeT $ bimap Just (cutoff (n - 1)) `liftM` m
cutoff :: (Functor f, Applicative m) => Integer -> FreeT f m a -> FreeT f m (Maybe a)
cutoff n _ | n <= 0 = pure Nothing
cutoff n (FreeT m) = FreeT $ bimap Just (cutoff (n - 1)) <$> m

-- | @partialIterT n phi m@ interprets first @n@ layers of @m@ using @phi@.
-- This is sort of the opposite for @'cutoff'@.
Expand Down Expand Up @@ -506,7 +510,7 @@ partialIterT n phi m
-- 'intersperseT' f '.' 'lift' ≡ 'lift'
-- 'intersperseT' f '.' 'wrap' ≡ 'wrap' '.' 'fmap' ('iterTM' ('wrap' '.' ('<$' f) '.' 'wrap'))
-- @
intersperseT :: (Monad m, Functor f) => f a -> FreeT f m b -> FreeT f m b
intersperseT :: (Applicative m, Monad m, Functor f) => f a -> FreeT f m b -> FreeT f m b
intersperseT f (FreeT m) = FreeT $ do
val <- m
case val of
Expand Down
42 changes: 21 additions & 21 deletions src/Control/Monad/Trans/Free/Ap.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -44,7 +44,7 @@ module Control.Monad.Trans.Free.Ap
) where

import Control.Applicative
import Control.Monad (liftM, MonadPlus(..), join)
import Control.Monad (MonadPlus(..), join, liftM)
import Control.Monad.Catch (MonadThrow(..), MonadCatch(..))
import Control.Monad.Trans.Class
import qualified Control.Monad.Fail as Fail
Expand Down Expand Up @@ -274,13 +274,13 @@ instance (Functor f, Read1 f, Functor m, Read1 m, Read a) => Read (FreeT f m a)
#endif
readsPrec = readsPrec1

instance (Functor f, Monad m) => Functor (FreeT f m) where
fmap f (FreeT m) = FreeT (liftM f' m) where
instance (Functor f, Functor m) => Functor (FreeT f m) where
fmap f (FreeT m) = FreeT (fmap f' m) where
f' (Pure a) = Pure (f a)
f' (Free as) = Free (fmap (fmap f) as)

instance (Applicative f, Applicative m, Monad m) => Applicative (FreeT f m) where
pure a = FreeT (return (Pure a))
instance (Applicative f, Applicative m) => Applicative (FreeT f m) where
pure a = FreeT (pure (Pure a))
{-# INLINE pure #-}
FreeT f <*> FreeT a = FreeT $ g <$> f <*> a where
g (Pure f') (Pure a') = Pure (f' a')
Expand All @@ -289,14 +289,14 @@ instance (Applicative f, Applicative m, Monad m) => Applicative (FreeT f m) wher
g (Free fs) (Free as) = Free $ (<*>) <$> fs <*> as
{-# INLINE (<*>) #-}

instance (Apply f, Apply m, Monad m) => Apply (FreeT f m) where
instance (Apply f, Apply m, Applicative m) => Apply (FreeT f m) where
FreeT f <.> FreeT a = FreeT $ g <$> f <.> a where
g (Pure f') (Pure a') = Pure (f' a')
g (Pure f') (Free as) = Free $ fmap f' <$> as
g (Free fs) (Pure a') = Free $ fmap ($ a') <$> fs
g (Free fs) (Free as) = Free $ (<.>) <$> fs <.> as

instance (Apply f, Apply m, Monad m) => Bind (FreeT f m) where
instance (Apply f, Apply m, Applicative m, Monad m) => Bind (FreeT f m) where
FreeT m >>- f = FreeT $ m >>= \v -> case v of
Pure a -> runFreeT (f a)
Free w -> return (Free (fmap (>>- f) w))
Expand Down Expand Up @@ -329,14 +329,14 @@ instance (Applicative f, Applicative m, MonadReader r m) => MonadReader r (FreeT
instance (Applicative f, Applicative m, MonadWriter w m) => MonadWriter w (FreeT f m) where
tell = lift . tell
{-# INLINE tell #-}
listen (FreeT m) = FreeT $ liftM concat' $ listen (fmap listen `liftM` m)
listen (FreeT m) = FreeT $ fmap concat' $ listen (fmap listen <$> m)
where
concat' (Pure x, w) = Pure (x, w)
concat' (Free y, w) = Free $ fmap (second (w `mappend`)) <$> y
pass m = FreeT . pass' . runFreeT . hoistFreeT clean $ listen m
where
clean = pass . liftM (\x -> (x, const mempty))
pass' = join . liftM g
clean = pass . fmap (\x -> (x, const mempty))
pass' = join . fmap g
g (Pure ((x, f), w)) = tell (f w) >> return (Pure x)
g (Free f) = return . Free . fmap (FreeT . pass' . runFreeT) $ f
#if MIN_VERSION_mtl(2,1,1)
Expand All @@ -357,7 +357,7 @@ instance (Applicative f, Applicative m, MonadState s m) => MonadState s (FreeT f
instance (Applicative f, Applicative m, MonadError e m) => MonadError e (FreeT f m) where
throwError = lift . throwError
{-# INLINE throwError #-}
FreeT m `catchError` f = FreeT $ liftM (fmap (`catchError` f)) m `catchError` (runFreeT . f)
FreeT m `catchError` f = FreeT $ fmap (fmap (`catchError` f)) m `catchError` (runFreeT . f)

instance (Applicative f, Applicative m, MonadCont m) => MonadCont (FreeT f m) where
callCC f = FreeT $ callCC (\k -> runFreeT $ f (lift . k . Pure))
Expand All @@ -382,7 +382,7 @@ instance (Applicative f, Applicative m, MonadThrow m) => MonadThrow (FreeT f m)
{-# INLINE throwM #-}

instance (Applicative f, Applicative m, MonadCatch m) => MonadCatch (FreeT f m) where
FreeT m `catch` f = FreeT $ liftM (fmap (`Control.Monad.Catch.catch` f)) m
FreeT m `catch` f = FreeT $ fmap (fmap (`Control.Monad.Catch.catch` f)) m
`Control.Monad.Catch.catch` (runFreeT . f)
{-# INLINE catch #-}

Expand Down Expand Up @@ -413,19 +413,19 @@ instance (Monad m, Traversable m, Traversable f) => Traversable (FreeT f m) wher
-- | Lift a monad homomorphism from @m@ to @n@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' f n@
--
-- @'hoistFreeT' :: ('Monad' m, 'Functor' f) => (m ~> n) -> 'FreeT' f m ~> 'FreeT' f n@
hoistFreeT :: (Monad m, Applicative f) => (forall a. m a -> n a) -> FreeT f m b -> FreeT f n b
hoistFreeT mh = FreeT . mh . liftM (fmap (hoistFreeT mh)) . runFreeT
hoistFreeT :: (Functor m, Applicative f) => (forall a. m a -> n a) -> FreeT f m b -> FreeT f n b
hoistFreeT mh = FreeT . mh . fmap (fmap (hoistFreeT mh)) . runFreeT

-- | Lift an applicative homomorphism from @f@ to @g@ into a monad homomorphism from @'FreeT' f m@ to @'FreeT' g m@
transFreeT :: (Monad m, Applicative g) => (forall a. f a -> g a) -> FreeT f m b -> FreeT g m b
transFreeT nt = FreeT . liftM (fmap (transFreeT nt) . transFreeF nt) . runFreeT
transFreeT :: (Functor m, Applicative g) => (forall a. f a -> g a) -> FreeT f m b -> FreeT g m b
transFreeT nt = FreeT . fmap (fmap (transFreeT nt) . transFreeF nt) . runFreeT

-- | Pull out and join @m@ layers of @'FreeT' f m a@.
joinFreeT :: (Monad m, Traversable f, Applicative f) => FreeT f m a -> m (Free f a)
joinFreeT :: (Functor m, Monad m, Traversable f, Applicative f) => FreeT f m a -> m (Free f a)
joinFreeT (FreeT m) = m >>= joinFreeF
where
joinFreeF (Pure x) = return (return x)
joinFreeF (Free f) = wrap `liftM` Data.Traversable.mapM joinFreeT f
joinFreeF (Free f) = wrap <$> Data.Traversable.mapM joinFreeT f

-- |
-- 'retract' is the left inverse of 'liftF'
Expand Down Expand Up @@ -462,9 +462,9 @@ iterM phi = iterT phi . hoistFreeT (return . runIdentity)
--
-- Calling @'retract' '.' 'cutoff' n@ is always terminating, provided each of the
-- steps in the iteration is terminating.
cutoff :: (Applicative f, Applicative m, Monad m) => Integer -> FreeT f m a -> FreeT f m (Maybe a)
cutoff n _ | n <= 0 = return Nothing
cutoff n (FreeT m) = FreeT $ bimap Just (cutoff (n - 1)) `liftM` m
cutoff :: (Applicative f, Applicative m) => Integer -> FreeT f m a -> FreeT f m (Maybe a)
cutoff n _ | n <= 0 = pure Nothing
cutoff n (FreeT m) = FreeT $ bimap Just (cutoff (n - 1)) <$> m

-- | @partialIterT n phi m@ interprets first @n@ layers of @m@ using @phi@.
-- This is sort of the opposite for @'cutoff'@.
Expand Down
Loading