Semigroup.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wall -Werror #-}

-- | First-class semigroup values, independent of the 'Prelude.Semigroup' type class.
module Data.Valuation.Semigroup
  ( Semigroup (..),

    -- * optics
    HasSemigroup (..),
    AsSemigroup (..),

    -- * combinators
    applySemigroup,
    applyHasSemigroup,
    applyAsSemigroup,
    semigroup',
    runSemigroup,
    liftSemigroup,
    liftRunSemigroup,

    -- * semigroup values
    first,
    second,
    dual,
    min,
    max,
    sum,
    product,
    Data.Valuation.Semigroup.all,
    Data.Valuation.Semigroup.any,
    endo,
    endoDual,
    unit,
    pair,
    ordering,
    Data.Valuation.Semigroup.maybe,
    list,
    nonEmpty,
    io,
    Data.Valuation.Semigroup.either,
    void,
    byteArray,
    event,
    comparison,
    equivalence,
    predicate,
    op,
    Data.Valuation.Semigroup.and,
    ior,
    Data.Valuation.Semigroup.xor,
    iff,
    wrappedMonoid,
    identity,
    down,
    dualM,
    solo,
    stm,
    st,
    function,
    const',
    alt,
    proxy,
    lifetime,
    tuple3,
    tuple4,
    tuple5,
    u1,
    v1,
    par1,
    rec1,
    k1,
    m1,
    productG,
    composeG,
    productF,
    composeF,

    -- * laws
    lawAssociative,
  )
where

-- \$setup
-- >>> :set -Wno-name-shadowing -Wno-type-defaults -XTypeOperators
-- >>> import Prelude hiding (Semigroup, min, max, sum, product, all, any, and, either, maybe)

import Control.Applicative (Alternative ((<|>)))
import Control.Lens
  ( Iso,
    Lens',
    Prism',
    Rewrapped,
    Wrapped (..),
    iso,
    review,
    _Wrapped,
  )
import Control.Monad.ST (ST)
import Data.Array.Byte (ByteArray)
import Data.Bits (Bits (complement, xor, (.&.), (.|.)), FiniteBits)
import Data.Functor.Compose (Compose (..))
import Data.Functor.Const (Const (..))
import Data.Functor.Contravariant
  ( Comparison,
    Equivalence,
    Predicate,
  )
import Data.Functor.Identity (Identity)
import Data.Functor.Product (Product (..))
import Data.List.NonEmpty (NonEmpty (..))
import Data.Ord (Down (..))
import Data.Proxy (Proxy (..))
import Data.Tuple (Solo)
import Data.Void (Void, absurd)
import GHC.Conc (STM)
import GHC.Event (Event, Lifetime)
import GHC.Generics (K1 (..), M1 (..), Par1 (..), Rec1 (..), U1 (..), V1, type (:*:) (..), type (:.:) (..))
import Prelude hiding (Semigroup, max, min, product, sum)
import qualified Prelude

-- | A first-class semigroup: an associative binary operation on @a@.
newtype Semigroup a
  = Semigroup (a -> a -> a)

instance (Semigroup a ~ t) => Rewrapped (Semigroup a') t

instance Wrapped (Semigroup a) where
  type Unwrapped (Semigroup a) = a -> a -> a
  _Wrapped' = iso (\(Semigroup x) -> x) Semigroup

-- | Classy lens for types that contain a 'Semigroup'.
class HasSemigroup c a | c -> a where
  semigroup :: Lens' c (Semigroup a)

instance HasSemigroup (Semigroup a) a where
  semigroup = id

-- | Classy prism for types that can be constructed from a 'Semigroup'.
class AsSemigroup c a | c -> a where
  _Semigroup :: Prism' c (Semigroup a)

instance AsSemigroup (Semigroup a) a where
  _Semigroup = id

-- | Iso between a 'Semigroup' and its underlying binary operation.
applySemigroup :: Iso (Semigroup a) (Semigroup a') (a -> a -> a) (a' -> a' -> a')
applySemigroup = _Wrapped

-- | Lens to the underlying binary operation of a 'HasSemigroup'.
applyHasSemigroup :: (HasSemigroup s a) => Lens' s (a -> a -> a)
applyHasSemigroup = semigroup . applySemigroup

-- | Prism to the underlying binary operation of an 'AsSemigroup'.
applyAsSemigroup :: (AsSemigroup s a) => Prism' s (a -> a -> a)
applyAsSemigroup = _Semigroup . applySemigroup

-- |
-- >>> lawAssociative sum (1 :: Int) 2 3
-- True
--
-- >>> lawAssociative product (2 :: Int) 3 4
-- True
--
-- >>> lawAssociative list [1,2] [3,4] [5 :: Int,6]
-- True
--
-- >>> lawAssociative min (3 :: Int) 1 2
-- True
--
-- >>> lawAssociative max (3 :: Int) 1 2
-- True
--
-- >>> lawAssociative ordering LT EQ GT
-- True
--
-- >>> lawAssociative (review applySemigroup (&&)) True False True
-- True
--
-- >>> lawAssociative (review applySemigroup (||)) True False True
-- True
--
-- >>> lawAssociative (pair sum product) (1,2) (3,4) (5 :: Int,6 :: Int)
-- True
--
-- >>> lawAssociative (Data.Valuation.Semigroup.maybe sum) (Just 1) Nothing (Just 3 :: Maybe Int)
-- True
--
-- >>> lawAssociative nonEmpty (1 :| [2]) (3 :| []) (4 :| [5 :: Int])
-- True
--
-- >>> lawAssociative first (1 :: Int) 2 3
-- True
--
-- >>> lawAssociative second (1 :: Int) 2 3
-- True
lawAssociative :: (Eq a) => Semigroup a -> a -> a -> a -> Bool
lawAssociative s a b c =
  let f = runSemigroup s
   in f (f a b) c == f a (f b c)

-- |
-- >>> runSemigroup semigroup' "ab" "cd" :: String
-- "abcd"
semigroup' :: (Prelude.Semigroup a) => Semigroup a
semigroup' = review applySemigroup (<>)

-- |
-- >>> runSemigroup sum 3 4 :: Int
-- 7
runSemigroup :: Semigroup a -> a -> a -> a
runSemigroup (Semigroup f) = f

-- | Map a 'Semigroup' through an isomorphism (unwrap, wrap).
mapSemigroup :: (b -> a) -> (a -> b) -> Semigroup a -> Semigroup b
mapSemigroup unwrap wrap s = review applySemigroup (\b1 b2 -> wrap (runSemigroup s (unwrap b1) (unwrap b2)))

-- |
-- >>> runSemigroup (liftSemigroup sum) [1, 2] [10, 20] :: [Int]
-- [11,21,12,22]
--
-- >>> runSemigroup (liftSemigroup sum) (Just 3) (Just 4) :: Maybe Int
-- Just 7
liftSemigroup :: (Applicative f) => Semigroup a -> Semigroup (f a)
liftSemigroup = review applySemigroup . liftA2 . runSemigroup

-- |
-- >>> liftRunSemigroup sum [1, 2] [10, 20] :: [Int]
-- [11,21,12,22]
liftRunSemigroup :: (Applicative f) => Semigroup a -> f a -> f a -> f a
liftRunSemigroup = liftA2 . runSemigroup

-- |
-- >>> runSemigroup first 1 2 :: Int
-- 1
--
-- >>> runSemigroup first "a" "b"
-- "a"
first :: Semigroup a
first = review applySemigroup const

-- |
-- >>> runSemigroup second 1 2 :: Int
-- 2
--
-- >>> runSemigroup second "a" "b"
-- "b"
second :: Semigroup a
second = review applySemigroup (const id)

-- |
-- >>> runSemigroup (dual first) 1 2 :: Int
-- 2
--
-- >>> runSemigroup (dual second) 1 2 :: Int
-- 1
dual :: Semigroup a -> Semigroup a
dual = review applySemigroup . flip . runSemigroup

-- |
-- >>> runSemigroup min 3 5 :: Int
-- 3
--
-- >>> runSemigroup min 5 3 :: Int
-- 3
min :: (Ord a) => Semigroup a
min = review applySemigroup Prelude.min

-- |
-- >>> runSemigroup max 3 5 :: Int
-- 5
--
-- >>> runSemigroup max 5 3 :: Int
-- 5
max :: (Ord a) => Semigroup a
max = review applySemigroup Prelude.max

-- |
-- >>> runSemigroup sum 3 4 :: Int
-- 7
--
-- >>> runSemigroup sum 0 5 :: Int
-- 5
sum :: (Num a) => Semigroup a
sum = review applySemigroup (+)

-- |
-- >>> runSemigroup product 3 4 :: Int
-- 12
--
-- >>> runSemigroup product 1 5 :: Int
-- 5
product :: (Num a) => Semigroup a
product = review applySemigroup (*)

-- |
-- >>> runSemigroup Data.Valuation.Semigroup.all True True
-- True
--
-- >>> runSemigroup Data.Valuation.Semigroup.all True False
-- False
--
-- >>> runSemigroup Data.Valuation.Semigroup.all False False
-- False
all :: Semigroup Bool
all = review applySemigroup (&&)

-- |
-- >>> runSemigroup Data.Valuation.Semigroup.any True False
-- True
--
-- >>> runSemigroup Data.Valuation.Semigroup.any False False
-- False
--
-- >>> runSemigroup Data.Valuation.Semigroup.any False True
-- True
any :: Semigroup Bool
any = review applySemigroup (||)

-- |
-- >>> runSemigroup endo (+1) (*2) 3 :: Int
-- 7
--
-- >>> runSemigroup endo (*2) (+1) 3 :: Int
-- 8
endo :: Semigroup (a -> a)
endo = review applySemigroup (.)

-- |
-- >>> runSemigroup endoDual (+1) (*2) 3 :: Int
-- 8
endoDual :: Semigroup (a -> a)
endoDual = dual endo

-- |
-- >>> runSemigroup unit () ()
-- ()
unit :: Semigroup ()
unit = review applySemigroup (\() () -> ())

-- |
-- >>> runSemigroup (pair sum product) (1, 2) (3, 4) :: (Int, Int)
-- (4,8)
--
-- >>> runSemigroup (pair min max) (1, 2) (3, 4) :: (Int, Int)
-- (1,4)
pair :: Semigroup a -> Semigroup b -> Semigroup (a, b)
pair sa sb = review applySemigroup (\(a1, b1) (a2, b2) -> (runSemigroup sa a1 a2, runSemigroup sb b1 b2))

-- |
-- >>> runSemigroup ordering LT EQ
-- LT
--
-- >>> runSemigroup ordering EQ GT
-- GT
--
-- >>> runSemigroup ordering EQ EQ
-- EQ
--
-- >>> runSemigroup ordering GT LT
-- GT
ordering :: Semigroup Ordering
ordering = review applySemigroup (\a b -> if a /= EQ then a else b)

-- |
-- >>> runSemigroup (Data.Valuation.Semigroup.maybe sum) (Just 1) (Just 2) :: Maybe Int
-- Just 3
--
-- >>> runSemigroup (Data.Valuation.Semigroup.maybe sum) (Just 1) Nothing :: Maybe Int
-- Just 1
--
-- >>> runSemigroup (Data.Valuation.Semigroup.maybe sum) Nothing (Just 2) :: Maybe Int
-- Just 2
--
-- >>> runSemigroup (Data.Valuation.Semigroup.maybe sum) Nothing Nothing :: Maybe Int
-- Nothing
maybe :: Semigroup a -> Semigroup (Maybe a)
maybe s = review applySemigroup (\a1 a2 -> Prelude.maybe a2 (\a1' -> Prelude.maybe a1 (Just . runSemigroup s a1') a2) a1)

-- |
-- >>> runSemigroup list [1, 2] [3, 4] :: [Int]
-- [1,2,3,4]
--
-- >>> runSemigroup list "ab" "cd"
-- "abcd"
list :: Semigroup [a]
list = review applySemigroup (<>)

-- |
-- >>> runSemigroup nonEmpty (1 :| [2]) (3 :| [4]) :: NonEmpty Int
-- 1 :| [2,3,4]
nonEmpty :: Semigroup (NonEmpty a)
nonEmpty = review applySemigroup (\(a :| as) (b :| bs) -> a :| (as <> (b : bs)))

-- |
-- >>> runSemigroup (io sum) (pure 3) (pure 4) :: IO Int
-- 7
io :: Semigroup a -> Semigroup (IO a)
io = liftSemigroup

-- |
-- >>> runSemigroup Data.Valuation.Semigroup.either (Right 1) (Right 2) :: Either String Int
-- Right 1
--
-- >>> runSemigroup Data.Valuation.Semigroup.either (Left "a") (Right 2) :: Either String Int
-- Right 2
--
-- >>> runSemigroup Data.Valuation.Semigroup.either (Right 1) (Left "b") :: Either String Int
-- Right 1
--
-- >>> runSemigroup Data.Valuation.Semigroup.either (Left "a") (Left "b") :: Either String String
-- Left "b"
either :: Semigroup (Either a b)
either = review applySemigroup (\a b -> case a of Right _ -> a; Left _ -> b)

-- | Vacuous semigroup on 'Void'.
void :: Semigroup Void
void = review applySemigroup (pure . absurd)

-- | Semigroup on 'ByteArray' via concatenation.
byteArray :: Semigroup ByteArray
byteArray = semigroup'

-- | Semigroup on 'Event' via bitwise OR.
event :: Semigroup Event
event = semigroup'

-- |
-- >>> import Data.Functor.Contravariant (Comparison(..), getComparison)
-- >>> let cmp1 = Comparison (compare :: Int -> Int -> Ordering)
-- >>> let cmp2 = Comparison (\a b -> compare (a `mod` 2) (b `mod` 2))
-- >>> getComparison (runSemigroup comparison cmp1 cmp2) 1 2
-- LT
--
-- >>> import Data.Functor.Contravariant (Comparison(..), getComparison)
-- >>> let cmp1 = Comparison (\_ _ -> EQ) :: Comparison Int
-- >>> let cmp2 = Comparison compare
-- >>> getComparison (runSemigroup comparison cmp1 cmp2) 1 2
-- LT
comparison :: Semigroup (Comparison a)
comparison = semigroup'

-- |
-- >>> import Data.Functor.Contravariant (Equivalence(..), getEquivalence)
-- >>> let eq1 = Equivalence ((==) :: Int -> Int -> Bool)
-- >>> let eq2 = Equivalence (\a b -> even a == even b)
-- >>> getEquivalence (runSemigroup equivalence eq1 eq2) 2 2
-- True
--
-- >>> import Data.Functor.Contravariant (Equivalence(..), getEquivalence)
-- >>> let eq1 = Equivalence ((==) :: Int -> Int -> Bool)
-- >>> let eq2 = Equivalence (\a b -> even a == even b)
-- >>> getEquivalence (runSemigroup equivalence eq1 eq2) 2 4
-- False
equivalence :: Semigroup (Equivalence a)
equivalence = semigroup'

-- |
-- >>> import Data.Functor.Contravariant (Predicate(..), getPredicate)
-- >>> let p1 = Predicate even :: Predicate Int
-- >>> let p2 = Predicate (> 0)
-- >>> getPredicate (runSemigroup predicate p1 p2) 4
-- True
--
-- >>> import Data.Functor.Contravariant (Predicate(..), getPredicate)
-- >>> let p1 = Predicate even :: Predicate Int
-- >>> let p2 = Predicate (> 0)
-- >>> getPredicate (runSemigroup predicate p1 p2) 3
-- False
--
-- >>> import Data.Functor.Contravariant (Predicate(..), getPredicate)
-- >>> let p1 = Predicate even :: Predicate Int
-- >>> let p2 = Predicate (> 0)
-- >>> getPredicate (runSemigroup predicate p1 p2) (-2)
-- False
predicate :: Semigroup (Predicate a)
predicate = semigroup'

-- |
-- >>> runSemigroup (Data.Valuation.Semigroup.op sum) (+ 1) (+ 2) 10 :: Int
-- 23
op :: Semigroup b -> Semigroup (a -> b)
op = liftSemigroup

-- |
-- >>> runSemigroup Data.Valuation.Semigroup.and (0xFF :: Int) (0x0F :: Int) :: Int
-- 15
and :: (Bits a) => Semigroup a
and = review applySemigroup (.&.)

-- |
-- >>> runSemigroup ior (0xF0 :: Int) (0x0F :: Int) :: Int
-- 255
ior :: (Bits a) => Semigroup a
ior = review applySemigroup (.|.)

-- |
-- >>> runSemigroup Data.Valuation.Semigroup.xor (0xFF :: Int) (0x0F :: Int) :: Int
-- 240
xor :: (Bits a) => Semigroup a
xor = review applySemigroup Data.Bits.xor

-- |
-- >>> import Data.Word (Word8)
-- >>> runSemigroup iff (0xFF :: Word8) (0x0F :: Word8)
-- 15
iff :: (FiniteBits a) => Semigroup a
iff = review applySemigroup (\a b -> complement (Data.Bits.xor a b))

-- |
-- >>> runSemigroup wrappedMonoid "ab" "cd"
-- "abcd"
wrappedMonoid :: (Prelude.Monoid a) => Semigroup a
wrappedMonoid = review applySemigroup mappend

-- |
-- >>> import Data.Functor.Identity (Identity(..))
-- >>> runSemigroup (identity sum) (Identity 3) (Identity 4)
-- Identity 7
identity :: Semigroup a -> Semigroup (Identity a)
identity = liftSemigroup

-- |
-- >>> runSemigroup (down sum) (Down 3) (Down 4)
-- Down 7
down :: Semigroup a -> Semigroup (Down a)
down = liftSemigroup

-- |
-- >>> runSemigroup (dualM sum) (1, 2) (3, 4) :: (Int, Int)
-- (4,6)
dualM :: Semigroup a -> Semigroup (a, a)
dualM s = pair s s

-- |
-- >>> runSemigroup (solo sum) (pure 3) (pure 4) :: Solo Int
-- MkSolo 7
solo :: Semigroup a -> Semigroup (Solo a)
solo = liftSemigroup

-- | Lift a 'Semigroup' through 'STM'.
stm :: Semigroup a -> Semigroup (STM a)
stm = liftSemigroup

-- | Lift a 'Semigroup' through 'ST'.
st :: Semigroup a -> Semigroup (ST s a)
st = liftSemigroup

-- |
-- >>> runSemigroup (function sum) (+ 1) (+ 2) 10 :: Int
-- 23
--
-- >>> runSemigroup (function list) words lines "hello world"
-- ["hello","world","hello world"]
function :: Semigroup b -> Semigroup (a -> b)
function = liftSemigroup

-- |
-- >>> runSemigroup (const' sum) (Const 3) (Const 4) :: Const Int String
-- Const 7
const' :: Semigroup a -> Semigroup (Const a b)
const' = mapSemigroup getConst Const

-- |
-- >>> runSemigroup alt [1, 2] [3, 4] :: [Int]
-- [1,2,3,4]
--
-- >>> runSemigroup alt Nothing (Just 1) :: Maybe Int
-- Just 1
alt :: (Alternative f) => Semigroup (f a)
alt = review applySemigroup (<|>)

-- |
-- >>> runSemigroup proxy Proxy Proxy
-- Proxy
proxy :: Semigroup (Proxy s)
proxy = review applySemigroup (\_ _ -> Proxy)

-- | Semigroup on 'Lifetime'.
lifetime :: Semigroup Lifetime
lifetime = semigroup'

-- |
-- >>> runSemigroup (tuple3 sum product min) (1, 2, 3) (4, 5, 6) :: (Int, Int, Int)
-- (5,10,3)
tuple3 :: Semigroup a -> Semigroup b -> Semigroup c -> Semigroup (a, b, c)
tuple3 sa sb sc =
  let f = runSemigroup sa; g = runSemigroup sb; h = runSemigroup sc
   in review applySemigroup (\(a1, b1, c1) (a2, b2, c2) -> (f a1 a2, g b1 b2, h c1 c2))

-- |
-- >>> runSemigroup (tuple4 sum sum sum sum) (1, 2, 3, 4) (5, 6, 7, 8) :: (Int, Int, Int, Int)
-- (6,8,10,12)
tuple4 :: Semigroup a -> Semigroup b -> Semigroup c -> Semigroup d -> Semigroup (a, b, c, d)
tuple4 sa sb sc sd =
  let f = runSemigroup sa; g = runSemigroup sb; h = runSemigroup sc; i = runSemigroup sd
   in review applySemigroup (\(a1, b1, c1, d1) (a2, b2, c2, d2) -> (f a1 a2, g b1 b2, h c1 c2, i d1 d2))

-- |
-- >>> runSemigroup (tuple5 sum sum sum sum sum) (1, 2, 3, 4, 5) (6, 7, 8, 9, 10) :: (Int, Int, Int, Int, Int)
-- (7,9,11,13,15)
tuple5 :: Semigroup a -> Semigroup b -> Semigroup c -> Semigroup d -> Semigroup e -> Semigroup (a, b, c, d, e)
tuple5 sa sb sc sd se =
  let f = runSemigroup sa; g = runSemigroup sb; h = runSemigroup sc; i = runSemigroup sd; j = runSemigroup se
   in review applySemigroup (\(a1, b1, c1, d1, e1) (a2, b2, c2, d2, e2) -> (f a1 a2, g b1 b2, h c1 c2, i d1 d2, j e1 e2))

-- |
-- >>> runSemigroup u1 U1 U1
-- U1
u1 :: Semigroup (U1 p)
u1 = review applySemigroup (\_ _ -> U1)

-- | Vacuous semigroup on 'V1' (uninhabited type).
v1 :: Semigroup (V1 p)
v1 = review applySemigroup const

-- |
-- >>> runSemigroup (par1 sum) (Par1 3) (Par1 4)
-- Par1 {unPar1 = 7}
par1 :: Semigroup p -> Semigroup (Par1 p)
par1 = mapSemigroup unPar1 Par1

-- |
-- >>> runSemigroup (rec1 list) (Rec1 [1, 2]) (Rec1 [3, 4]) :: Rec1 [] Int
-- Rec1 {unRec1 = [1,2,3,4]}
rec1 :: Semigroup (f p) -> Semigroup (Rec1 f p)
rec1 = mapSemigroup unRec1 Rec1

-- |
-- >>> runSemigroup (k1 sum) (K1 3) (K1 4) :: K1 () Int ()
-- K1 {unK1 = 7}
k1 :: Semigroup c -> Semigroup (K1 i c p)
k1 = mapSemigroup unK1 K1

-- |
-- >>> :set -XDataKinds
-- >>> runSemigroup (m1 (k1 sum)) (M1 (K1 3)) (M1 (K1 4)) :: M1 () ('GHC.Generics.MetaData "" "" "" 'False) (K1 () Int) ()
-- M1 {unM1 = K1 {unK1 = 7}}
m1 :: Semigroup (f p) -> Semigroup (M1 i c f p)
m1 = mapSemigroup unM1 M1

-- |
-- >>> :set -XTypeOperators
-- >>> runSemigroup (productG (par1 sum) (par1 product)) (Par1 1 :*: Par1 2) (Par1 3 :*: Par1 4) :: (Par1 :*: Par1) Int
-- Par1 {unPar1 = 4} :*: Par1 {unPar1 = 8}
productG :: Semigroup (f p) -> Semigroup (g p) -> Semigroup ((f :*: g) p)
productG sf sg =
  let f = runSemigroup sf; g = runSemigroup sg
   in review applySemigroup (\(a :*: b) (c :*: d) -> f a c :*: g b d)

-- |
-- >>> :set -XTypeOperators
-- >>> runSemigroup (composeG (par1 list)) (Comp1 (Par1 [1, 2])) (Comp1 (Par1 [3, 4])) :: (Par1 :.: []) Int
-- Comp1 {unComp1 = Par1 {unPar1 = [1,2,3,4]}}
composeG :: Semigroup (f (g p)) -> Semigroup ((f :.: g) p)
composeG = mapSemigroup unComp1 Comp1

-- |
-- >>> runSemigroup (productF list list) (Pair [1] [2]) (Pair [3] [4]) :: Product [] [] Int
-- Pair [1,3] [2,4]
productF :: Semigroup (f a) -> Semigroup (g a) -> Semigroup (Product f g a)
productF sf sg =
  let f = runSemigroup sf; g = runSemigroup sg
   in review applySemigroup (\(Pair a b) (Pair c d) -> Pair (f a c) (g b d))

-- |
-- >>> runSemigroup (composeF list) (Compose [[1, 2]]) (Compose [[3, 4]]) :: Compose [] [] Int
-- Compose [[1,2],[3,4]]
composeF :: Semigroup (f (g a)) -> Semigroup (Compose f g a)
composeF = mapSemigroup getCompose Compose