{-# 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 { forall (f :: * -> *). Trav f -> f ()
getTrav :: f () }

instance Apply f => Semigroup (Trav f) where
  Trav f ()
a <> :: Trav f -> Trav f -> Trav f
<> Trav f ()
b = forall (f :: * -> *). f () -> Trav f
Trav (f ()
a 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 = forall (f :: * -> *). f () -> Trav f
Trav forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() 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 = forall (f :: * -> *). f () -> Trav f
Trav (f a
a 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 = forall (f :: * -> *). f () -> Trav f
Trav (() forall (f :: * -> *) a b. Functor f => a -> f b -> 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 :: forall (f :: * -> *).
Reducer (f ()) (Trav f) =>
Trav f -> f () -> Trav f
snocTrav Trav f
a = forall a. Semigroup a => a -> a -> a
(<>) Trav f
a forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 { forall (f :: * -> *) m. App f m -> f m
getApp :: f m }
  deriving (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
<$ :: forall a b. a -> App f b -> App f a
$c<$ :: forall (f :: * -> *) a b. Functor f => a -> App f b -> App f a
fmap :: forall a b. (a -> b) -> App f a -> App f b
$cfmap :: forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> App f a -> App f b
Functor,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 :: forall a b c. (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
<. :: forall a b. 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
.> :: forall a b. 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
<.> :: forall a 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
Apply)

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