associative-0.0.4: src/Data/Associative/MonoidOp.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wall -Werror #-}

-- |
-- A monoid operation is an associative binary operation with an identity element
-- that is defined for all pairs of inputs.
module Data.Associative.MonoidOp
  ( -- * Types
    MonoidOpT (..),
    MonoidOp,
    MonoidOpT',
    MonoidOp',

    -- * Isomorphisms
    iMonoidOpT,
    iMonoidOp,

    -- * Running
    runMonoidOpT,
    runMonoidOp,
    identityMonoidOpT,
    identityMonoidOp,

    -- * Smart constructors
    monoid,

    -- * Laws
    monoidLawAssociative,
    monoidLawLeftIdentity,
    monoidLawRightIdentity,

    -- * Classy optics
    HasMonoidOpT (..),
    AsMonoidOpT (..),

    -- * Values (via monoid)
    monoidUnit,
    monoidOrdering,
    monoidList,
    monoidProxy,
    monoidMaybe,
    monoidDual,
    monoidDown,
    monoidIdentity,
    monoidTuple,
    monoidWrappedMonoid,
    monoidFunction,
    monoidAlt,
    monoidAlternative,
    monoidLiftF2,
    monoidLiftA2,

    -- * Values (via MonoidOpT)
    monoidMin,
    monoidMax,
    monoidAll,
    monoidAny,
    monoidAddition,
    monoidMultiplication,
    monoidEndo,
    monoidAnd,
    monoidIor,
    monoidXor,
    monoidIff,

    -- * Collection values
    monoidSetUnion,
    monoidIntSetUnion,
    monoidHashSetUnion,
    monoidMapUnion,
    monoidIntMapUnion,
    monoidHashMapUnion,
  )
where

import Control.Applicative (Alternative (..))
import Control.Lens
  ( Iso,
    Lens',
    Prism',
    iso,
    lens,
  )
import Data.Associative.SemigroupOp
  ( HasSemigroupOpT (..),
    SemigroupOp',
    SemigroupOpT (..),
    op,
    runSemigroupOp,
    runSemigroupOpT,
    semigroupDown,
    semigroupDual,
    semigroupFunction,
    semigroupIdentity,
    semigroupLawAssociative,
    semigroupLiftA2,
    semigroupMaybe,
    semigroupTuple,
    semigroupWrappedMonoid,
  )
import qualified Data.Associative.SemigroupOp as SG (semigroupSemigroup)
import Data.Bits (Bits, FiniteBits, complement, xor, zeroBits, (.&.), (.|.))
import Data.Functor.Alt (Alt (..))
import Data.Functor.Identity (Identity (..))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.Hashable (Hashable)
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Ord (Down (..))
import Data.Proxy (Proxy (..))
import Data.Semigroup (Dual (..), WrappedMonoid (..))
import Data.Set (Set)
import qualified Data.Set as Set
import GHC.Generics (Generic)

-- $setup
-- >>> import Data.Associative.SemigroupOp (SemigroupOpT(..), SemigroupOp', op, semigroupList)
-- >>> import Control.Lens (view, review)
-- >>> import Data.Functor.Identity (Identity(..))
-- >>> import Data.Ord (Down(..))
-- >>> import Data.Proxy (Proxy(..))
-- >>> import Data.Semigroup (Dual(..), WrappedMonoid(..))
-- >>> import Data.Word (Word8)
-- >>> import qualified Data.Set as Set
-- >>> import qualified Data.IntSet as IntSet
-- >>> import qualified Data.HashSet as HashSet
-- >>> import qualified Data.Map as Map
-- >>> import qualified Data.IntMap as IntMap
-- >>> import qualified Data.HashMap.Strict as HashMap
-- >>> import Data.List (sort)
-- >>> let add = MonoidOpT (op (+)) 0 :: MonoidOp' Int
-- >>> let run = runMonoidOp
-- >>> let runT = runMonoidOpT

-- | A monoid transformer. The wrapped operation must be associative
-- (see 'monoidLawAssociative') with an identity element.
--
-- >>> run add 3 4
-- 7
-- >>> identityMonoidOp add
-- 0
data MonoidOpT f a b i = MonoidOpT (SemigroupOpT f a b) i
  deriving (Generic)

-- | A monoid using 'Identity' as the base functor.
type MonoidOp a b i = MonoidOpT Identity a b i

-- | A monoid transformer where input, output, and identity types coincide.
type MonoidOpT' f x = MonoidOpT f x x x

-- | A monoid where input, output, and identity types coincide.
type MonoidOp' x = MonoidOp x x x

-- | Iso between 'MonoidOpT' and its underlying function paired with identity.
--
-- >>> let (f, e) = view iMonoidOpT add
-- >>> f 3 4
-- Identity 7
-- >>> e
-- 0
iMonoidOpT :: Iso (MonoidOpT f a b i) (MonoidOpT f' a' b' i') (a -> a -> f b, i) (a' -> a' -> f' b', i')
iMonoidOpT =
  iso
    (\(MonoidOpT (SemigroupOpT k) e) -> (k, e))
    (\(f, e) -> MonoidOpT (SemigroupOpT f) e)
{-# INLINE iMonoidOpT #-}

-- | Iso between 'MonoidOp' and a pure function paired with identity.
--
-- >>> let (f, e) = view iMonoidOp add
-- >>> f 3 4
-- 7
-- >>> e
-- 0
iMonoidOp :: Iso (MonoidOp a b i) (MonoidOp a' b' i') (a -> a -> b, i) (a' -> a' -> b', i')
iMonoidOp =
  iso
    (\(MonoidOpT s e) -> (runSemigroupOp s, e))
    (\(f, e) -> MonoidOpT (op f) e)
{-# INLINE iMonoidOp #-}

-- | Unwrap a 'MonoidOpT' to run its underlying operation.
--
-- >>> runT add 3 4
-- Identity 7
runMonoidOpT :: MonoidOpT f a b i -> a -> a -> f b
runMonoidOpT (MonoidOpT s _) = runSemigroupOpT s
{-# INLINE runMonoidOpT #-}

-- | Run a 'MonoidOp' (specialised to 'Identity').
--
-- >>> run add 3 4
-- 7
runMonoidOp :: MonoidOp a b i -> a -> a -> b
runMonoidOp (MonoidOpT s _) = runSemigroupOp s
{-# INLINE runMonoidOp #-}

-- | Extract the identity element from a 'MonoidOpT'.
--
-- >>> identityMonoidOpT add
-- 0
-- >>> identityMonoidOpT monoidList
-- []
identityMonoidOpT :: MonoidOpT f a b i -> i
identityMonoidOpT (MonoidOpT _ e) = e
{-# INLINE identityMonoidOpT #-}

-- | Extract the identity element from a 'MonoidOp'.
--
-- >>> identityMonoidOp add
-- 0
-- >>> identityMonoidOp monoidList
-- []
identityMonoidOp :: MonoidOp a b i -> i
identityMonoidOp (MonoidOpT _ e) = e
{-# INLINE identityMonoidOp #-}

-- | Build a 'MonoidOp'' from any 'Monoid' instance.
--
-- >>> run (monoid :: MonoidOp' [Int]) [1,2] [3,4]
-- [1,2,3,4]
-- >>> identityMonoidOp (monoid :: MonoidOp' [Int])
-- []
monoid :: (Monoid a) => MonoidOp' a
monoid = MonoidOpT SG.semigroupSemigroup mempty
{-# INLINE monoid #-}

-- | Classy lens giving access to the underlying 'SemigroupOpT'.
--
-- >>> import Data.Associative.SemigroupOp (runSemigroupOp)
-- >>> runSemigroupOp (view semigroupOpT add) 3 4
-- 7
instance HasSemigroupOpT (MonoidOpT f a b i) f a b where
  semigroupOpT = lens (\(MonoidOpT s _) -> s) (\(MonoidOpT _ e) s' -> MonoidOpT s' e)

{- HLINT ignore "Monoid law, left identity" -}
{- HLINT ignore "Monoid law, right identity" -}

----
-- Law-checking functions
----

-- | Associativity: @f (f x y) z == f x (f y z)@
--
-- >>> runIdentity $ monoidLawAssociative add 1 2 3
-- True
monoidLawAssociative :: (Monad f, Eq a) => MonoidOpT' f a -> a -> a -> a -> f Bool
monoidLawAssociative (MonoidOpT s _) = semigroupLawAssociative s

-- | Left identity: @f e a == a@
--
-- >>> runIdentity $ monoidLawLeftIdentity add 42
-- True
-- >>> runIdentity $ monoidLawLeftIdentity monoidList [1,2,3 :: Int]
-- True
monoidLawLeftIdentity :: (Monad f, Eq a) => MonoidOpT' f a -> a -> f Bool
monoidLawLeftIdentity m a = do
  r <- runMonoidOpT m (identityMonoidOpT m) a
  pure (r == a)

-- | Right identity: @f a e == a@
--
-- >>> runIdentity $ monoidLawRightIdentity add 42
-- True
-- >>> runIdentity $ monoidLawRightIdentity monoidList [1,2,3 :: Int]
-- True
monoidLawRightIdentity :: (Monad f, Eq a) => MonoidOpT' f a -> a -> f Bool
monoidLawRightIdentity m a = do
  r <- runMonoidOpT m a (identityMonoidOpT m)
  pure (r == a)

-- | Classy lens for types that contain a 'MonoidOpT'.
--
-- >>> run (view monoidOpT add) 3 4
-- 7
class HasMonoidOpT c f a b i | c -> f a b i where
  monoidOpT :: Lens' c (MonoidOpT f a b i)

instance HasMonoidOpT (MonoidOpT f a b i) f a b i where
  monoidOpT = id

-- | Classy prism for types that can be constructed from a 'MonoidOpT'.
--
-- >>> run (review _MonoidOpT add) 3 4
-- 7
class AsMonoidOpT c f a b i | c -> f a b i where
  _MonoidOpT :: Prism' c (MonoidOpT f a b i)

instance AsMonoidOpT (MonoidOpT f a b i) f a b i where
  _MonoidOpT = id

----
-- MonoidOp' values via monoid
----

-- | >>> run monoidUnit () ()
-- ()
-- >>> identityMonoidOp monoidUnit
-- ()
monoidUnit :: MonoidOp' ()
monoidUnit = monoid

-- | Lexicographic composition of orderings.
--
-- >>> run monoidOrdering LT GT
-- LT
-- >>> run monoidOrdering EQ GT
-- GT
-- >>> identityMonoidOp monoidOrdering
-- EQ
monoidOrdering :: MonoidOp' Ordering
monoidOrdering = monoid

-- | List concatenation.
--
-- >>> run monoidList [1,2] [3,4 :: Int]
-- [1,2,3,4]
-- >>> identityMonoidOp monoidList
-- []
monoidList :: MonoidOp' [a]
monoidList = monoid

-- | >>> run monoidProxy Proxy (Proxy :: Proxy Int)
-- Proxy
-- >>> identityMonoidOp monoidProxy
-- Proxy
monoidProxy :: MonoidOp' (Proxy a)
monoidProxy = monoid

-- | 'Nothing' is identity; 'Just' values are combined.
--
-- >>> run (monoidMaybe semigroupList) (Just [1]) (Just [2 :: Int])
-- Just [1,2]
-- >>> run (monoidMaybe semigroupList) Nothing (Just [2 :: Int])
-- Just [2]
-- >>> identityMonoidOp (monoidMaybe semigroupList)
-- Nothing
monoidMaybe :: SemigroupOp' a -> MonoidOp' (Maybe a)
monoidMaybe s = MonoidOpT (semigroupMaybe s) Nothing

-- | Reverses the inner monoid.
--
-- >>> run (monoidDual monoidList) (Dual [1]) (Dual [2 :: Int])
-- Dual {getDual = [2,1]}
-- >>> identityMonoidOp (monoidDual (monoidList :: MonoidOp' [Int]))
-- Dual {getDual = []}
monoidDual :: MonoidOp' a -> MonoidOp' (Dual a)
monoidDual (MonoidOpT s e) = MonoidOpT (semigroupDual s) (Dual e)

-- | Delegates through 'Down'.
--
-- >>> run (monoidDown monoidList) (Down [1]) (Down [2 :: Int])
-- Down [1,2]
monoidDown :: MonoidOp' a -> MonoidOp' (Down a)
monoidDown (MonoidOpT s e) = MonoidOpT (semigroupDown s) (Down e)

-- | Delegates through 'Identity'.
--
-- >>> run (monoidIdentity monoidList) (Identity [1]) (Identity [2 :: Int])
-- Identity [1,2]
monoidIdentity :: MonoidOp' a -> MonoidOp' (Identity a)
monoidIdentity (MonoidOpT s e) = MonoidOpT (semigroupIdentity s) (Identity e)

-- | Pairwise combination.
--
-- >>> run (monoidTuple monoidList monoidList) ([1 :: Int], [10]) ([2], [20 :: Int])
-- ([1,2],[10,20])
-- >>> identityMonoidOp (monoidTuple monoidList monoidList :: MonoidOp' ([Int], [Int]))
-- ([],[])
monoidTuple :: MonoidOp' a -> MonoidOp' b -> MonoidOp' (a, b)
monoidTuple (MonoidOpT sa ea) (MonoidOpT sb eb) = MonoidOpT (semigroupTuple sa sb) (ea, eb)

-- | Uses the underlying monoid operation.
--
-- >>> run (monoidWrappedMonoid monoidList) (WrapMonoid [1]) (WrapMonoid [2 :: Int])
-- WrapMonoid {unwrapMonoid = [1,2]}
monoidWrappedMonoid :: MonoidOp' a -> MonoidOp' (WrappedMonoid a)
monoidWrappedMonoid (MonoidOpT s e) = MonoidOpT (semigroupWrappedMonoid s) (WrapMonoid e)

-- | Pointwise combination.
--
-- >>> run (monoidFunction monoidList) (++ "a") ((++ "b") :: String -> String) "x"
-- "xaxb"
monoidFunction :: MonoidOp' b -> MonoidOp' (a -> b)
monoidFunction (MonoidOpT s e) = MonoidOpT (semigroupFunction s) (const e)

-- | First-success on 'Maybe' via 'Alt'.
--
-- >>> run monoidAlt (Just 1) (Just 2 :: Maybe Int)
-- Just 1
-- >>> run monoidAlt Nothing (Just 2 :: Maybe Int)
-- Just 2
-- >>> identityMonoidOp monoidAlt
-- Nothing
monoidAlt :: MonoidOp' (Maybe a)
monoidAlt = MonoidOpT (op (<!>)) Nothing

-- | First-success on 'Maybe' via 'Alternative'.
--
-- >>> run monoidAlternative (Just 1) (Just 2 :: Maybe Int)
-- Just 1
-- >>> run monoidAlternative Nothing (Just 2 :: Maybe Int)
-- Just 2
-- >>> identityMonoidOp monoidAlternative
-- Nothing
monoidAlternative :: MonoidOp' (Maybe a)
monoidAlternative = MonoidOpT (op (<|>)) Nothing

-- | Lift a monoid operation through an 'Data.Functor.Apply.Apply' functor via 'Data.Functor.Apply.liftF2'.
-- Requires 'Applicative' for 'pure' to construct the identity element.
--
-- >>> run (monoidLiftF2 add) (Just 3) (Just 4 :: Maybe Int)
-- Just 7
-- >>> identityMonoidOp (monoidLiftF2 add :: MonoidOp' (Maybe Int))
-- Just 0
monoidLiftF2 :: (Applicative f) => MonoidOp' a -> MonoidOp' (f a)
monoidLiftF2 (MonoidOpT s e) = MonoidOpT (semigroupLiftA2 s) (pure e)

-- | Lift a monoid operation through an 'Applicative' functor via 'Control.Applicative.liftA2'.
--
-- >>> run (monoidLiftA2 add) (Just 3) (Just 4 :: Maybe Int)
-- Just 7
-- >>> identityMonoidOp (monoidLiftA2 add :: MonoidOp' (Maybe Int))
-- Just 0
monoidLiftA2 :: (Applicative f) => MonoidOp' a -> MonoidOp' (f a)
monoidLiftA2 (MonoidOpT s e) = MonoidOpT (semigroupLiftA2 s) (pure e)

----
-- MonoidOp' values via MonoidOpT constructor
----

-- | Takes the minimum ('Min'). Requires 'Bounded' for 'maxBound' identity.
--
-- >>> run monoidMin (3 :: Int) 4
-- 3
-- >>> identityMonoidOp monoidMin == (maxBound :: Int)
-- True
monoidMin :: (Ord a, Bounded a) => MonoidOp' a
monoidMin = MonoidOpT (op min) maxBound

-- | Takes the maximum ('Max'). Requires 'Bounded' for 'minBound' identity.
--
-- >>> run monoidMax (3 :: Int) 4
-- 4
-- >>> identityMonoidOp monoidMax == (minBound :: Int)
-- True
monoidMax :: (Ord a, Bounded a) => MonoidOp' a
monoidMax = MonoidOpT (op max) minBound

-- | Logical conjunction ('All'). Identity is 'True'.
--
-- >>> run monoidAll True True
-- True
-- >>> run monoidAll True False
-- False
-- >>> identityMonoidOp monoidAll
-- True
monoidAll :: MonoidOp' Bool
monoidAll = MonoidOpT (op (&&)) True

-- | Logical disjunction ('Any'). Identity is 'False'.
--
-- >>> run monoidAny False False
-- False
-- >>> run monoidAny False True
-- True
-- >>> identityMonoidOp monoidAny
-- False
monoidAny :: MonoidOp' Bool
monoidAny = MonoidOpT (op (||)) False

-- | Addition ('Sum'). Identity is 0.
--
-- >>> run monoidAddition (3 :: Int) 4
-- 7
-- >>> identityMonoidOp monoidAddition
-- 0
monoidAddition :: (Num a) => MonoidOp' a
monoidAddition = MonoidOpT (op (+)) 0

-- | Multiplication ('Product'). Identity is 1.
--
-- >>> run monoidMultiplication (3 :: Int) 4
-- 12
-- >>> identityMonoidOp monoidMultiplication
-- 1
monoidMultiplication :: (Num a) => MonoidOp' a
monoidMultiplication = MonoidOpT (op (*)) 1

-- | Function composition ('Endo'). Identity is 'id'.
--
-- >>> run monoidEndo (+1) ((*10) :: Int -> Int) 3
-- 31
-- >>> identityMonoidOp monoidEndo 42
-- 42
monoidEndo :: MonoidOp' (a -> a)
monoidEndo = MonoidOpT (op (.)) id

-- | Bitwise AND. Identity is all ones ('complement' 'zeroBits').
--
-- >>> run monoidAnd (0xFF :: Word8) 0x0F
-- 15
-- >>> identityMonoidOp monoidAnd == (0xFF :: Word8)
-- True
monoidAnd :: (Bits a) => MonoidOp' a
monoidAnd = MonoidOpT (op (.&.)) (complement zeroBits)

-- | Bitwise inclusive OR. Identity is 'zeroBits'.
--
-- >>> run monoidIor (0xF0 :: Word8) 0x0F
-- 255
-- >>> identityMonoidOp monoidIor == (0 :: Word8)
-- True
monoidIor :: (Bits a) => MonoidOp' a
monoidIor = MonoidOpT (op (.|.)) zeroBits

-- | Bitwise exclusive OR. Identity is 'zeroBits'.
--
-- >>> run monoidXor (0xFF :: Word8) 0x0F
-- 240
-- >>> identityMonoidOp monoidXor == (0 :: Word8)
-- True
monoidXor :: (Bits a) => MonoidOp' a
monoidXor = MonoidOpT (op xor) zeroBits

-- | Bitwise equivalence / XNOR. Identity is all ones ('complement' 'zeroBits').
--
-- >>> run monoidIff (0xFF :: Word8) 0x0F
-- 15
-- >>> identityMonoidOp monoidIff == (0xFF :: Word8)
-- True
monoidIff :: (FiniteBits a) => MonoidOp' a
monoidIff = MonoidOpT (op (\a b -> complement (xor a b))) (complement zeroBits)

----
-- Collection values
----

-- | Set union. Identity is 'Set.empty'.
--
-- >>> run monoidSetUnion (Set.fromList [1,2]) (Set.fromList [2,3 :: Int])
-- fromList [1,2,3]
-- >>> identityMonoidOp monoidSetUnion == (Set.empty :: Set Int)
-- True
monoidSetUnion :: (Ord a) => MonoidOp' (Set a)
monoidSetUnion = MonoidOpT (op Set.union) Set.empty

-- | IntSet union. Identity is 'IntSet.empty'.
--
-- >>> run monoidIntSetUnion (IntSet.fromList [1,2]) (IntSet.fromList [2,3])
-- fromList [1,2,3]
-- >>> identityMonoidOp monoidIntSetUnion == IntSet.empty
-- True
monoidIntSetUnion :: MonoidOp' IntSet
monoidIntSetUnion = MonoidOpT (op IntSet.union) IntSet.empty

-- | HashSet union. Identity is 'HashSet.empty'.
--
-- >>> sort (HashSet.toList (run monoidHashSetUnion (HashSet.fromList [1,2]) (HashSet.fromList [2,3 :: Int])))
-- [1,2,3]
monoidHashSetUnion :: (Eq a, Hashable a) => MonoidOp' (HashSet a)
monoidHashSetUnion = MonoidOpT (op HashSet.union) HashSet.empty

-- | Map union (left-biased on overlapping keys). Identity is 'Map.empty'.
--
-- >>> run monoidMapUnion (Map.fromList [(1 :: Int,'a'),(2,'b')]) (Map.fromList [(2,'x'),(3,'c')])
-- fromList [(1,'a'),(2,'b'),(3,'c')]
monoidMapUnion :: (Ord k) => MonoidOp' (Map k v)
monoidMapUnion = MonoidOpT (op Map.union) Map.empty

-- | IntMap union (left-biased on overlapping keys). Identity is 'IntMap.empty'.
--
-- >>> run monoidIntMapUnion (IntMap.fromList [(1,'a'),(2,'b')]) (IntMap.fromList [(2,'x'),(3,'c')])
-- fromList [(1,'a'),(2,'b'),(3,'c')]
monoidIntMapUnion :: MonoidOp' (IntMap v)
monoidIntMapUnion = MonoidOpT (op IntMap.union) IntMap.empty

-- | HashMap union (left-biased on overlapping keys). Identity is 'HashMap.empty'.
--
-- >>> sort (HashMap.toList (run monoidHashMapUnion (HashMap.fromList [(1 :: Int,'a'),(2,'b')]) (HashMap.fromList [(2,'x'),(3,'c')])))
-- [(1,'a'),(2,'b'),(3,'c')]
monoidHashMapUnion :: (Eq k, Hashable k) => MonoidOp' (HashMap k v)
monoidHashMapUnion = MonoidOpT (op HashMap.union) HashMap.empty