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

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

module Data.Semigroup.Applicative
    ( Traversal(..)
    , Ap(..)
    ) where

import Control.Applicative
import Data.Semigroup.Reducer (Reducer(..))

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

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

-- | A 'Traversal' uses an glues together 'Applicative' actions with (*>)
--   in the manner of 'traverse_' from "Data.Foldable". Any values returned by
--   reduced actions are discarded.
newtype Traversal f = Traversal { Traversal f -> f ()
getTraversal :: f () }

instance Applicative f => Semigroup (Traversal f) where
  Traversal f ()
a <> :: Traversal f -> Traversal f -> Traversal f
<> Traversal f ()
b = f () -> Traversal f
forall (f :: * -> *). f () -> Traversal f
Traversal (f ()
a f () -> f () -> f ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> f ()
b)

instance Applicative f => Monoid (Traversal f) where
  mempty :: Traversal f
mempty = f () -> Traversal f
forall (f :: * -> *). f () -> Traversal f
Traversal (() -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
#if !(MIN_VERSION_base(4,11,0))
  Traversal a `mappend` Traversal b = Traversal (a *> b)
#endif

instance Applicative f => Reducer (f a) (Traversal f) where
  unit :: f a -> Traversal f
unit = f () -> Traversal f
forall (f :: * -> *). f () -> Traversal f
Traversal (f () -> Traversal f) -> (f a -> f ()) -> f a -> Traversal f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() () -> f a -> f ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$)
  f a
a cons :: f a -> Traversal f -> Traversal f
`cons` Traversal f ()
b = f () -> Traversal f
forall (f :: * -> *). f () -> Traversal f
Traversal (f a
a f a -> f () -> f ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> f ()
b)
  Traversal f ()
a snoc :: Traversal f -> f a -> Traversal f
`snoc` f a
b = f () -> Traversal f
forall (f :: * -> *). f () -> Traversal f
Traversal (() () -> f a -> f ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (f ()
a f () -> f a -> f a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> f a
b))

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

newtype Ap f m = Ap { Ap f m -> f m
getAp :: f m }
  deriving (a -> Ap f b -> Ap f a
(a -> b) -> Ap f a -> Ap f b
(forall a b. (a -> b) -> Ap f a -> Ap f b)
-> (forall a b. a -> Ap f b -> Ap f a) -> Functor (Ap f)
forall a b. a -> Ap f b -> Ap f a
forall a b. (a -> b) -> Ap f a -> Ap f b
forall (f :: * -> *) a b. Functor f => a -> Ap f b -> Ap f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> Ap f a -> Ap f b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Ap f b -> Ap f a
$c<$ :: forall (f :: * -> *) a b. Functor f => a -> Ap f b -> Ap f a
fmap :: (a -> b) -> Ap f a -> Ap f b
$cfmap :: forall (f :: * -> *) a b. Functor f => (a -> b) -> Ap f a -> Ap f b
Functor,Functor (Ap f)
a -> Ap f a
Functor (Ap f)
-> (forall a. a -> Ap f a)
-> (forall a b. Ap f (a -> b) -> Ap f a -> Ap f b)
-> (forall a b c. (a -> b -> c) -> Ap f a -> Ap f b -> Ap f c)
-> (forall a b. Ap f a -> Ap f b -> Ap f b)
-> (forall a b. Ap f a -> Ap f b -> Ap f a)
-> Applicative (Ap f)
Ap f a -> Ap f b -> Ap f b
Ap f a -> Ap f b -> Ap f a
Ap f (a -> b) -> Ap f a -> Ap f b
(a -> b -> c) -> Ap f a -> Ap f b -> Ap f c
forall a. a -> Ap f a
forall a b. Ap f a -> Ap f b -> Ap f a
forall a b. Ap f a -> Ap f b -> Ap f b
forall a b. Ap f (a -> b) -> Ap f a -> Ap f b
forall a b c. (a -> b -> c) -> Ap f a -> Ap f b -> Ap 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 (Ap f)
forall (f :: * -> *) a. Applicative f => a -> Ap f a
forall (f :: * -> *) a b.
Applicative f =>
Ap f a -> Ap f b -> Ap f a
forall (f :: * -> *) a b.
Applicative f =>
Ap f a -> Ap f b -> Ap f b
forall (f :: * -> *) a b.
Applicative f =>
Ap f (a -> b) -> Ap f a -> Ap f b
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> Ap f a -> Ap f b -> Ap f c
<* :: Ap f a -> Ap f b -> Ap f a
$c<* :: forall (f :: * -> *) a b.
Applicative f =>
Ap f a -> Ap f b -> Ap f a
*> :: Ap f a -> Ap f b -> Ap f b
$c*> :: forall (f :: * -> *) a b.
Applicative f =>
Ap f a -> Ap f b -> Ap f b
liftA2 :: (a -> b -> c) -> Ap f a -> Ap f b -> Ap f c
$cliftA2 :: forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> Ap f a -> Ap f b -> Ap f c
<*> :: Ap f (a -> b) -> Ap f a -> Ap f b
$c<*> :: forall (f :: * -> *) a b.
Applicative f =>
Ap f (a -> b) -> Ap f a -> Ap f b
pure :: a -> Ap f a
$cpure :: forall (f :: * -> *) a. Applicative f => a -> Ap f a
$cp1Applicative :: forall (f :: * -> *). Applicative f => Functor (Ap f)
Applicative)

instance (Applicative f, Semigroup m) => Semigroup (Ap f m) where
  <> :: Ap f m -> Ap f m -> Ap f m
(<>) = (m -> m -> m) -> Ap f m -> Ap f m -> Ap f m
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 m -> m -> m
forall a. Semigroup a => a -> a -> a
(<>)

instance (Applicative f, Monoid m) => Monoid (Ap f m) where
  mempty :: Ap f m
mempty = m -> Ap f m
forall (f :: * -> *) a. Applicative f => a -> f a
pure m
forall a. Monoid a => a
mempty
#if !(MIN_VERSION_base(4,11,0))
  mappend = liftA2 mappend
#endif

instance (Applicative f, Reducer c m) => Reducer (f c) (Ap f m) where
  unit :: f c -> Ap f m
unit = (c -> m) -> Ap f c -> Ap f m
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> m
forall c m. Reducer c m => c -> m
unit (Ap f c -> Ap f m) -> (f c -> Ap f c) -> f c -> Ap f m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f c -> Ap f c
forall (f :: * -> *) m. f m -> Ap f m
Ap