Apply.hs

{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, FlexibleContexts #-}
{-# LANGUAGE CPP #-}
#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

#if __GLASGOW_HASKELL__ < 710
import Data.Functor
#endif
import Data.Functor.Apply
import Data.Semigroup (Semigroup(..))
import Data.Semigroup.Reducer (Reducer(..))

-- | 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 { getTrav :: f () }

instance Apply f => Semigroup (Trav f) where
  Trav a <> Trav b = Trav (a .> b)

instance Apply f => Reducer (f a) (Trav f) where
    unit = Trav . (() <$)
    a `cons` Trav b = Trav (a .> b)
    Trav a `snoc` b = Trav (() <$ (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 a = (<>) a . 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 { getApp :: f m }
  deriving (Functor,Apply)

instance (Apply f, Semigroup m) => Semigroup (App f m) where
  (<>) = liftF2 (<>)

instance (Apply f, Reducer c m) => Reducer (f c) (App f m) where
  unit = fmap unit . App