{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, FlexibleContexts, TypeOperators #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MonoLocalBinds #-}
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Semigroup.Monad
-- Copyright   :  (c) Edward Kmett 2009
-- License     :  BSD-style
-- Maintainer  :  ekmett@gmail.com
-- Stability   :  experimental
-- Portability :  non-portable (MPTCs)
--
-- Semigroups for working with 'Monad's.
--
-----------------------------------------------------------------------------

module Data.Semigroup.Monad
    ( Action(..)
    , Mon(..)
    ) where

import Control.Monad (liftM, liftM2)
import Data.Semigroup.Reducer (Reducer(..))

#if !(MIN_VERSION_base(4,8,0))
import Control.Applicative (Applicative(..))
import Data.Monoid (Monoid(..))
#endif

#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup (Semigroup(..))
#endif

-- | A 'Action' uses an glues together monadic actions with (>>)
--   in the manner of 'mapM_' from "Data.Foldable". Any values returned by
--   reduced actions are discarded.
newtype Action f = Action { Action f -> f ()
getAction :: f () }

instance Monad f => Semigroup (Action f) where
  Action f ()
a <> :: Action f -> Action f -> Action f
<> Action f ()
b = f () -> Action f
forall (f :: * -> *). f () -> Action f
Action (f ()
a f () -> f () -> f ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> f ()
b)

instance Monad f => Monoid (Action f) where
  mempty :: Action f
mempty = f () -> Action f
forall (f :: * -> *). f () -> Action f
Action (() -> f ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
#if !(MIN_VERSION_base(4,11,0))
  Action a `mappend` Action b = Action (a >> b)
#endif

instance Monad f => Reducer (f a) (Action f) where
  unit :: f a -> Action f
unit f a
a            = f () -> Action f
forall (f :: * -> *). f () -> Action f
Action (f a
a f a -> f () -> f ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> f ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
  f a
a cons :: f a -> Action f -> Action f
`cons` Action f ()
b = f () -> Action f
forall (f :: * -> *). f () -> Action f
Action (f a
a f a -> f () -> f ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> f ()
b)
  Action f ()
a snoc :: Action f -> f a -> Action f
`snoc` f a
b = f () -> Action f
forall (f :: * -> *). f () -> Action f
Action (f ()
a f () -> f a -> f a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> f a
b f a -> f () -> f ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> f ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | Efficiently avoid needlessly rebinding when using 'snoc' on an action that already returns ()
--   A rewrite rule automatically applies this when possible
snocAction :: Reducer (f ()) (Action f) => Action f -> f () -> Action f
snocAction :: Action f -> f () -> Action f
snocAction Action f
a = Action f -> Action f -> Action f
forall a. Semigroup a => a -> a -> a
(<>) Action f
a (Action f -> Action f) -> (f () -> Action f) -> f () -> Action f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f () -> Action f
forall (f :: * -> *). f () -> Action f
Action
{-# RULES "unitAction" unit = Action #-}
{-# RULES "snocAction" snoc = snocAction #-}

newtype Mon f m = Mon { Mon f m -> f m
getMon :: f m }
  deriving (a -> Mon f b -> Mon f a
(a -> b) -> Mon f a -> Mon f b
(forall a b. (a -> b) -> Mon f a -> Mon f b)
-> (forall a b. a -> Mon f b -> Mon f a) -> Functor (Mon f)
forall a b. a -> Mon f b -> Mon f a
forall a b. (a -> b) -> Mon f a -> Mon f b
forall (f :: * -> *) a b. Functor f => a -> Mon f b -> Mon f a
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> Mon f a -> Mon f b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Mon f b -> Mon f a
$c<$ :: forall (f :: * -> *) a b. Functor f => a -> Mon f b -> Mon f a
fmap :: (a -> b) -> Mon f a -> Mon f b
$cfmap :: forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> Mon f a -> Mon f b
Functor,Functor (Mon f)
a -> Mon f a
Functor (Mon f)
-> (forall a. a -> Mon f a)
-> (forall a b. Mon f (a -> b) -> Mon f a -> Mon f b)
-> (forall a b c. (a -> b -> c) -> Mon f a -> Mon f b -> Mon f c)
-> (forall a b. Mon f a -> Mon f b -> Mon f b)
-> (forall a b. Mon f a -> Mon f b -> Mon f a)
-> Applicative (Mon f)
Mon f a -> Mon f b -> Mon f b
Mon f a -> Mon f b -> Mon f a
Mon f (a -> b) -> Mon f a -> Mon f b
(a -> b -> c) -> Mon f a -> Mon f b -> Mon f c
forall a. a -> Mon f a
forall a b. Mon f a -> Mon f b -> Mon f a
forall a b. Mon f a -> Mon f b -> Mon f b
forall a b. Mon f (a -> b) -> Mon f a -> Mon f b
forall a b c. (a -> b -> c) -> Mon f a -> Mon f b -> Mon f c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (f :: * -> *). Applicative f => Functor (Mon f)
forall (f :: * -> *) a. Applicative f => a -> Mon f a
forall (f :: * -> *) a b.
Applicative f =>
Mon f a -> Mon f b -> Mon f a
forall (f :: * -> *) a b.
Applicative f =>
Mon f a -> Mon f b -> Mon f b
forall (f :: * -> *) a b.
Applicative f =>
Mon f (a -> b) -> Mon f a -> Mon f b
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> Mon f a -> Mon f b -> Mon f c
<* :: Mon f a -> Mon f b -> Mon f a
$c<* :: forall (f :: * -> *) a b.
Applicative f =>
Mon f a -> Mon f b -> Mon f a
*> :: Mon f a -> Mon f b -> Mon f b
$c*> :: forall (f :: * -> *) a b.
Applicative f =>
Mon f a -> Mon f b -> Mon f b
liftA2 :: (a -> b -> c) -> Mon f a -> Mon f b -> Mon f c
$cliftA2 :: forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> Mon f a -> Mon f b -> Mon f c
<*> :: Mon f (a -> b) -> Mon f a -> Mon f b
$c<*> :: forall (f :: * -> *) a b.
Applicative f =>
Mon f (a -> b) -> Mon f a -> Mon f b
pure :: a -> Mon f a
$cpure :: forall (f :: * -> *) a. Applicative f => a -> Mon f a
$cp1Applicative :: forall (f :: * -> *). Applicative f => Functor (Mon f)
Applicative,Applicative (Mon f)
a -> Mon f a
Applicative (Mon f)
-> (forall a b. Mon f a -> (a -> Mon f b) -> Mon f b)
-> (forall a b. Mon f a -> Mon f b -> Mon f b)
-> (forall a. a -> Mon f a)
-> Monad (Mon f)
Mon f a -> (a -> Mon f b) -> Mon f b
Mon f a -> Mon f b -> Mon f b
forall a. a -> Mon f a
forall a b. Mon f a -> Mon f b -> Mon f b
forall a b. Mon f a -> (a -> Mon f b) -> Mon f b
forall (f :: * -> *). Monad f => Applicative (Mon f)
forall (f :: * -> *) a. Monad f => a -> Mon f a
forall (f :: * -> *) a b. Monad f => Mon f a -> Mon f b -> Mon f b
forall (f :: * -> *) a b.
Monad f =>
Mon f a -> (a -> Mon f b) -> Mon f b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Mon f a
$creturn :: forall (f :: * -> *) a. Monad f => a -> Mon f a
>> :: Mon f a -> Mon f b -> Mon f b
$c>> :: forall (f :: * -> *) a b. Monad f => Mon f a -> Mon f b -> Mon f b
>>= :: Mon f a -> (a -> Mon f b) -> Mon f b
$c>>= :: forall (f :: * -> *) a b.
Monad f =>
Mon f a -> (a -> Mon f b) -> Mon f b
$cp1Monad :: forall (f :: * -> *). Monad f => Applicative (Mon f)
Monad)

instance (Monad f, Semigroup m) => Semigroup (Mon f m) where
  <> :: Mon f m -> Mon f m -> Mon f m
(<>) = (m -> m -> m) -> Mon f m -> Mon f m -> Mon f m
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 m -> m -> m
forall a. Semigroup a => a -> a -> a
(<>)

instance (Monad f, Monoid m) => Monoid (Mon f m) where
  mempty :: Mon f m
mempty = m -> Mon f m
forall (m :: * -> *) a. Monad m => a -> m a
return m
forall a. Monoid a => a
mempty
#if !(MIN_VERSION_base(4,11,0))
  mappend = liftM2 mappend
#endif

instance (Monad f, Reducer c m) => Reducer (f c) (Mon f m) where
  unit :: f c -> Mon f m
unit = (c -> m) -> Mon f c -> Mon f m
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM c -> m
forall c m. Reducer c m => c -> m
unit (Mon f c -> Mon f m) -> (f c -> Mon f c) -> f c -> Mon f m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f c -> Mon f c
forall (f :: * -> *) m. f m -> Mon f m
Mon