associative-0.0.2: 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
    MonoidOp (..),

    -- * Isomorphism
    iMonoidOp,

    -- * Running
    runMonoidOp,
    identityMonoidOp,

    -- * Smart constructors
    monoid,

    -- * Laws
    monoidLawAssociative,
    monoidLawLeftIdentity,
    monoidLawRightIdentity,

    -- * Classy optics
    HasMonoidOp (..),
    AsMonoidOp (..),

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

    -- * Values (via MonoidOp)
    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', op, runSemigroupOp, semigroupDual, semigroupDown, semigroupFunction, semigroupIdentity, 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 = MonoidOp (op (+)) 0 :: MonoidOp Int
-- >>> let run = runMonoidOp

-- | A monoid operation: an associative binary operation with an identity element,
-- defined for all pairs of inputs.
--
-- >>> run add 3 4
-- 7
-- >>> identityMonoidOp add
-- 0
data MonoidOp a = MonoidOp (SemigroupOp' a) a
  deriving (Generic)

-- | Iso between 'MonoidOp' and a @(binary-operation, identity)@ pair.
--
-- >>> let (f, e) = view iMonoidOp add
-- >>> f 3 4
-- 7
-- >>> e
-- 0
iMonoidOp :: Iso (MonoidOp a) (MonoidOp b) (a -> a -> a, a) (b -> b -> b, b)
iMonoidOp =
  iso
    (\(MonoidOp s e) -> (runSemigroupOp s, e))
    (\(f, e) -> MonoidOp (op f) e)
{-# INLINE iMonoidOp #-}

-- | Extract the binary operation and run it.
--
-- >>> runMonoidOp add 3 4
-- 7
runMonoidOp :: MonoidOp a -> a -> a -> a
runMonoidOp (MonoidOp s _) = runSemigroupOp s
{-# INLINE runMonoidOp #-}

-- | Extract the identity element.
--
-- >>> identityMonoidOp add
-- 0
-- >>> identityMonoidOp monoidList
-- []
identityMonoidOp :: MonoidOp a -> a
identityMonoidOp (MonoidOp _ 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 = MonoidOp 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 (MonoidOp a) Identity a a where
  semigroupOpT = lens (\(MonoidOp s _) -> s) (\(MonoidOp _ e) s' -> MonoidOp 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)@
--
-- >>> monoidLawAssociative add 1 2 3
-- True
monoidLawAssociative :: (Eq a) => MonoidOp a -> a -> a -> a -> Bool
monoidLawAssociative m x y z =
  let f = runMonoidOp m
   in f (f x y) z == f x (f y z)

-- | Left identity: @f e a == a@
--
-- >>> monoidLawLeftIdentity add 42
-- True
-- >>> monoidLawLeftIdentity monoidList [1,2,3 :: Int]
-- True
monoidLawLeftIdentity :: (Eq a) => MonoidOp a -> a -> Bool
monoidLawLeftIdentity m a =
  runMonoidOp m (identityMonoidOp m) a == a

-- | Right identity: @f a e == a@
--
-- >>> monoidLawRightIdentity add 42
-- True
-- >>> monoidLawRightIdentity monoidList [1,2,3 :: Int]
-- True
monoidLawRightIdentity :: (Eq a) => MonoidOp a -> a -> Bool
monoidLawRightIdentity m a =
  runMonoidOp m a (identityMonoidOp m) == a

-- | Classy lens for types that contain a 'MonoidOp'.
--
-- >>> run (view monoidOp add) 3 4
-- 7
class HasMonoidOp c a | c -> a where
  monoidOp :: Lens' c (MonoidOp a)

instance HasMonoidOp (MonoidOp a) a where
  monoidOp = id

-- | Classy prism for types that can be constructed from a 'MonoidOp'.
--
-- >>> run (review _MonoidOp add) 3 4
-- 7
class AsMonoidOp c a | c -> a where
  _MonoidOp :: Prism' c (MonoidOp a)

instance AsMonoidOp (MonoidOp a) a where
  _MonoidOp = 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 = MonoidOp (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 (MonoidOp s e) = MonoidOp (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 (MonoidOp s e) = MonoidOp (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 (MonoidOp s e) = MonoidOp (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 (MonoidOp sa ea) (MonoidOp sb eb) = MonoidOp (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 (MonoidOp s e) = MonoidOp (semigroupWrappedMonoid s) (WrapMonoid e)

-- | Pointwise combination.
--
-- >>> run (monoidFunction monoidList) (++ "a") ((++ "b") :: String -> String) "x"
-- "xaxb"
monoidFunction :: MonoidOp b -> MonoidOp (a -> b)
monoidFunction (MonoidOp s e) = MonoidOp (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 = MonoidOp (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 = MonoidOp (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 (MonoidOp s e) = MonoidOp (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 (MonoidOp s e) = MonoidOp (semigroupLiftA2 s) (pure e)

----
-- MonoidOp values via MonoidOp 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 = MonoidOp (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 = MonoidOp (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 = MonoidOp (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 = MonoidOp (op (||)) False

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

-- | Multiplication ('Product'). Identity is 1.
--
-- >>> run monoidMultiplication (3 :: Int) 4
-- 12
-- >>> identityMonoidOp monoidMultiplication
-- 1
monoidMultiplication :: (Num a) => MonoidOp a
monoidMultiplication = MonoidOp (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 = MonoidOp (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 = MonoidOp (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 = MonoidOp (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 = MonoidOp (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 = MonoidOp (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 = MonoidOp (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 = MonoidOp (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 = MonoidOp (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 = MonoidOp (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 = MonoidOp (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 = MonoidOp (op HashMap.union) HashMap.empty