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

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

module Data.Semigroup.Apply
    ( Trav(..)
    , App(..)
    ) where

import Data.Functor.Apply
import Data.Semigroup.Reducer (Reducer(..))

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

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

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

instance Apply f => Reducer (f a) (Trav f) where
    unit :: f a -> Trav f
unit = f () -> Trav f
forall (f :: * -> *). f () -> Trav f
Trav (f () -> Trav f) -> (f a -> f ()) -> f a -> Trav 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 -> Trav f -> Trav f
`cons` Trav f ()
b = f () -> Trav f
forall (f :: * -> *). f () -> Trav f
Trav (f a
a f a -> f () -> f ()
forall (f :: * -> *) a b. Apply f => f a -> f b -> f b
.> f ()
b)
    Trav f ()
a snoc :: Trav f -> f a -> Trav f
`snoc` f a
b = f () -> Trav f
forall (f :: * -> *). f () -> Trav f
Trav (() () -> 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. Apply 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
snocTrav :: Reducer (f ()) (Trav f) => Trav f -> f () -> Trav f
snocTrav :: Trav f -> f () -> Trav f
snocTrav Trav f
a = Trav f -> Trav f -> Trav f
forall a. Semigroup a => a -> a -> a
(<>) Trav f
a (Trav f -> Trav f) -> (f () -> Trav f) -> f () -> Trav f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f () -> Trav f
forall (f :: * -> *). f () -> Trav f
Trav
{-# RULES "unitTrav" unit = Trav #-}
{-# RULES "snocTrav" snoc = snocTrav #-}

-- | A 'App' turns any 'Apply' wrapped around a 'Semigroup' into a 'Semigroup'

newtype App f m = App { App f m -> f m
getApp :: f m }
  deriving (a -> App f b -> App f a
(a -> b) -> App f a -> App f b
(forall a b. (a -> b) -> App f a -> App f b)
-> (forall a b. a -> App f b -> App f a) -> Functor (App f)
forall a b. a -> App f b -> App f a
forall a b. (a -> b) -> App f a -> App f b
forall (f :: * -> *) a b. Functor f => a -> App f b -> App f a
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> App f a -> App f b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> App f b -> App f a
$c<$ :: forall (f :: * -> *) a b. Functor f => a -> App f b -> App f a
fmap :: (a -> b) -> App f a -> App f b
$cfmap :: forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> App f a -> App f b
Functor,Functor (App f)
Functor (App f)
-> (forall a b. App f (a -> b) -> App f a -> App f b)
-> (forall a b. App f a -> App f b -> App f b)
-> (forall a b. App f a -> App f b -> App f a)
-> (forall a b c. (a -> b -> c) -> App f a -> App f b -> App f c)
-> Apply (App f)
App f a -> App f b -> App f b
App f a -> App f b -> App f a
App f (a -> b) -> App f a -> App f b
(a -> b -> c) -> App f a -> App f b -> App f c
forall a b. App f a -> App f b -> App f a
forall a b. App f a -> App f b -> App f b
forall a b. App f (a -> b) -> App f a -> App f b
forall a b c. (a -> b -> c) -> App f a -> App f b -> App f c
forall (f :: * -> *).
Functor f
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> Apply f
forall (f :: * -> *). Apply f => Functor (App f)
forall (f :: * -> *) a b. Apply f => App f a -> App f b -> App f a
forall (f :: * -> *) a b. Apply f => App f a -> App f b -> App f b
forall (f :: * -> *) a b.
Apply f =>
App f (a -> b) -> App f a -> App f b
forall (f :: * -> *) a b c.
Apply f =>
(a -> b -> c) -> App f a -> App f b -> App f c
liftF2 :: (a -> b -> c) -> App f a -> App f b -> App f c
$cliftF2 :: forall (f :: * -> *) a b c.
Apply f =>
(a -> b -> c) -> App f a -> App f b -> App f c
<. :: App f a -> App f b -> App f a
$c<. :: forall (f :: * -> *) a b. Apply f => App f a -> App f b -> App f a
.> :: App f a -> App f b -> App f b
$c.> :: forall (f :: * -> *) a b. Apply f => App f a -> App f b -> App f b
<.> :: App f (a -> b) -> App f a -> App f b
$c<.> :: forall (f :: * -> *) a b.
Apply f =>
App f (a -> b) -> App f a -> App f b
$cp1Apply :: forall (f :: * -> *). Apply f => Functor (App f)
Apply)

instance (Apply f, Semigroup m) => Semigroup (App f m) where
  <> :: App f m -> App f m -> App f m
(<>) = (m -> m -> m) -> App f m -> App f m -> App f m
forall (f :: * -> *) a b c.
Apply f =>
(a -> b -> c) -> f a -> f b -> f c
liftF2 m -> m -> m
forall a. Semigroup a => a -> a -> a
(<>)

instance (Apply f, Reducer c m) => Reducer (f c) (App f m) where
  unit :: f c -> App f m
unit = (c -> m) -> App f c -> App 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 (App f c -> App f m) -> (f c -> App f c) -> f c -> App f m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f c -> App f c
forall (f :: * -> *) m. f m -> App f m
App