diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,27 @@ +Copyright 2026 Tony Morris + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/associative.cabal b/associative.cabal new file mode 100644 --- /dev/null +++ b/associative.cabal @@ -0,0 +1,62 @@ +cabal-version: 2.4 +name: associative +version: 0.0.1 +synopsis: Partial Semigroup and Semigroup operations +description: Partial Semigroup and Semigroup operations: Associative, Closed, Binary operation which may not be defined for all domains +license: BSD-3-Clause +license-file: LICENCE +author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> +maintainer: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> +copyright: Copyright (C) 2026 Tony Morris +category: Data +build-type: Simple +extra-doc-files: changelog.md +homepage: https://gitlab.com/tonymorris/associative +bug-reports: https://gitlab.com/tonymorris/associative/issues +tested-with: GHC == 9.4.8, GHC == 9.6.7 + +source-repository head + type: git + location: https://gitlab.com/tonymorris/associative + +library + exposed-modules: + Data.Associative + Data.Associative.MonoidOp + Data.Associative.PartialMonoidOp + Data.Associative.PartialSemigroupOp + Data.Associative.SemigroupOp + Data.Associative.Examples + Data.Associative.Examples.MonoidOpExamples + Data.Associative.Examples.PartialMonoidOpExamples + Data.Associative.Examples.PartialSemigroupOpExamples + Data.Associative.Examples.SemigroupOpExamples + + build-depends: base >= 4.8 && < 6 + , containers >= 0.5 && < 1 + , hashable >= 1.2 && < 2 + , lens >= 4 && < 6 + , mtl >= 2.2 && < 3 + , profunctors >= 5 && < 6 + , selective >= 0.7.0.1 && < 1 + , semigroupoids >= 5.2 && < 7 + , unordered-containers >= 0.2 && < 1 + , witherable >= 0.4 && < 1 + + hs-source-dirs: src + examples + + default-language: Haskell2010 + + ghc-options: -Wall + + +test-suite doctest + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base >= 4.8 && < 6 + , process >= 1 && < 2 + build-tool-depends: doctest:doctest >= 0.22 + default-language: Haskell2010 + ghc-options: -Wall diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,3 @@ +0.0.1 + +* This change log starts diff --git a/examples/Data/Associative/Examples.hs b/examples/Data/Associative/Examples.hs new file mode 100644 --- /dev/null +++ b/examples/Data/Associative/Examples.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -Wall -Werror #-} + +module Data.Associative.Examples + ( module Data.Associative.Examples.MonoidOpExamples, + module Data.Associative.Examples.PartialMonoidOpExamples, + module Data.Associative.Examples.PartialSemigroupOpExamples, + module Data.Associative.Examples.SemigroupOpExamples, + ) +where + +import Data.Associative.Examples.MonoidOpExamples +import Data.Associative.Examples.PartialMonoidOpExamples +import Data.Associative.Examples.PartialSemigroupOpExamples +import Data.Associative.Examples.SemigroupOpExamples diff --git a/examples/Data/Associative/Examples/MonoidOpExamples.hs b/examples/Data/Associative/Examples/MonoidOpExamples.hs new file mode 100644 --- /dev/null +++ b/examples/Data/Associative/Examples/MonoidOpExamples.hs @@ -0,0 +1,60 @@ +{-# OPTIONS_GHC -Wall -Werror #-} + +-- | +-- Example usages of "Data.Associative.MonoidOp". +module Data.Associative.Examples.MonoidOpExamples + ( -- * Constructing monoid operations + addMonoid, + catMonoid, + + -- * Identity element laws + monoidIdentityLawExample, + ) +where + +import Data.Associative.MonoidOp + ( MonoidOp (..), + identityMonoidOp, + monoidList, + runMonoidOp, + ) +import Data.Associative.SemigroupOp (op) + +-- * Constructing monoid operations + +-- | A monoid operation for addition with identity 0. +-- +-- >>> runMonoidOp addMonoid 3 4 +-- 7 +-- >>> identityMonoidOp addMonoid +-- 0 +addMonoid :: MonoidOp Int +addMonoid = MonoidOp (op (+)) 0 + +-- | A monoid operation from the 'Monoid' class. +-- +-- >>> runMonoidOp catMonoid [1,2] [3,4 :: Int] +-- [1,2,3,4] +-- >>> identityMonoidOp catMonoid +-- [] +catMonoid :: MonoidOp [Int] +catMonoid = monoidList + +-- * Identity element laws + +-- | The identity element is neutral under the operation. +-- +-- >>> let e = identityMonoidOp addMonoid +-- >>> runMonoidOp addMonoid e 42 +-- 42 +-- >>> runMonoidOp addMonoid 42 e +-- 42 +monoidIdentityLawExample :: () +monoidIdentityLawExample = () + +-- helpers to suppress unused-import warnings for re-exports used in doctests +_suppressRunMonoidOp :: MonoidOp a -> a -> a -> a +_suppressRunMonoidOp = runMonoidOp + +_suppressIdentityMonoidOp :: MonoidOp a -> a +_suppressIdentityMonoidOp = identityMonoidOp diff --git a/examples/Data/Associative/Examples/PartialMonoidOpExamples.hs b/examples/Data/Associative/Examples/PartialMonoidOpExamples.hs new file mode 100644 --- /dev/null +++ b/examples/Data/Associative/Examples/PartialMonoidOpExamples.hs @@ -0,0 +1,60 @@ +{-# OPTIONS_GHC -Wall -Werror #-} + +-- | +-- Example usages of "Data.Associative.PartialMonoidOp". +module Data.Associative.Examples.PartialMonoidOpExamples + ( -- * Constructing partial monoid operations + addPartialMonoid, + catPartialMonoid, + + -- * Identity element laws + partialMonoidIdentityLawExample, + ) +where + +import Data.Associative.PartialMonoidOp + ( PartialMonoidOp (..), + identityPartialMonoidOp, + pmonoidList, + runPartialMonoidOp, + ) +import Data.Associative.PartialSemigroupOp (total) + +-- * Constructing partial monoid operations + +-- | A partial monoid operation for addition with identity 0. +-- +-- >>> runPartialMonoidOp addPartialMonoid 3 4 +-- Just 7 +-- >>> identityPartialMonoidOp addPartialMonoid +-- 0 +addPartialMonoid :: PartialMonoidOp Int +addPartialMonoid = PartialMonoidOp (total (+)) 0 + +-- | A partial monoid operation from the 'Monoid' class. +-- +-- >>> runPartialMonoidOp catPartialMonoid [1,2] [3,4 :: Int] +-- Just [1,2,3,4] +-- >>> identityPartialMonoidOp catPartialMonoid +-- [] +catPartialMonoid :: PartialMonoidOp [Int] +catPartialMonoid = pmonoidList + +-- * Identity element laws + +-- | The identity element is neutral under the operation. +-- +-- >>> let e = identityPartialMonoidOp addPartialMonoid +-- >>> runPartialMonoidOp addPartialMonoid e 42 +-- Just 42 +-- >>> runPartialMonoidOp addPartialMonoid 42 e +-- Just 42 +partialMonoidIdentityLawExample :: () +partialMonoidIdentityLawExample = () + +-- helpers to suppress unused-import warnings for re-exports used in doctests +_suppressRunPartialMonoidOp :: PartialMonoidOp a -> a -> a -> Maybe a +_suppressRunPartialMonoidOp = runPartialMonoidOp + +_suppressIdentityPartialMonoidOp :: PartialMonoidOp a -> a +_suppressIdentityPartialMonoidOp = identityPartialMonoidOp diff --git a/examples/Data/Associative/Examples/PartialSemigroupOpExamples.hs b/examples/Data/Associative/Examples/PartialSemigroupOpExamples.hs new file mode 100644 --- /dev/null +++ b/examples/Data/Associative/Examples/PartialSemigroupOpExamples.hs @@ -0,0 +1,118 @@ +{-# OPTIONS_GHC -Wall -Werror #-} + +-- | +-- Example usages of "Data.Associative.PartialSemigroupOp". +module Data.Associative.Examples.PartialSemigroupOpExamples + ( -- * Constructing and running partial semigroups + addPositive, + multiply, + + -- * Combining operations with Semigroup (first-success fallback) + fallbackExample, + + -- * Functor + fmapPartialExample, + + -- * Using effects (monad transformer) + countedAdd, + ) +where + +import Control.Monad.State (State, get, put) +import Data.Associative.PartialSemigroupOp + ( PartialSemigroupOp', + PartialSemigroupOpT (..), + runPartialSemigroupOp, + runPartialSemigroupOpT, + total, + ) +import Data.Functor.Identity (Identity (..)) +import Prelude hiding (null) + +-- $setup +-- >>> import Data.Functor.Identity (Identity(..)) +-- >>> import Control.Monad.State (runState) + +-- * Constructing and running partial semigroups + +-- | A partial semigroup that adds two positive integers, +-- returning 'Nothing' when either input is non-positive. +-- +-- >>> runPartialSemigroupOp addPositive 3 4 +-- Just 7 +-- >>> runPartialSemigroupOp addPositive (-1) 4 +-- Nothing +-- >>> runPartialSemigroupOp addPositive 0 5 +-- Nothing +addPositive :: PartialSemigroupOp' Int +addPositive = + PartialSemigroupOpT + ( \a b -> + Identity + ( if a > 0 && b > 0 + then Just (a + b) + else Nothing + ) + ) + +-- | A partial semigroup built with the 'total' smart constructor. +-- Total operations always succeed (always return 'Just'). +-- +-- >>> runPartialSemigroupOp multiply 3 4 +-- Just 12 +-- >>> runPartialSemigroupOp multiply 0 5 +-- Just 0 +multiply :: PartialSemigroupOp' Int +multiply = total (*) + +-- * Combining operations with Semigroup (first-success fallback) + +-- | Partial semigroups combine with first-success fallback: +-- try the left operand; if it returns 'Nothing', try the right. +-- +-- >>> runPartialSemigroupOp (addPositive <> total (+)) 3 4 +-- Just 7 +-- >>> runPartialSemigroupOp (addPositive <> total (+)) (-1) 4 +-- Just 3 +fallbackExample :: PartialSemigroupOp' Int +fallbackExample = addPositive <> total (+) + +-- * Functor + +-- | 'fmap' transforms the result. +-- +-- >>> runPartialSemigroupOp (fmap (*10) addPositive) 3 4 +-- Just 70 +-- >>> runPartialSemigroupOp (fmap (*10) addPositive) (-1) 4 +-- Nothing +fmapPartialExample :: PartialSemigroupOp' Int +fmapPartialExample = fmap (* 10) addPositive + +-- * Using effects (monad transformer) + +-- | A partial semigroup that tracks how many times it's been called, +-- returning 'Nothing' when either input is non-positive. +-- +-- >>> runState (runPartialSemigroupOpT countedAdd 3 4) 0 +-- (Just 7,1) +-- >>> runState (runPartialSemigroupOpT countedAdd (-1) 4) 0 +-- (Nothing,1) +countedAdd :: PartialSemigroupOpT (State Int) Int Int +countedAdd = + PartialSemigroupOpT + ( \a b -> do + n <- get + put (n + 1) + pure + ( if a > 0 && b > 0 + then Just (a + b) + else Nothing + ) + ) + +-- helpers to suppress unused-import warnings for re-exports used in doctests +_suppressRunPartialSemigroupOp :: PartialSemigroupOp' a -> a -> a -> Maybe a +_suppressRunPartialSemigroupOp = runPartialSemigroupOp + +_suppressRunPartialSemigroupOpT :: PartialSemigroupOpT f a b -> a -> a -> f (Maybe b) +_suppressRunPartialSemigroupOpT = runPartialSemigroupOpT diff --git a/examples/Data/Associative/Examples/SemigroupOpExamples.hs b/examples/Data/Associative/Examples/SemigroupOpExamples.hs new file mode 100644 --- /dev/null +++ b/examples/Data/Associative/Examples/SemigroupOpExamples.hs @@ -0,0 +1,104 @@ +{-# OPTIONS_GHC -Wall -Werror #-} + +-- | +-- Example usages of "Data.Associative.SemigroupOp". +module Data.Associative.Examples.SemigroupOpExamples + ( -- * Constructing and running total semigroup operations + add, + cat, + + -- * Combining operations with Semigroup (pointwise) + pointwiseExample, + + -- * Functor and Profunctor + fmapTotalExample, + lmapExample, + + -- * Using effects (monad transformer) + statefulConcat, + ) +where + +import Control.Monad.State (State, get, put) +import Data.Associative.SemigroupOp + ( SemigroupOp', + SemigroupOpT (..), + op, + runSemigroupOp, + runSemigroupOpT, + ) +import Data.Functor.Identity (Identity (..)) + +-- $setup +-- >>> import Data.Functor.Identity (Identity(..)) +-- >>> import Data.Profunctor (lmap, rmap) +-- >>> import Control.Monad.State (runState) + +-- * Constructing and running total semigroup operations + +-- | A total semigroup operation for addition. +-- +-- >>> runSemigroupOp add 3 4 +-- 7 +add :: SemigroupOp' Int +add = op (+) + +-- | A total semigroup operation for list concatenation. +-- +-- >>> runSemigroupOp cat [1,2] [3,4 :: Int] +-- [1,2,3,4] +cat :: SemigroupOp' [Int] +cat = op (++) + +-- * Combining operations with Semigroup (pointwise) + +-- | Total semigroup operations combine pointwise: both operations +-- run and their results are combined via the inner 'Semigroup'. +-- +-- >>> runSemigroupOp (cat <> cat) [1] [2 :: Int] +-- [1,2,1,2] +pointwiseExample :: SemigroupOp' [Int] +pointwiseExample = cat <> cat + +-- * Functor and Profunctor + +-- | 'fmap' transforms the result of a total operation. +-- +-- >>> runSemigroupOpT (fmap show add) 3 4 +-- Identity "7" +fmapTotalExample :: SemigroupOpT Identity Int String +fmapTotalExample = fmap show add + +-- | 'lmap' transforms the inputs (contravariantly). +-- +-- >>> runSemigroupOp (lmap negate add) (-3) (-4) +-- 7 +-- +-- 'rmap' transforms the output (same as 'fmap'). +-- +-- >>> runSemigroupOp (rmap (*10) add) 3 4 +-- 70 +lmapExample :: SemigroupOp' Int +lmapExample = fmap (* 10) add + +-- * Using effects (monad transformer) + +-- | A total semigroup operation with state. +-- +-- >>> runState (runSemigroupOpT statefulConcat "hello" " world") 0 +-- ("hello world",1) +statefulConcat :: SemigroupOpT (State Int) String String +statefulConcat = + SemigroupOpT + ( \a b -> do + n <- get + put (n + 1) + pure (a ++ b) + ) + +-- helpers to suppress unused-import warnings for re-exports used in doctests +_suppressRunSemigroupOp :: SemigroupOp' a -> a -> a -> a +_suppressRunSemigroupOp = runSemigroupOp + +_suppressRunSemigroupOpT :: SemigroupOpT f a b -> a -> a -> f b +_suppressRunSemigroupOpT = runSemigroupOpT diff --git a/src/Data/Associative.hs b/src/Data/Associative.hs new file mode 100644 --- /dev/null +++ b/src/Data/Associative.hs @@ -0,0 +1,231 @@ +{-# OPTIONS_GHC -Wall -Werror #-} + +-- | +-- Associative binary operations as first-class values, with a monad-transformer +-- structure for composing effects. Includes both total and partial variants, each +-- with semigroup and monoid flavours. +-- +-- Four modules are provided: +-- +-- +--------------------------------------------------+----------------------------------------------+-----------------------------------------------------------+ +-- | Module | Type | Operation | +-- +==================================================+==============================================+===========================================================+ +-- | "Data.Associative.SemigroupOp" | @SemigroupOpT f a b@ ~ @a -> a -> f b@ | Total semigroup -- defined for all inputs | +-- +--------------------------------------------------+----------------------------------------------+-----------------------------------------------------------+ +-- | "Data.Associative.PartialSemigroupOp" | @PartialSemigroupOpT f a b@ ~ @a -> a -> f (Maybe b)@ | Partial semigroup -- may be undefined for some inputs | +-- +--------------------------------------------------+----------------------------------------------+-----------------------------------------------------------+ +-- | "Data.Associative.MonoidOp" | @MonoidOp a@ ~ @(SemigroupOp' a, a)@ | Total monoid -- semigroup with an identity element | +-- +--------------------------------------------------+----------------------------------------------+-----------------------------------------------------------+ +-- | "Data.Associative.PartialMonoidOp" | @PartialMonoidOp a@ ~ @(PartialSemigroupOp' a, a)@ | Partial monoid -- partial semigroup with an identity element | +-- +--------------------------------------------------+----------------------------------------------+-----------------------------------------------------------+ +-- +-- The semigroup types are parameterised by a functor @f@ for effects (e.g. +-- 'Data.Functor.Identity.Identity', 'IO', @State s@), an input type @a@, and a result type @b@. When +-- @a ~ b@ the operation is /endomorphic/ (the common case for semigroups). +-- +-- The monoid types pair a semigroup operation with its identity element. +-- +-- == Quick start +-- +-- @ +-- import "Data.Associative.SemigroupOp" +-- import "Data.Associative.PartialSemigroupOp" ('Data.Associative.PartialSemigroupOp.PartialSemigroupOpT'(..), 'Data.Associative.PartialSemigroupOp.runPartialSemigroupOp', 'Data.Associative.PartialSemigroupOp.total') +-- import "Data.Associative.MonoidOp" +-- import "Data.Associative.PartialMonoidOp" +-- +-- -- A total semigroup operation for addition +-- add :: 'Data.Associative.SemigroupOp.SemigroupOp'' Int +-- add = 'Data.Associative.SemigroupOp.op' (+) +-- +-- 'Data.Associative.SemigroupOp.runSemigroupOp' add 3 4 -- 7 +-- +-- -- A partial semigroup that adds two positive integers +-- addPos :: 'Data.Associative.PartialSemigroupOp.PartialSemigroupOp'' Int +-- addPos = 'Data.Associative.PartialSemigroupOp.PartialSemigroupOpT' (\\a b -> +-- Identity (if a > 0 && b > 0 then Just (a + b) else Nothing)) +-- +-- 'Data.Associative.PartialSemigroupOp.runPartialSemigroupOp' addPos 3 4 -- Just 7 +-- 'Data.Associative.PartialSemigroupOp.runPartialSemigroupOp' addPos (-1) 4 -- Nothing +-- +-- -- A monoid operation for addition with identity 0 +-- addM :: 'Data.Associative.MonoidOp.MonoidOp' Int +-- addM = 'Data.Associative.MonoidOp.MonoidOp' ('Data.Associative.SemigroupOp.op' (+)) 0 +-- +-- 'Data.Associative.MonoidOp.runMonoidOp' addM 3 4 -- 7 +-- 'Data.Associative.MonoidOp.identityMonoidOp' addM -- 0 +-- +-- -- A partial monoid operation +-- addPM :: 'Data.Associative.PartialMonoidOp.PartialMonoidOp' Int +-- addPM = 'Data.Associative.PartialMonoidOp.PartialMonoidOp' ('Data.Associative.PartialSemigroupOp.total' (+)) 0 +-- +-- 'Data.Associative.PartialMonoidOp.runPartialMonoidOp' addPM 3 4 -- Just 7 +-- 'Data.Associative.PartialMonoidOp.identityPartialMonoidOp' addPM -- 0 +-- @ +-- +-- == Smart constructors +-- +-- === SemigroupOp +-- +-- ['Data.Associative.SemigroupOp.op'] Lift a pure function @(a -> a -> b)@ into a semigroup operation +-- +-- ['Data.Associative.SemigroupOp.semigroupSemigroup'] Lift a 'Semigroup' class instance: @semigroupSemigroup = op ('<>')@ +-- +-- === PartialSemigroupOp +-- +-- ['Data.Associative.PartialSemigroupOp.total'] Lift a total pure function @(a -> a -> b)@ into a partial semigroup that always succeeds +-- +-- ['Data.Associative.PartialSemigroupOp.totalT'] Lift an effectful total function @(a -> a -> f b)@ +-- +-- ['Data.Associative.PartialSemigroupOp.psemigroupSemigroup'] Lift a 'Semigroup' class instance: @psemigroupSemigroup = total ('<>')@ +-- +-- ['Data.Associative.PartialSemigroupOp.null'] The always-undefined partial semigroup +-- +-- === MonoidOp +-- +-- ['Data.Associative.MonoidOp.monoid'] Lift a 'Monoid' class instance +-- +-- ['Data.Associative.MonoidOp.MonoidOp'] Directly pair a 'Data.Associative.SemigroupOp.SemigroupOp'' with its identity element +-- +-- === PartialMonoidOp +-- +-- ['Data.Associative.PartialMonoidOp.pmonoid'] Lift a 'Monoid' class instance +-- +-- ['Data.Associative.PartialMonoidOp.PartialMonoidOp'] Directly pair a 'Data.Associative.PartialSemigroupOp.PartialSemigroupOp'' with its identity element +-- +-- == Typeclass instances +-- +-- The semigroup types carry a rich set of instances. The monoid types provide +-- classy optics into their underlying semigroup. +-- +-- === SemigroupOpT instances +-- +-- 'Functor', 'Data.Functor.Apply.Apply', 'Applicative', 'Data.Functor.Bind.Bind', 'Monad', 'Data.Profunctor.Profunctor', 'Data.Profunctor.Strong', 'Data.Profunctor.Choice', +-- 'Data.Semigroupoid.Semigroupoid', 'Semigroup', 'Monoid', 'Control.Selective.Selective', 'Data.Functor.Extend.Extend', 'Control.Lens.Wrapped', 'Control.Lens.Rewrapped', +-- 'Control.Monad.Reader.Class.MonadReader', 'Control.Monad.Error.Class.MonadError', 'Control.Monad.State.Class.MonadState', 'Control.Monad.Writer.Class.MonadWriter', 'Control.Monad.RWS.Class.MonadRWS', 'Control.Monad.IO.Class.MonadIO', +-- 'Control.Monad.Cont.Class.MonadCont', 'Data.Functor.Alt.Alt', 'Data.Functor.Plus.Plus'. +-- +-- === PartialSemigroupOpT instances +-- +-- All of the above, plus: 'MonadFail', 'Control.Applicative.Alternative', 'Control.Monad.MonadPlus', 'Witherable.Filterable'. +-- +-- These additional instances exploit the 'Maybe' layer in @f (Maybe b)@ to +-- express failure and filtering. They are not available on 'Data.Associative.SemigroupOp.SemigroupOpT' +-- because a total operation always produces a result. +-- +-- === Semantic differences +-- +-- The 'Semigroup' and 'Monoid' instances differ between the two semigroup types: +-- +-- ['Data.Associative.PartialSemigroupOp.PartialSemigroupOpT'] First-success fallback. @p '<>' q@ tries @p@ first; +-- if it returns 'Nothing', falls back to @q@. 'mempty' is the +-- always-undefined operation. +-- +-- ['Data.Associative.SemigroupOp.SemigroupOpT'] Pointwise combination. @p '<>' q@ runs both and combines +-- their results via the inner 'Semigroup'. 'mempty' returns 'mempty' of the +-- result type. Requires @'Semigroup' b@ \/ @'Monoid' b@ on the result. +-- +-- === Classy optics on monoid types +-- +-- 'Data.Associative.MonoidOp.MonoidOp' has a 'Data.Associative.SemigroupOp.HasSemigroupOpT' instance giving lens access to the +-- underlying 'Data.Associative.SemigroupOp.SemigroupOp''. 'Data.Associative.PartialMonoidOp.PartialMonoidOp' has a 'Data.Associative.PartialSemigroupOp.HasPartialSemigroupOpT' +-- instance for the same purpose. +-- +-- == Pre-defined values +-- +-- All four modules export named values for common operations. +-- +-- === Via class instance +-- +-- @Unit@, @Void@ (semigroups only), @Ordering@, @List@, @NonEmpty@ (semigroups only), @Either@ (semigroups only), +-- @Proxy@, @Maybe@, @Dual@, @Down@, @Identity@, @Tuple@, @WrappedMonoid@, +-- @Function@, @Alt@, @Alternative@. +-- +-- === Via op \/ total +-- +-- @First@, @Last@ (semigroups only), @Min@, @Max@, @All@, @Any@, @Addition@, @Multiplication@, @Endo@, +-- @And@ (bitwise), @Ior@, @Xor@, @Iff@ (XNOR). +-- +-- === Collection operations +-- +-- Union and intersection for 'Data.Set.Set', 'Data.IntSet.IntSet', 'Data.HashSet.HashSet', 'Data.Map.Map', 'Data.IntMap.IntMap', +-- 'Data.HashMap.Strict.HashMap'. Monoid types provide union only (intersection lacks a general +-- identity element). +-- +-- == Classy optics +-- +-- Each semigroup module exports a classy lens and a classy prism: +-- +-- @ +-- class 'Data.Associative.SemigroupOp.HasSemigroupOpT' c f a b | c -> f a b where +-- 'Data.Associative.SemigroupOp.semigroupOpT' :: Lens' c ('Data.Associative.SemigroupOp.SemigroupOpT' f a b) +-- +-- class 'Data.Associative.SemigroupOp.AsSemigroupOpT' c f a b | c -> f a b where +-- 'Data.Associative.SemigroupOp._SemigroupOpT' :: Prism' c ('Data.Associative.SemigroupOp.SemigroupOpT' f a b) +-- @ +-- +-- @ +-- class 'Data.Associative.PartialSemigroupOp.HasPartialSemigroupOpT' c f a b | c -> f a b where +-- 'Data.Associative.PartialSemigroupOp.partialSemigroupOpT' :: Lens' c ('Data.Associative.PartialSemigroupOp.PartialSemigroupOpT' f a b) +-- +-- class 'Data.Associative.PartialSemigroupOp.AsPartialSemigroupOpT' c f a b | c -> f a b where +-- 'Data.Associative.PartialSemigroupOp._PartialSemigroupOpT' :: Prism' c ('Data.Associative.PartialSemigroupOp.PartialSemigroupOpT' f a b) +-- @ +-- +-- Each monoid module exports its own classy lens and prism: +-- +-- @ +-- class 'Data.Associative.MonoidOp.HasMonoidOp' c a | c -> a where +-- 'Data.Associative.MonoidOp.monoidOp' :: Lens' c ('Data.Associative.MonoidOp.MonoidOp' a) +-- +-- class 'Data.Associative.MonoidOp.AsMonoidOp' c a | c -> a where +-- 'Data.Associative.MonoidOp._MonoidOp' :: Prism' c ('Data.Associative.MonoidOp.MonoidOp' a) +-- @ +-- +-- @ +-- class 'Data.Associative.PartialMonoidOp.HasPartialMonoidOp' c a | c -> a where +-- 'Data.Associative.PartialMonoidOp.partialMonoidOp' :: Lens' c ('Data.Associative.PartialMonoidOp.PartialMonoidOp' a) +-- +-- class 'Data.Associative.PartialMonoidOp.AsPartialMonoidOp' c a | c -> a where +-- 'Data.Associative.PartialMonoidOp._PartialMonoidOp' :: Prism' c ('Data.Associative.PartialMonoidOp.PartialMonoidOp' a) +-- @ +-- +-- == Law-checking functions +-- +-- All modules export functions for verifying laws at specific inputs, useful for +-- property-based testing. +-- +-- Each module prefixes its law functions with its value prefix +-- (@semigroup@, @psemigroup@, @monoid@, @pmonoid@). +-- +-- === Semigroup modules +-- +-- * @semigroupLawAssociative@ / @psemigroupLawAssociative@ -- associativity of the binary operation itself +-- +-- * @semigroupLawSemigroupAssociative@ / @psemigroupLawSemigroupAssociative@ -- 'Semigroup' instance associativity +-- +-- * @semigroupLawMonoidLeftIdentity@ / @psemigroupLawMonoidLeftIdentity@, @semigroupLawMonoidRightIdentity@ / @psemigroupLawMonoidRightIdentity@ +-- +-- * @semigroupLawFunctorIdentity@ / @psemigroupLawFunctorIdentity@, @semigroupLawFunctorComposition@ / @psemigroupLawFunctorComposition@ +-- +-- * @semigroupLawProfunctorIdentity@ / @psemigroupLawProfunctorIdentity@ +-- +-- * @semigroupLawExtendAssociative@ / @psemigroupLawExtendAssociative@ +-- +-- * @semigroupLawSemigroupoidAssociative@ / @psemigroupLawSemigroupoidAssociative@ +-- +-- "Data.Associative.PartialSemigroupOp" additionally exports @lawFilterableIdentity@ and +-- @lawFilterableComposition@. +-- +-- === Monoid modules +-- +-- * @monoidLawAssociative@ / @pmonoidLawAssociative@ -- associativity of the binary operation +-- +-- * @monoidLawLeftIdentity@ / @pmonoidLawLeftIdentity@, @monoidLawRightIdentity@ / @pmonoidLawRightIdentity@ -- identity element laws +module Data.Associative ( + module A +) where + +import Data.Associative.MonoidOp as A +import Data.Associative.PartialMonoidOp as A +import Data.Associative.PartialSemigroupOp as A +import Data.Associative.SemigroupOp as A diff --git a/src/Data/Associative/MonoidOp.hs b/src/Data/Associative/MonoidOp.hs new file mode 100644 --- /dev/null +++ b/src/Data/Associative/MonoidOp.hs @@ -0,0 +1,508 @@ +{-# 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, + + -- * 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) +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(..), op) +-- >>> 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 (Just [1]) (Just [2 :: Int]) +-- Just [1,2] +-- >>> run monoidMaybe Nothing (Just [2 :: Int]) +-- Just [2] +-- >>> identityMonoidOp monoidMaybe +-- Nothing +monoidMaybe :: (Semigroup a) => MonoidOp (Maybe a) +monoidMaybe = monoid + +-- | Reverses the inner monoid. +-- +-- >>> run monoidDual (Dual [1]) (Dual [2 :: Int]) +-- Dual {getDual = [2,1]} +-- >>> identityMonoidOp (monoidDual :: MonoidOp (Dual [Int])) +-- Dual {getDual = []} +monoidDual :: (Monoid a) => MonoidOp (Dual a) +monoidDual = monoid + +-- | Delegates through 'Down'. +-- +-- >>> run monoidDown (Down [1]) (Down [2 :: Int]) +-- Down [1,2] +monoidDown :: (Monoid a) => MonoidOp (Down a) +monoidDown = monoid + +-- | Delegates through 'Identity'. +-- +-- >>> run monoidIdentity (Identity [1]) (Identity [2 :: Int]) +-- Identity [1,2] +monoidIdentity :: (Monoid a) => MonoidOp (Identity a) +monoidIdentity = monoid + +-- | Pairwise combination. +-- +-- >>> run monoidTuple ([1 :: Int], [10]) ([2], [20 :: Int]) +-- ([1,2],[10,20]) +-- >>> identityMonoidOp (monoidTuple :: MonoidOp ([Int], [Int])) +-- ([],[]) +monoidTuple :: (Monoid a, Monoid b) => MonoidOp (a, b) +monoidTuple = monoid + +-- | Uses the underlying 'Monoid' operation. +-- +-- >>> run monoidWrappedMonoid (WrapMonoid [1]) (WrapMonoid [2 :: Int]) +-- WrapMonoid {unwrapMonoid = [1,2]} +monoidWrappedMonoid :: (Monoid a) => MonoidOp (WrappedMonoid a) +monoidWrappedMonoid = monoid + +-- | Pointwise combination. +-- +-- >>> run monoidFunction (++ "a") ((++ "b") :: String -> String) "x" +-- "xaxb" +monoidFunction :: (Monoid b) => MonoidOp (a -> b) +monoidFunction = monoid + +-- | 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 + +---- +-- 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 diff --git a/src/Data/Associative/PartialMonoidOp.hs b/src/Data/Associative/PartialMonoidOp.hs new file mode 100644 --- /dev/null +++ b/src/Data/Associative/PartialMonoidOp.hs @@ -0,0 +1,524 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wall -Werror #-} + +-- | +-- A partial monoid operation is an associative binary operation with an identity +-- element that is not defined for all pairs of inputs. +module Data.Associative.PartialMonoidOp + ( -- * Types + PartialMonoidOp (..), + + -- * Isomorphism + iPartialMonoidOp, + + -- * Running + runPartialMonoidOp, + identityPartialMonoidOp, + + -- * Smart constructors + pmonoid, + + -- * Laws + pmonoidLawAssociative, + pmonoidLawLeftIdentity, + pmonoidLawRightIdentity, + + -- * Classy optics + HasPartialMonoidOp (..), + AsPartialMonoidOp (..), + + -- * Values (via pmonoid) + pmonoidUnit, + pmonoidOrdering, + pmonoidList, + pmonoidProxy, + pmonoidMaybe, + pmonoidDual, + pmonoidDown, + pmonoidIdentity, + pmonoidTuple, + pmonoidWrappedMonoid, + pmonoidFunction, + pmonoidAlt, + pmonoidAlternative, + + -- * Values (via PartialMonoidOp) + pmonoidMin, + pmonoidMax, + pmonoidAll, + pmonoidAny, + pmonoidAddition, + pmonoidMultiplication, + pmonoidEndo, + pmonoidAnd, + pmonoidIor, + pmonoidXor, + pmonoidIff, + + -- * Collection values + pmonoidSetUnion, + pmonoidIntSetUnion, + pmonoidHashSetUnion, + pmonoidMapUnion, + pmonoidIntMapUnion, + pmonoidHashMapUnion, + ) +where + +import Control.Applicative (Alternative (..)) +import Control.Lens + ( Iso, + Lens', + Prism', + iso, + lens, + review, + ) +import Data.Associative.PartialSemigroupOp + ( HasPartialSemigroupOpT (..), + PartialSemigroupOp', + iPartialSemigroupOp, + runPartialSemigroupOp, + psemigroupSemigroup, + total, + ) +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.PartialSemigroupOp (PartialSemigroupOpT(..), total) +-- >>> 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 = PartialMonoidOp (total (+)) 0 :: PartialMonoidOp Int +-- >>> let run = runPartialMonoidOp + +-- | A partial monoid operation: an associative binary operation with an identity +-- element, not necessarily defined for all pairs of inputs. +-- +-- >>> run add 3 4 +-- Just 7 +-- >>> identityPartialMonoidOp add +-- 0 +data PartialMonoidOp a = PartialMonoidOp (PartialSemigroupOp' a) a + deriving (Generic) + +-- | Iso between 'PartialMonoidOp' and a @(partial-binary-operation, identity)@ pair. +-- +-- >>> let (f, e) = view iPartialMonoidOp add +-- >>> f 3 4 +-- Just 7 +-- >>> e +-- 0 +iPartialMonoidOp :: Iso (PartialMonoidOp a) (PartialMonoidOp b) (a -> a -> Maybe a, a) (b -> b -> Maybe b, b) +iPartialMonoidOp = + iso + (\(PartialMonoidOp s e) -> (runPartialSemigroupOp s, e)) + (\(f, e) -> PartialMonoidOp (review iPartialSemigroupOp f) e) +{-# INLINE iPartialMonoidOp #-} + +-- | Extract the partial binary operation and run it. +-- +-- >>> runPartialMonoidOp add 3 4 +-- Just 7 +runPartialMonoidOp :: PartialMonoidOp a -> a -> a -> Maybe a +runPartialMonoidOp (PartialMonoidOp s _) = runPartialSemigroupOp s +{-# INLINE runPartialMonoidOp #-} + +-- | Extract the identity element. +-- +-- >>> identityPartialMonoidOp add +-- 0 +-- >>> identityPartialMonoidOp pmonoidList +-- [] +identityPartialMonoidOp :: PartialMonoidOp a -> a +identityPartialMonoidOp (PartialMonoidOp _ e) = e +{-# INLINE identityPartialMonoidOp #-} + +-- | Build a 'PartialMonoidOp' from any 'Monoid' instance. +-- +-- >>> run (pmonoid :: PartialMonoidOp [Int]) [1,2] [3,4] +-- Just [1,2,3,4] +-- >>> identityPartialMonoidOp (pmonoid :: PartialMonoidOp [Int]) +-- [] +pmonoid :: (Monoid a) => PartialMonoidOp a +pmonoid = PartialMonoidOp psemigroupSemigroup mempty +{-# INLINE pmonoid #-} + +-- | Classy lens giving access to the underlying 'PartialSemigroupOpT'. +-- +-- >>> import Data.Associative.PartialSemigroupOp (runPartialSemigroupOp) +-- >>> runPartialSemigroupOp (view partialSemigroupOpT add) 3 4 +-- Just 7 +instance HasPartialSemigroupOpT (PartialMonoidOp a) Identity a a where + partialSemigroupOpT = lens (\(PartialMonoidOp s _) -> s) (\(PartialMonoidOp _ e) s' -> PartialMonoidOp s' e) + +{- HLINT ignore "Monoid law, left identity" -} +{- HLINT ignore "Monoid law, right identity" -} + +---- +-- Law-checking functions +---- + +-- | Associativity of the partial monoid operation. +-- +-- Left- and right-association of three values must agree: +-- both 'Nothing' or both the same 'Just'. +-- +-- >>> pmonoidLawAssociative add 1 2 3 +-- True +pmonoidLawAssociative :: (Eq a) => PartialMonoidOp a -> a -> a -> a -> Bool +pmonoidLawAssociative m x y z = + let f = runPartialMonoidOp m + lhs = case f x y of + Nothing -> Nothing + Just xy -> f xy z + rhs = case f y z of + Nothing -> Nothing + Just yz -> f x yz + in lhs == rhs + +-- | Left identity: @f e a == Just a@ +-- +-- >>> pmonoidLawLeftIdentity add 42 +-- True +-- >>> pmonoidLawLeftIdentity pmonoidList [1,2,3 :: Int] +-- True +pmonoidLawLeftIdentity :: (Eq a) => PartialMonoidOp a -> a -> Bool +pmonoidLawLeftIdentity m a = + runPartialMonoidOp m (identityPartialMonoidOp m) a == Just a + +-- | Right identity: @f a e == Just a@ +-- +-- >>> pmonoidLawRightIdentity add 42 +-- True +-- >>> pmonoidLawRightIdentity pmonoidList [1,2,3 :: Int] +-- True +pmonoidLawRightIdentity :: (Eq a) => PartialMonoidOp a -> a -> Bool +pmonoidLawRightIdentity m a = + runPartialMonoidOp m a (identityPartialMonoidOp m) == Just a + +-- | Classy lens for types that contain a 'PartialMonoidOp'. +-- +-- >>> run (view partialMonoidOp add) 3 4 +-- Just 7 +class HasPartialMonoidOp c a | c -> a where + partialMonoidOp :: Lens' c (PartialMonoidOp a) + +instance HasPartialMonoidOp (PartialMonoidOp a) a where + partialMonoidOp = id + +-- | Classy prism for types that can be constructed from a 'PartialMonoidOp'. +-- +-- >>> run (review _PartialMonoidOp add) 3 4 +-- Just 7 +class AsPartialMonoidOp c a | c -> a where + _PartialMonoidOp :: Prism' c (PartialMonoidOp a) + +instance AsPartialMonoidOp (PartialMonoidOp a) a where + _PartialMonoidOp = id + +---- +-- PartialMonoidOp values via pmonoid +---- + +-- | >>> run pmonoidUnit () () +-- Just () +-- >>> identityPartialMonoidOp pmonoidUnit +-- () +pmonoidUnit :: PartialMonoidOp () +pmonoidUnit = pmonoid + +-- | Lexicographic composition of orderings. +-- +-- >>> run pmonoidOrdering LT GT +-- Just LT +-- >>> run pmonoidOrdering EQ GT +-- Just GT +-- >>> identityPartialMonoidOp pmonoidOrdering +-- EQ +pmonoidOrdering :: PartialMonoidOp Ordering +pmonoidOrdering = pmonoid + +-- | List concatenation. +-- +-- >>> run pmonoidList [1,2] [3,4 :: Int] +-- Just [1,2,3,4] +-- >>> identityPartialMonoidOp pmonoidList +-- [] +pmonoidList :: PartialMonoidOp [a] +pmonoidList = pmonoid + +-- | >>> run pmonoidProxy Proxy (Proxy :: Proxy Int) +-- Just Proxy +-- >>> identityPartialMonoidOp pmonoidProxy +-- Proxy +pmonoidProxy :: PartialMonoidOp (Proxy a) +pmonoidProxy = pmonoid + +-- | 'Nothing' is identity; 'Just' values are combined. +-- +-- >>> run pmonoidMaybe (Just [1]) (Just [2 :: Int]) +-- Just (Just [1,2]) +-- >>> run pmonoidMaybe Nothing (Just [2 :: Int]) +-- Just (Just [2]) +-- >>> identityPartialMonoidOp pmonoidMaybe +-- Nothing +pmonoidMaybe :: (Semigroup a) => PartialMonoidOp (Maybe a) +pmonoidMaybe = pmonoid + +-- | Reverses the inner monoid. +-- +-- >>> run pmonoidDual (Dual [1]) (Dual [2 :: Int]) +-- Just (Dual {getDual = [2,1]}) +-- >>> identityPartialMonoidOp (pmonoidDual :: PartialMonoidOp (Dual [Int])) +-- Dual {getDual = []} +pmonoidDual :: (Monoid a) => PartialMonoidOp (Dual a) +pmonoidDual = pmonoid + +-- | Delegates through 'Down'. +-- +-- >>> run pmonoidDown (Down [1]) (Down [2 :: Int]) +-- Just (Down [1,2]) +pmonoidDown :: (Monoid a) => PartialMonoidOp (Down a) +pmonoidDown = pmonoid + +-- | Delegates through 'Identity'. +-- +-- >>> run pmonoidIdentity (Identity [1]) (Identity [2 :: Int]) +-- Just (Identity [1,2]) +pmonoidIdentity :: (Monoid a) => PartialMonoidOp (Identity a) +pmonoidIdentity = pmonoid + +-- | Pairwise combination. +-- +-- >>> run pmonoidTuple ([1 :: Int], [10]) ([2], [20 :: Int]) +-- Just ([1,2],[10,20]) +-- >>> identityPartialMonoidOp (pmonoidTuple :: PartialMonoidOp ([Int], [Int])) +-- ([],[]) +pmonoidTuple :: (Monoid a, Monoid b) => PartialMonoidOp (a, b) +pmonoidTuple = pmonoid + +-- | Uses the underlying 'Monoid' operation. +-- +-- >>> run pmonoidWrappedMonoid (WrapMonoid [1]) (WrapMonoid [2 :: Int]) +-- Just (WrapMonoid {unwrapMonoid = [1,2]}) +pmonoidWrappedMonoid :: (Monoid a) => PartialMonoidOp (WrappedMonoid a) +pmonoidWrappedMonoid = pmonoid + +-- | Pointwise combination. +-- +-- >>> fmap ($ "x") (run pmonoidFunction (++ "a") ((++ "b") :: String -> String)) +-- Just "xaxb" +pmonoidFunction :: (Monoid b) => PartialMonoidOp (a -> b) +pmonoidFunction = pmonoid + +-- | First-success on 'Maybe' via 'Alt'. +-- +-- >>> run pmonoidAlt (Just 1) (Just 2 :: Maybe Int) +-- Just (Just 1) +-- >>> run pmonoidAlt Nothing (Just 2 :: Maybe Int) +-- Just (Just 2) +-- >>> identityPartialMonoidOp pmonoidAlt +-- Nothing +pmonoidAlt :: PartialMonoidOp (Maybe a) +pmonoidAlt = PartialMonoidOp (total ()) Nothing + +-- | First-success on 'Maybe' via 'Alternative'. +-- +-- >>> run pmonoidAlternative (Just 1) (Just 2 :: Maybe Int) +-- Just (Just 1) +-- >>> run pmonoidAlternative Nothing (Just 2 :: Maybe Int) +-- Just (Just 2) +-- >>> identityPartialMonoidOp pmonoidAlternative +-- Nothing +pmonoidAlternative :: PartialMonoidOp (Maybe a) +pmonoidAlternative = PartialMonoidOp (total (<|>)) Nothing + +---- +-- PartialMonoidOp values via PartialMonoidOp constructor +---- + +-- | Takes the minimum ('Min'). Requires 'Bounded' for 'maxBound' identity. +-- +-- >>> run pmonoidMin (3 :: Int) 4 +-- Just 3 +-- >>> identityPartialMonoidOp pmonoidMin == (maxBound :: Int) +-- True +pmonoidMin :: (Ord a, Bounded a) => PartialMonoidOp a +pmonoidMin = PartialMonoidOp (total min) maxBound + +-- | Takes the maximum ('Max'). Requires 'Bounded' for 'minBound' identity. +-- +-- >>> run pmonoidMax (3 :: Int) 4 +-- Just 4 +-- >>> identityPartialMonoidOp pmonoidMax == (minBound :: Int) +-- True +pmonoidMax :: (Ord a, Bounded a) => PartialMonoidOp a +pmonoidMax = PartialMonoidOp (total max) minBound + +-- | Logical conjunction ('All'). Identity is 'True'. +-- +-- >>> run pmonoidAll True True +-- Just True +-- >>> run pmonoidAll True False +-- Just False +-- >>> identityPartialMonoidOp pmonoidAll +-- True +pmonoidAll :: PartialMonoidOp Bool +pmonoidAll = PartialMonoidOp (total (&&)) True + +-- | Logical disjunction ('Any'). Identity is 'False'. +-- +-- >>> run pmonoidAny False False +-- Just False +-- >>> run pmonoidAny False True +-- Just True +-- >>> identityPartialMonoidOp pmonoidAny +-- False +pmonoidAny :: PartialMonoidOp Bool +pmonoidAny = PartialMonoidOp (total (||)) False + +-- | Addition ('Sum'). Identity is 0. +-- +-- >>> run pmonoidAddition (3 :: Int) 4 +-- Just 7 +-- >>> identityPartialMonoidOp pmonoidAddition +-- 0 +pmonoidAddition :: (Num a) => PartialMonoidOp a +pmonoidAddition = PartialMonoidOp (total (+)) 0 + +-- | Multiplication ('Product'). Identity is 1. +-- +-- >>> run pmonoidMultiplication (3 :: Int) 4 +-- Just 12 +-- >>> identityPartialMonoidOp pmonoidMultiplication +-- 1 +pmonoidMultiplication :: (Num a) => PartialMonoidOp a +pmonoidMultiplication = PartialMonoidOp (total (*)) 1 + +-- | Function composition ('Endo'). Identity is 'id'. +-- +-- >>> fmap ($ 3) (run pmonoidEndo (+1) ((*10) :: Int -> Int)) +-- Just 31 +-- >>> identityPartialMonoidOp pmonoidEndo 42 +-- 42 +pmonoidEndo :: PartialMonoidOp (a -> a) +pmonoidEndo = PartialMonoidOp (total (.)) id + +-- | Bitwise AND. Identity is all ones ('complement' 'zeroBits'). +-- +-- >>> run pmonoidAnd (0xFF :: Word8) 0x0F +-- Just 15 +-- >>> identityPartialMonoidOp pmonoidAnd == (0xFF :: Word8) +-- True +pmonoidAnd :: (Bits a) => PartialMonoidOp a +pmonoidAnd = PartialMonoidOp (total (.&.)) (complement zeroBits) + +-- | Bitwise inclusive OR. Identity is 'zeroBits'. +-- +-- >>> run pmonoidIor (0xF0 :: Word8) 0x0F +-- Just 255 +-- >>> identityPartialMonoidOp pmonoidIor == (0 :: Word8) +-- True +pmonoidIor :: (Bits a) => PartialMonoidOp a +pmonoidIor = PartialMonoidOp (total (.|.)) zeroBits + +-- | Bitwise exclusive OR. Identity is 'zeroBits'. +-- +-- >>> run pmonoidXor (0xFF :: Word8) 0x0F +-- Just 240 +-- >>> identityPartialMonoidOp pmonoidXor == (0 :: Word8) +-- True +pmonoidXor :: (Bits a) => PartialMonoidOp a +pmonoidXor = PartialMonoidOp (total xor) zeroBits + +-- | Bitwise equivalence / XNOR. Identity is all ones ('complement' 'zeroBits'). +-- +-- >>> run pmonoidIff (0xFF :: Word8) 0x0F +-- Just 15 +-- >>> identityPartialMonoidOp pmonoidIff == (0xFF :: Word8) +-- True +pmonoidIff :: (FiniteBits a) => PartialMonoidOp a +pmonoidIff = PartialMonoidOp (total (\a b -> complement (xor a b))) (complement zeroBits) + +---- +-- Collection values +---- + +-- | Set union. Identity is 'Set.empty'. +-- +-- >>> run pmonoidSetUnion (Set.fromList [1,2]) (Set.fromList [2,3 :: Int]) +-- Just (fromList [1,2,3]) +-- >>> identityPartialMonoidOp pmonoidSetUnion == (Set.empty :: Set Int) +-- True +pmonoidSetUnion :: (Ord a) => PartialMonoidOp (Set a) +pmonoidSetUnion = PartialMonoidOp (total Set.union) Set.empty + +-- | IntSet union. Identity is 'IntSet.empty'. +-- +-- >>> run pmonoidIntSetUnion (IntSet.fromList [1,2]) (IntSet.fromList [2,3]) +-- Just (fromList [1,2,3]) +-- >>> identityPartialMonoidOp pmonoidIntSetUnion == IntSet.empty +-- True +pmonoidIntSetUnion :: PartialMonoidOp IntSet +pmonoidIntSetUnion = PartialMonoidOp (total IntSet.union) IntSet.empty + +-- | HashSet union. Identity is 'HashSet.empty'. +-- +-- >>> fmap sort (fmap HashSet.toList (run pmonoidHashSetUnion (HashSet.fromList [1,2]) (HashSet.fromList [2,3 :: Int]))) +-- Just [1,2,3] +pmonoidHashSetUnion :: (Eq a, Hashable a) => PartialMonoidOp (HashSet a) +pmonoidHashSetUnion = PartialMonoidOp (total HashSet.union) HashSet.empty + +-- | Map union (left-biased on overlapping keys). Identity is 'Map.empty'. +-- +-- >>> run pmonoidMapUnion (Map.fromList [(1 :: Int,'a'),(2,'b')]) (Map.fromList [(2,'x'),(3,'c')]) +-- Just (fromList [(1,'a'),(2,'b'),(3,'c')]) +pmonoidMapUnion :: (Ord k) => PartialMonoidOp (Map k v) +pmonoidMapUnion = PartialMonoidOp (total Map.union) Map.empty + +-- | IntMap union (left-biased on overlapping keys). Identity is 'IntMap.empty'. +-- +-- >>> run pmonoidIntMapUnion (IntMap.fromList [(1,'a'),(2,'b')]) (IntMap.fromList [(2,'x'),(3,'c')]) +-- Just (fromList [(1,'a'),(2,'b'),(3,'c')]) +pmonoidIntMapUnion :: PartialMonoidOp (IntMap v) +pmonoidIntMapUnion = PartialMonoidOp (total IntMap.union) IntMap.empty + +-- | HashMap union (left-biased on overlapping keys). Identity is 'HashMap.empty'. +-- +-- >>> fmap sort (fmap HashMap.toList (run pmonoidHashMapUnion (HashMap.fromList [(1 :: Int,'a'),(2,'b')]) (HashMap.fromList [(2,'x'),(3,'c')]))) +-- Just [(1,'a'),(2,'b'),(3,'c')] +pmonoidHashMapUnion :: (Eq k, Hashable k) => PartialMonoidOp (HashMap k v) +pmonoidHashMapUnion = PartialMonoidOp (total HashMap.union) HashMap.empty diff --git a/src/Data/Associative/PartialSemigroupOp.hs b/src/Data/Associative/PartialSemigroupOp.hs new file mode 100644 --- /dev/null +++ b/src/Data/Associative/PartialSemigroupOp.hs @@ -0,0 +1,972 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wall -Werror #-} + +-- | +-- A partial semigroup operation is an associative binary operation that is not +-- defined for all pairs of inputs. +module Data.Associative.PartialSemigroupOp + ( -- * Types + PartialSemigroupOpT (..), + PartialSemigroupOp, + PartialSemigroupOpT', + PartialSemigroupOp', + + -- * Isomorphisms + iPartialSemigroupOpT, + iPartialSemigroupOp, + + -- * Running + runPartialSemigroupOpT, + runPartialSemigroupOp, + + -- * Smart constructors + totalT, + total, + psemigroupSemigroup, + null, + + -- * Laws + psemigroupLawAssociative, + psemigroupLawSemigroupAssociative, + psemigroupLawMonoidLeftIdentity, + psemigroupLawMonoidRightIdentity, + psemigroupLawFunctorIdentity, + psemigroupLawFunctorComposition, + psemigroupLawProfunctorIdentity, + lawFilterableIdentity, + lawFilterableComposition, + psemigroupLawExtendAssociative, + psemigroupLawSemigroupoidAssociative, + + -- * Classy optics + HasPartialSemigroupOpT (..), + AsPartialSemigroupOpT (..), + + -- * Values (via semigroup) + psemigroupUnit, + psemigroupVoid, + psemigroupOrdering, + psemigroupList, + psemigroupNonEmpty, + psemigroupEither, + psemigroupProxy, + psemigroupMaybe, + psemigroupDual, + psemigroupDown, + psemigroupIdentity, + psemigroupTuple, + psemigroupWrappedMonoid, + psemigroupFunction, + psemigroupAlt, + psemigroupAlternative, + + -- * Values (via total) + psemigroupFirst, + psemigroupLast, + psemigroupMin, + psemigroupMax, + psemigroupAll, + psemigroupAny, + psemigroupAddition, + psemigroupMultiplication, + psemigroupEndo, + psemigroupAnd, + psemigroupIor, + psemigroupXor, + psemigroupIff, + + -- * Collection values + psemigroupSetUnion, + psemigroupSetIntersection, + psemigroupIntSetUnion, + psemigroupIntSetIntersection, + psemigroupHashSetUnion, + psemigroupHashSetIntersection, + psemigroupMapUnion, + psemigroupMapIntersection, + psemigroupIntMapUnion, + psemigroupIntMapIntersection, + psemigroupHashMapUnion, + psemigroupHashMapIntersection, + ) +where + +import Control.Applicative (Alternative (..)) +import Control.Lens + ( Iso, + Lens', + Prism', + Rewrapped, + Wrapped (..), + iso, + review, + view, + _Wrapped, + ) +import Control.Monad (MonadPlus, (>=>)) +import Control.Monad.Cont.Class (MonadCont (..)) +import Control.Monad.Error.Class (MonadError (..)) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.RWS.Class (MonadRWS) +import Control.Monad.Reader.Class (MonadReader (..)) +import Control.Monad.State.Class (MonadState (..)) +import Control.Monad.Writer.Class (MonadWriter (..)) +import Control.Selective (Selective (..), selectM) +import Data.Bits (Bits, FiniteBits, complement, xor, (.&.), (.|.)) +import Data.Functor.Alt (Alt (..)) +import Data.Functor.Apply (Apply (..)) +import Data.Functor.Bind (Bind (..)) +import Data.Functor.Extend (Extend (..)) +import Data.Functor.Identity (Identity (..)) +import Data.Functor.Plus (Plus (..)) +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.List.NonEmpty (NonEmpty) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Ord (Down) +import Data.Profunctor (Choice (..), Profunctor (..), Strong (..)) +import Data.Proxy (Proxy) +import Data.Semigroup (Dual, WrappedMonoid) +import Data.Semigroupoid (Semigroupoid (..)) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Void (Void) +import GHC.Generics (Generic, Generic1) +import Witherable (Filterable (mapMaybe)) +import Prelude hiding (null) + +-- $setup +-- >>> :set -Wno-name-shadowing +-- >>> import Control.Lens (view, review) +-- >>> import Data.Functor.Apply (liftF2) +-- >>> import Data.Functor.Bind ((>>-)) +-- >>> import Data.Functor.Extend (extended) +-- >>> import Data.Functor.Identity (Identity(..)) +-- >>> import Data.Profunctor (dimap, lmap, rmap, first', left') +-- >>> import Data.Semigroupoid (o) +-- >>> import Witherable (mapMaybe) +-- >>> import Data.List.NonEmpty (NonEmpty(..)) +-- >>> 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 addPos = PartialSemigroupOpT (\a b -> Identity (if a > 0 && b > 0 then Just (a + b) else Nothing)) :: PartialSemigroupOp' Int +-- >>> let total = PartialSemigroupOpT (\a b -> Identity (Just (a + b))) :: PartialSemigroupOp' Int +-- >>> let run = runPartialSemigroupOp + +-- | A partial semigroup transformer. The wrapped operation must be associative +-- (see 'psemigroupLawAssociative'). +-- +-- >>> run addPos 3 4 +-- Just 7 +-- >>> run addPos (-1) 4 +-- Nothing +newtype PartialSemigroupOpT f a b = PartialSemigroupOpT (a -> a -> f (Maybe b)) + deriving (Generic, Generic1) + +-- | A partial semigroup using 'Identity' as the base functor. +type PartialSemigroupOp a b = PartialSemigroupOpT Identity a b + +-- | A partial semigroup transformer where input and output types coincide. +type PartialSemigroupOpT' f x = PartialSemigroupOpT f x x + +-- | A partial semigroup where input and output types coincide. +type PartialSemigroupOp' x = PartialSemigroupOp x x + +-- | Iso between 'PartialSemigroupOpT' and its underlying function. +-- +-- >>> view iPartialSemigroupOpT addPos 3 4 +-- Identity (Just 7) +iPartialSemigroupOpT :: Iso (PartialSemigroupOpT f a b) (PartialSemigroupOpT f' a' b') (a -> a -> f (Maybe b)) (a' -> a' -> f' (Maybe b')) +iPartialSemigroupOpT = _Wrapped +{-# INLINE iPartialSemigroupOpT #-} + +-- | Iso between 'PartialSemigroupOp' and a pure partial function. +-- +-- >>> view iPartialSemigroupOp addPos 3 4 +-- Just 7 +iPartialSemigroupOp :: Iso (PartialSemigroupOp a b) (PartialSemigroupOp a' b') (a -> a -> Maybe b) (a' -> a' -> Maybe b') +iPartialSemigroupOp = + iso + (\(PartialSemigroupOpT j) a1 a2 -> runIdentity (j a1 a2)) + (\k -> PartialSemigroupOpT (\a1 a2 -> Identity (k a1 a2))) +{-# INLINE iPartialSemigroupOp #-} + +-- | Unwrap a 'PartialSemigroupOpT' to its underlying function. +-- +-- >>> runPartialSemigroupOpT addPos 3 4 +-- Identity (Just 7) +-- >>> runPartialSemigroupOpT addPos (-1) 4 +-- Identity Nothing +runPartialSemigroupOpT :: PartialSemigroupOpT f a b -> a -> a -> f (Maybe b) +runPartialSemigroupOpT = view iPartialSemigroupOpT +{-# INLINE runPartialSemigroupOpT #-} + +-- | Run a 'PartialSemigroupOp' (specialised to 'Identity'). +-- +-- >>> runPartialSemigroupOp addPos 3 4 +-- Just 7 +-- >>> runPartialSemigroupOp addPos (-1) 4 +-- Nothing +runPartialSemigroupOp :: PartialSemigroupOp a b -> a -> a -> Maybe b +runPartialSemigroupOp = view iPartialSemigroupOp +{-# INLINE runPartialSemigroupOp #-} + +totalT :: (Functor f) => (a -> a -> f b) -> PartialSemigroupOpT f a b +totalT k = PartialSemigroupOpT (\a1 a2 -> Just <$> k a1 a2) +{-# INLINE totalT #-} + +total :: (a -> a -> b) -> PartialSemigroupOp a b +total k = review iPartialSemigroupOp (\a1 a2 -> Just (k a1 a2)) +{-# INLINE total #-} + +psemigroupSemigroup :: (Semigroup a) => PartialSemigroupOp' a +psemigroupSemigroup = total (<>) +{-# INLINE psemigroupSemigroup #-} + +null :: (Applicative f) => PartialSemigroupOpT f a b +null = PartialSemigroupOpT (\_ _ -> pure Nothing) +{-# INLINE null #-} + +instance + (PartialSemigroupOpT f a b ~ t) => + Rewrapped (PartialSemigroupOpT f' a' b') t + +instance Wrapped (PartialSemigroupOpT f a b) where + type Unwrapped (PartialSemigroupOpT f a b) = a -> a -> f (Maybe b) + _Wrapped' = iso (\(PartialSemigroupOpT x) -> x) PartialSemigroupOpT + +-- | >>> run (fmap (*10) addPos) 3 4 +-- Just 70 +-- >>> run (fmap (*10) addPos) (-1) 4 +-- Nothing +instance (Functor f) => Functor (PartialSemigroupOpT f a) where + fmap g (PartialSemigroupOpT k) = + PartialSemigroupOpT (\a1 a2 -> fmap (fmap g) (k a1 a2)) + +-- | >>> run (liftF2 (+) addPos total) 3 4 +-- Just 14 +-- >>> run (liftF2 (+) addPos addPos) (-1) 4 +-- Nothing +instance (Apply f) => Apply (PartialSemigroupOpT f a) where + liftF2 g (PartialSemigroupOpT kx) (PartialSemigroupOpT ky) = + PartialSemigroupOpT (\a1 a2 -> liftF2 (liftA2 g) (kx a1 a2) (ky a1 a2)) + +-- | >>> run (pure 42 :: PartialSemigroupOp' Int) 0 0 +-- Just 42 +-- >>> run (liftA2 (+) addPos total) 3 4 +-- Just 14 +instance (Applicative f) => Applicative (PartialSemigroupOpT f a) where + pure b = PartialSemigroupOpT (\_ _ -> pure (Just b)) + liftA2 g (PartialSemigroupOpT kx) (PartialSemigroupOpT ky) = + PartialSemigroupOpT (\a1 a2 -> liftA2 (liftA2 g) (kx a1 a2) (ky a1 a2)) + +-- | >>> run (addPos >>- \n -> pure (n * 10)) 3 4 +-- Just 70 +instance (Monad f, Apply f) => Bind (PartialSemigroupOpT f a) where + PartialSemigroupOpT ka >>- g = + PartialSemigroupOpT + ( \a1 a2 -> + ka a1 a2 >>= \case + Nothing -> pure Nothing + Just x -> let PartialSemigroupOpT kb = g x in kb a1 a2 + ) + +-- | >>> run (addPos >>= \n -> pure (n * 10)) 3 4 +-- Just 70 +-- >>> run (addPos >>= \_ -> mempty :: PartialSemigroupOp' Int) 3 4 +-- Nothing +instance (Monad f) => Monad (PartialSemigroupOpT f a) where + PartialSemigroupOpT ka >>= g = + PartialSemigroupOpT + ( \a1 a2 -> + ka a1 a2 >>= \case + Nothing -> pure Nothing + Just x -> let PartialSemigroupOpT kb = g x in kb a1 a2 + ) + +-- | >>> run (lmap negate addPos) (-3) (-4) +-- Just 7 +-- >>> run (rmap (*10) addPos) 3 4 +-- Just 70 +-- >>> run (dimap negate (*10) addPos) (-3) (-4) +-- Just 70 +instance (Functor f) => Profunctor (PartialSemigroupOpT f) where + dimap f g (PartialSemigroupOpT k) = + PartialSemigroupOpT (\a1 a2 -> fmap (fmap g) (k (f a1) (f a2))) + lmap f (PartialSemigroupOpT k) = + PartialSemigroupOpT (\a1 a2 -> k (f a1) (f a2)) + rmap g (PartialSemigroupOpT k) = + PartialSemigroupOpT (\a1 a2 -> fmap (fmap g) (k a1 a2)) + +-- | Pairs the first input's extra component with the result. +-- +-- >>> run (first' addPos) (3, "x") (4, "y") +-- Just (7,"x") +instance (Functor f) => Strong (PartialSemigroupOpT f) where + first' (PartialSemigroupOpT k) = + PartialSemigroupOpT (\(a1, c) (a2, _) -> fmap (fmap (,c)) (k a1 a2)) + second' (PartialSemigroupOpT k) = + PartialSemigroupOpT (\(c, a1) (_, a2) -> fmap (fmap (c,)) (k a1 a2)) + +-- | Routes matching 'Either' branches; passes through the other. +-- +-- >>> run (left' addPos) (Left 3 :: Either Int String) (Left 4) +-- Just (Left 7) +-- >>> run (left' addPos) (Right "x" :: Either Int String) (Left 4) +-- Just (Right "x") +-- >>> run (left' addPos) (Left 3 :: Either Int String) (Right "x") +-- Just (Right "x") +instance (Applicative f) => Choice (PartialSemigroupOpT f) where + left' (PartialSemigroupOpT k) = + PartialSemigroupOpT + ( \e1 e2 -> case (e1, e2) of + (Left a1, Left a2) -> fmap (fmap Left) (k a1 a2) + (Right c, _) -> pure (Just (Right c)) + (Left _, Right c) -> pure (Just (Right c)) + ) + right' (PartialSemigroupOpT k) = + PartialSemigroupOpT + ( \e1 e2 -> case (e1, e2) of + (Right a1, Right a2) -> fmap (fmap Right) (k a1 a2) + (Left c, _) -> pure (Just (Left c)) + (Right _, Left c) -> pure (Just (Left c)) + ) + +-- | Compose by feeding the result of the second into both arguments of the first. +-- +-- >>> let showPos = PartialSemigroupOpT (\a _ -> Identity (if a > 0 then Just (show a) else Nothing)) :: PartialSemigroupOpT Identity Int String +-- >>> run (o showPos total) 3 4 +-- Just "7" +instance (Monad f) => Semigroupoid (PartialSemigroupOpT f) where + o (PartialSemigroupOpT g) (PartialSemigroupOpT h) = + PartialSemigroupOpT + ( \a1 a2 -> + h a1 a2 >>= \case + Nothing -> pure Nothing + Just b -> g b b + ) + +-- | >>> run (fail "oops" :: PartialSemigroupOp' Int) 3 4 +-- Nothing +instance (Monad f) => MonadFail (PartialSemigroupOpT f a) where + fail _ = PartialSemigroupOpT (\_ _ -> pure Nothing) + +-- | First-success: try the left operand, fall back to the right. +-- +-- >>> run (addPos <> total) 3 4 +-- Just 7 +-- >>> run (addPos <> total) (-1) 4 +-- Just 3 +instance (Monad f) => Semigroup (PartialSemigroupOpT f a b) where + PartialSemigroupOpT k1 <> PartialSemigroupOpT k2 = + PartialSemigroupOpT + ( \a1 a2 -> + k1 a1 a2 >>= \case + Just b -> pure (Just b) + Nothing -> k2 a1 a2 + ) + +-- | The always-undefined partial semigroup. +-- +-- >>> run (mempty :: PartialSemigroupOp' Int) 3 4 +-- Nothing +-- >>> run (mempty <> addPos) 3 4 +-- Just 7 +instance (Monad f) => Monoid (PartialSemigroupOpT f a b) where + mempty = PartialSemigroupOpT (\_ _ -> pure Nothing) + +-- | >>> run (addPos total) (-1) 4 +-- Just 3 +instance (Monad f) => Alt (PartialSemigroupOpT f a) where + () = (<>) + +-- | >>> run (zero :: PartialSemigroupOp' Int) 3 4 +-- Nothing +-- >>> run (zero addPos :: PartialSemigroupOp' Int) 3 4 +-- Just 7 +instance (Monad f) => Plus (PartialSemigroupOpT f a) where + zero = PartialSemigroupOpT (\_ _ -> pure Nothing) + +-- | >>> run (empty <|> addPos :: PartialSemigroupOp' Int) 3 4 +-- Just 7 +instance (Monad f) => Alternative (PartialSemigroupOpT f a) where + empty = mempty + (<|>) = (<>) + +instance (Monad f) => MonadPlus (PartialSemigroupOpT f a) + +-- | >>> run (select (pure (Left 5)) (pure (+10)) :: PartialSemigroupOp' Int) 0 0 +-- Just 15 +-- >>> run (select (pure (Right 42)) (pure (+10)) :: PartialSemigroupOp' Int) 0 0 +-- Just 42 +instance (Monad f) => Selective (PartialSemigroupOpT f a) where + select = selectM + +-- | >>> run (mapMaybe (\n -> if n > 5 then Just (n * 10) else Nothing) total) 3 4 +-- Just 70 +-- >>> run (mapMaybe (\n -> if n > 10 then Just n else Nothing) total) 3 4 +-- Nothing +instance (Functor f) => Filterable (PartialSemigroupOpT f a) where + mapMaybe g (PartialSemigroupOpT k) = + PartialSemigroupOpT (\a1 a2 -> fmap (>>= g) (k a1 a2)) + +-- | @'duplicated' w = w '<$' w@: preserves the 'Nothing'/'Just' structure, +-- replacing each value with the original partial semigroup. +-- +-- >>> run (extended (\p -> runPartialSemigroupOp p 10 20) total) 3 4 +-- Just (Just 30) +instance (Functor f) => Extend (PartialSemigroupOpT f a) where + duplicated w = w <$ w + +-- | Delegates to the underlying 'MonadReader'. +-- +-- >>> import Control.Monad.Reader (Reader, runReader) +-- >>> runReader (runPartialSemigroupOpT (ask :: PartialSemigroupOpT (Reader Int) () Int) () ()) 42 +-- Just 42 +instance (MonadReader r f) => MonadReader r (PartialSemigroupOpT f a) where + ask = PartialSemigroupOpT (\_ _ -> Just <$> ask) + local g (PartialSemigroupOpT k) = PartialSemigroupOpT (\a1 a2 -> local g (k a1 a2)) + +-- | Delegates to the underlying 'MonadError'. +-- +-- >>> import Control.Monad.Except (Except, runExcept) +-- >>> runExcept (runPartialSemigroupOpT (throwError "oops" :: PartialSemigroupOpT (Except String) () Int) () ()) +-- Left "oops" +instance (MonadError e f) => MonadError e (PartialSemigroupOpT f a) where + throwError e = PartialSemigroupOpT (\_ _ -> throwError e) + catchError (PartialSemigroupOpT k) h = + PartialSemigroupOpT + ( \a1 a2 -> + catchError (k a1 a2) (\e -> let PartialSemigroupOpT k' = h e in k' a1 a2) + ) + +-- | Delegates to the underlying 'MonadState'. +-- +-- >>> import Control.Monad.State (State, runState) +-- >>> runState (runPartialSemigroupOpT (get :: PartialSemigroupOpT (State Int) () Int) () ()) 5 +-- (Just 5,5) +instance (MonadState s f) => MonadState s (PartialSemigroupOpT f a) where + get = PartialSemigroupOpT (\_ _ -> Just <$> get) + put s = PartialSemigroupOpT (\_ _ -> Just <$> put s) + +-- | Delegates to the underlying 'MonadWriter'. +-- +-- >>> import Control.Monad.Writer (Writer, runWriter) +-- >>> runWriter (runPartialSemigroupOpT (tell "hi" :: PartialSemigroupOpT (Writer String) () ()) () ()) +-- (Just (),"hi") +instance (MonadWriter w f) => MonadWriter w (PartialSemigroupOpT f a) where + tell w = PartialSemigroupOpT (\_ _ -> Just <$> tell w) + listen (PartialSemigroupOpT k) = + PartialSemigroupOpT + ( \a1 a2 -> + fmap (\(mb, w') -> fmap (,w') mb) (listen (k a1 a2)) + ) + pass (PartialSemigroupOpT k) = + PartialSemigroupOpT + ( \a1 a2 -> + pass + ( fmap + ( \case + Nothing -> (Nothing, id) + Just (b, g) -> (Just b, g) + ) + (k a1 a2) + ) + ) + +instance (MonadRWS r w s f) => MonadRWS r w s (PartialSemigroupOpT f a) + +-- | Lifts an 'IO' action, always producing 'Just'. +instance (MonadIO f) => MonadIO (PartialSemigroupOpT f a) where + liftIO io = PartialSemigroupOpT (\_ _ -> Just <$> liftIO io) + +-- | Delegates to the underlying 'MonadCont'. +instance (MonadCont f) => MonadCont (PartialSemigroupOpT f a) where + callCC g = + PartialSemigroupOpT + ( \a1 a2 -> + callCC + ( \c -> + let PartialSemigroupOpT k = g (\b -> PartialSemigroupOpT (\_ _ -> c (Just b))) + in k a1 a2 + ) + ) + +{- HLINT ignore "Monoid law, left identity" -} +{- HLINT ignore "Monoid law, right identity" -} +{- HLINT ignore "Functor law" -} +{- HLINT ignore "Use >=>" -} + +---- +-- Law-checking functions +---- + +-- | Associativity of the partial semigroup operation. +-- +-- Left- and right-association of three values must agree: +-- both 'Nothing' or both the same 'Just'. +-- +-- >>> runIdentity $ psemigroupLawAssociative total 1 2 3 +-- True +-- >>> runIdentity $ psemigroupLawAssociative addPos 1 2 3 +-- True +-- >>> runIdentity $ psemigroupLawAssociative addPos (-1) 2 3 +-- True +psemigroupLawAssociative :: (Monad f, Eq a) => PartialSemigroupOpT' f a -> a -> a -> a -> f Bool +psemigroupLawAssociative (PartialSemigroupOpT op) x y z = do + mxy <- op x y + lhs <- case mxy of + Nothing -> pure Nothing + Just xy -> op xy z + myz <- op y z + rhs <- case myz of + Nothing -> pure Nothing + Just yz -> op x yz + pure (lhs == rhs) + +-- | 'Semigroup' associativity: @(p '<>' q) '<>' r == p '<>' (q '<>' r)@ +-- +-- >>> psemigroupLawSemigroupAssociative addPos total mempty 3 4 +-- True +-- >>> psemigroupLawSemigroupAssociative addPos total mempty (-1) 4 +-- True +psemigroupLawSemigroupAssociative :: (Monad f, Eq (f (Maybe b))) => PartialSemigroupOpT f a b -> PartialSemigroupOpT f a b -> PartialSemigroupOpT f a b -> a -> a -> Bool +psemigroupLawSemigroupAssociative p q r a1 a2 = + runPartialSemigroupOpT ((p <> q) <> r) a1 a2 == runPartialSemigroupOpT (p <> (q <> r)) a1 a2 + +-- | 'Monoid' left identity: @'mempty' '<>' p == p@ +-- +-- >>> psemigroupLawMonoidLeftIdentity addPos 3 4 +-- True +-- >>> psemigroupLawMonoidLeftIdentity addPos (-1) 4 +-- True +psemigroupLawMonoidLeftIdentity :: (Monad f, Eq (f (Maybe b))) => PartialSemigroupOpT f a b -> a -> a -> Bool +psemigroupLawMonoidLeftIdentity p a1 a2 = + runPartialSemigroupOpT (mempty <> p) a1 a2 == runPartialSemigroupOpT p a1 a2 + +-- | 'Monoid' right identity: @p '<>' 'mempty' == p@ +-- +-- >>> psemigroupLawMonoidRightIdentity addPos 3 4 +-- True +-- >>> psemigroupLawMonoidRightIdentity addPos (-1) 4 +-- True +psemigroupLawMonoidRightIdentity :: (Monad f, Eq (f (Maybe b))) => PartialSemigroupOpT f a b -> a -> a -> Bool +psemigroupLawMonoidRightIdentity p a1 a2 = + runPartialSemigroupOpT (p <> mempty) a1 a2 == runPartialSemigroupOpT p a1 a2 + +-- | 'Functor' identity: @'fmap' 'id' == 'id'@ +-- +-- >>> psemigroupLawFunctorIdentity addPos 3 4 +-- True +-- >>> psemigroupLawFunctorIdentity addPos (-1) 4 +-- True +psemigroupLawFunctorIdentity :: (Functor f, Eq (f (Maybe b))) => PartialSemigroupOpT f a b -> a -> a -> Bool +psemigroupLawFunctorIdentity p a1 a2 = + runPartialSemigroupOpT (fmap id p) a1 a2 == runPartialSemigroupOpT p a1 a2 + +-- | 'Functor' composition: @'fmap' (g '.' h) == 'fmap' g '.' 'fmap' h@ +-- +-- >>> psemigroupLawFunctorComposition (*10) (+1) addPos 3 4 +-- True +psemigroupLawFunctorComposition :: (Functor f, Eq (f (Maybe d))) => (c -> d) -> (b -> c) -> PartialSemigroupOpT f a b -> a -> a -> Bool +psemigroupLawFunctorComposition g h p a1 a2 = + runPartialSemigroupOpT (fmap (g . h) p) a1 a2 == runPartialSemigroupOpT (fmap g (fmap h p)) a1 a2 + +-- | 'Profunctor' identity: @'dimap' 'id' 'id' == 'id'@ +-- +-- >>> psemigroupLawProfunctorIdentity addPos 3 4 +-- True +psemigroupLawProfunctorIdentity :: (Functor f, Eq (f (Maybe b))) => PartialSemigroupOpT f a b -> a -> a -> Bool +psemigroupLawProfunctorIdentity p a1 a2 = + runPartialSemigroupOpT (dimap id id p) a1 a2 == runPartialSemigroupOpT p a1 a2 + +-- | 'Filterable' identity: @'mapMaybe' 'Just' == 'id'@ +-- +-- >>> lawFilterableIdentity addPos 3 4 +-- True +-- >>> lawFilterableIdentity addPos (-1) 4 +-- True +lawFilterableIdentity :: (Functor f, Eq (f (Maybe b))) => PartialSemigroupOpT f a b -> a -> a -> Bool +lawFilterableIdentity p a1 a2 = + runPartialSemigroupOpT (mapMaybe Just p) a1 a2 == runPartialSemigroupOpT p a1 a2 + +-- | 'Filterable' composition: @'mapMaybe' g '.' 'mapMaybe' h == 'mapMaybe' (h 'Control.Monad.>=>' g)@ +-- +-- >>> lawFilterableComposition (\n -> if n > 50 then Just n else Nothing) (\n -> if n > 5 then Just (n * 10) else Nothing) total 3 4 +-- True +lawFilterableComposition :: (Functor f, Eq (f (Maybe c))) => (b -> Maybe c) -> (a -> Maybe b) -> PartialSemigroupOpT f x a -> x -> x -> Bool +lawFilterableComposition g h p x1 x2 = + runPartialSemigroupOpT (mapMaybe g (mapMaybe h p)) x1 x2 == runPartialSemigroupOpT (mapMaybe (h >=> g) p) x1 x2 + +-- | 'Extend' associativity: @'extended' f '.' 'extended' g == 'extended' (f '.' 'extended' g)@ +-- +-- >>> psemigroupLawExtendAssociative (const True) (const 'x') total 3 4 +-- True +-- >>> psemigroupLawExtendAssociative (const True) (const 'x') addPos (-1) 4 +-- True +psemigroupLawExtendAssociative :: (Functor f, Eq (f (Maybe c))) => (PartialSemigroupOpT f a b -> c) -> (PartialSemigroupOpT f a d -> b) -> PartialSemigroupOpT f a d -> a -> a -> Bool +psemigroupLawExtendAssociative f g p a1 a2 = + runPartialSemigroupOpT (extended f (extended g p)) a1 a2 == runPartialSemigroupOpT (extended (f . extended g) p) a1 a2 + +-- | 'Semigroupoid' associativity: @'o' f ('o' g h) == 'o' ('o' f g) h@ +-- +-- >>> psemigroupLawSemigroupoidAssociative total total total 3 4 +-- True +psemigroupLawSemigroupoidAssociative :: (Monad f, Eq (f (Maybe d))) => PartialSemigroupOpT f c d -> PartialSemigroupOpT f b c -> PartialSemigroupOpT f a b -> a -> a -> Bool +psemigroupLawSemigroupoidAssociative f g h x1 x2 = + runPartialSemigroupOpT (o f (o g h)) x1 x2 == runPartialSemigroupOpT (o (o f g) h) x1 x2 + +-- | Classy lens for types that contain a 'PartialSemigroupOpT'. +-- +-- >>> run (view partialSemigroupOpT addPos) 3 4 +-- Just 7 +class HasPartialSemigroupOpT c f a b | c -> f a b where + partialSemigroupOpT :: Lens' c (PartialSemigroupOpT f a b) + +instance HasPartialSemigroupOpT (PartialSemigroupOpT f a b) f a b where + partialSemigroupOpT = id + +-- | Classy prism for types that can be constructed from a 'PartialSemigroupOpT'. +-- +-- >>> run (review _PartialSemigroupOpT addPos) 3 4 +-- Just 7 +class AsPartialSemigroupOpT c f a b | c -> f a b where + _PartialSemigroupOpT :: Prism' c (PartialSemigroupOpT f a b) + +instance AsPartialSemigroupOpT (PartialSemigroupOpT f a b) f a b where + _PartialSemigroupOpT = id + +---- +-- PartialSemigroupOp' values via semigroup +---- + +-- | >>> run psemigroupUnit () () +-- Just () +psemigroupUnit :: PartialSemigroupOp' () +psemigroupUnit = psemigroupSemigroup + +-- | Vacuously associative — 'Void' has no inhabitants. +psemigroupVoid :: PartialSemigroupOp' Void +psemigroupVoid = psemigroupSemigroup + +-- | Lexicographic composition of orderings. +-- +-- >>> run psemigroupOrdering LT GT +-- Just LT +-- >>> run psemigroupOrdering EQ GT +-- Just GT +-- >>> run psemigroupOrdering EQ EQ +-- Just EQ +psemigroupOrdering :: PartialSemigroupOp' Ordering +psemigroupOrdering = psemigroupSemigroup + +-- | List concatenation. +-- +-- >>> run psemigroupList [1,2] [3,4 :: Int] +-- Just [1,2,3,4] +psemigroupList :: PartialSemigroupOp' [a] +psemigroupList = psemigroupSemigroup + +-- | Non-empty list concatenation. +-- +-- >>> run psemigroupNonEmpty (1 :| [2]) (3 :| [4 :: Int]) +-- Just (1 :| [2,3,4]) +psemigroupNonEmpty :: PartialSemigroupOp' (NonEmpty a) +psemigroupNonEmpty = psemigroupSemigroup + +-- | First 'Right' wins; 'Left' is absorbed. +-- +-- >>> run psemigroupEither (Left "a") (Right 1 :: Either String Int) +-- Just (Right 1) +-- >>> run psemigroupEither (Right 1) (Left "b" :: Either String Int) +-- Just (Right 1) +-- >>> run psemigroupEither (Left "a") (Left "b" :: Either String Int) +-- Just (Left "b") +psemigroupEither :: PartialSemigroupOp' (Either a b) +psemigroupEither = psemigroupSemigroup + +-- | >>> run psemigroupProxy Proxy (Proxy :: Proxy Int) +-- Just Proxy +psemigroupProxy :: PartialSemigroupOp' (Proxy a) +psemigroupProxy = psemigroupSemigroup + +-- | 'Nothing' is identity; 'Just' values are combined. +-- +-- >>> run psemigroupMaybe (Just [1]) (Just [2 :: Int]) +-- Just (Just [1,2]) +-- >>> run psemigroupMaybe Nothing (Just [2 :: Int]) +-- Just (Just [2]) +-- >>> run psemigroupMaybe (Just [1 :: Int]) Nothing +-- Just (Just [1]) +psemigroupMaybe :: (Semigroup a) => PartialSemigroupOp' (Maybe a) +psemigroupMaybe = psemigroupSemigroup + +-- | Reverses the inner semigroup. +-- +-- >>> run psemigroupDual (Dual [1]) (Dual [2 :: Int]) +-- Just (Dual {getDual = [2,1]}) +psemigroupDual :: (Semigroup a) => PartialSemigroupOp' (Dual a) +psemigroupDual = psemigroupSemigroup + +-- | Delegates through 'Down'. +-- +-- >>> run psemigroupDown (Down [1]) (Down [2 :: Int]) +-- Just (Down [1,2]) +psemigroupDown :: (Semigroup a) => PartialSemigroupOp' (Down a) +psemigroupDown = psemigroupSemigroup + +-- | Delegates through 'Identity'. +-- +-- >>> run psemigroupIdentity (Identity [1]) (Identity [2 :: Int]) +-- Just (Identity [1,2]) +psemigroupIdentity :: (Semigroup a) => PartialSemigroupOp' (Identity a) +psemigroupIdentity = psemigroupSemigroup + +-- | Pairwise combination. +-- +-- >>> run psemigroupTuple ([1 :: Int], [10]) ([2], [20 :: Int]) +-- Just ([1,2],[10,20]) +psemigroupTuple :: (Semigroup a, Semigroup b) => PartialSemigroupOp' (a, b) +psemigroupTuple = psemigroupSemigroup + +-- | Uses the underlying 'Monoid' operation. +-- +-- >>> run psemigroupWrappedMonoid (WrapMonoid [1]) (WrapMonoid [2 :: Int]) +-- Just (WrapMonoid {unwrapMonoid = [1,2]}) +psemigroupWrappedMonoid :: (Monoid a) => PartialSemigroupOp' (WrappedMonoid a) +psemigroupWrappedMonoid = psemigroupSemigroup + +-- | Pointwise combination. +-- +-- >>> fmap ($ "x") (run psemigroupFunction (++ "a") ((++ "b") :: String -> String)) +-- Just "xaxb" +psemigroupFunction :: (Semigroup b) => PartialSemigroupOp' (a -> b) +psemigroupFunction = psemigroupSemigroup + +-- | First-success on 'Maybe' via 'Alt'. +-- +-- >>> run psemigroupAlt (Just 1) (Just 2 :: Maybe Int) +-- Just (Just 1) +-- >>> run psemigroupAlt Nothing (Just 2 :: Maybe Int) +-- Just (Just 2) +psemigroupAlt :: PartialSemigroupOp' (Maybe a) +psemigroupAlt = total () + +-- | First-success on 'Maybe' via 'Alternative'. +-- +-- >>> run psemigroupAlternative (Just 1) (Just 2 :: Maybe Int) +-- Just (Just 1) +-- >>> run psemigroupAlternative Nothing (Just 2 :: Maybe Int) +-- Just (Just 2) +psemigroupAlternative :: PartialSemigroupOp' (Maybe a) +psemigroupAlternative = total (<|>) + +---- +-- PartialSemigroupOp' values via total +---- + +-- | Takes the first value ('First'). +-- +-- >>> run psemigroupFirst 'a' 'b' +-- Just 'a' +psemigroupFirst :: PartialSemigroupOp' a +psemigroupFirst = total const + +-- | Takes the last value ('Last'). +-- +-- >>> run psemigroupLast 'a' 'b' +-- Just 'b' +psemigroupLast :: PartialSemigroupOp' a +psemigroupLast = total (const id) + +-- | Takes the minimum ('Min'). +-- +-- >>> run psemigroupMin (3 :: Int) 4 +-- Just 3 +psemigroupMin :: (Ord a) => PartialSemigroupOp' a +psemigroupMin = total min + +-- | Takes the maximum ('Max'). +-- +-- >>> run psemigroupMax (3 :: Int) 4 +-- Just 4 +psemigroupMax :: (Ord a) => PartialSemigroupOp' a +psemigroupMax = total max + +-- | Logical conjunction ('All'). +-- +-- >>> run psemigroupAll True True +-- Just True +-- >>> run psemigroupAll True False +-- Just False +psemigroupAll :: PartialSemigroupOp' Bool +psemigroupAll = total (&&) + +-- | Logical disjunction ('Any'). +-- +-- >>> run psemigroupAny False False +-- Just False +-- >>> run psemigroupAny False True +-- Just True +psemigroupAny :: PartialSemigroupOp' Bool +psemigroupAny = total (||) + +-- | Addition ('Sum'). +-- +-- >>> run psemigroupAddition (3 :: Int) 4 +-- Just 7 +psemigroupAddition :: (Num a) => PartialSemigroupOp' a +psemigroupAddition = total (+) + +-- | Multiplication ('Product'). +-- +-- >>> run psemigroupMultiplication (3 :: Int) 4 +-- Just 12 +psemigroupMultiplication :: (Num a) => PartialSemigroupOp' a +psemigroupMultiplication = total (*) + +-- | Function composition ('Endo'). +-- +-- >>> fmap ($ 3) (run psemigroupEndo (+1) ((*10) :: Int -> Int)) +-- Just 31 +psemigroupEndo :: PartialSemigroupOp' (a -> a) +psemigroupEndo = total (.) + +-- | Bitwise AND ('Data.Bits.And'). +-- +-- >>> run psemigroupAnd (0xFF :: Word8) 0x0F +-- Just 15 +psemigroupAnd :: (Bits a) => PartialSemigroupOp' a +psemigroupAnd = total (.&.) + +-- | Bitwise inclusive OR ('Data.Bits.Ior'). +-- +-- >>> run psemigroupIor (0xF0 :: Word8) 0x0F +-- Just 255 +psemigroupIor :: (Bits a) => PartialSemigroupOp' a +psemigroupIor = total (.|.) + +-- | Bitwise exclusive OR ('Data.Bits.Xor'). +-- +-- >>> run psemigroupXor (0xFF :: Word8) 0x0F +-- Just 240 +psemigroupXor :: (Bits a) => PartialSemigroupOp' a +psemigroupXor = total xor + +-- | Bitwise equivalence / XNOR ('Data.Bits.Iff'). +-- +-- >>> run psemigroupIff (0xFF :: Word8) 0x0F +-- Just 15 +psemigroupIff :: (FiniteBits a) => PartialSemigroupOp' a +psemigroupIff = total (\a b -> complement (xor a b)) + +---- +-- Collection values +---- + +-- | Set union. +-- +-- >>> run psemigroupSetUnion (Set.fromList [1,2]) (Set.fromList [2,3 :: Int]) +-- Just (fromList [1,2,3]) +psemigroupSetUnion :: (Ord a) => PartialSemigroupOp' (Set a) +psemigroupSetUnion = total Set.union + +-- | Set intersection. +-- +-- >>> run psemigroupSetIntersection (Set.fromList [1,2,3]) (Set.fromList [2,3,4 :: Int]) +-- Just (fromList [2,3]) +psemigroupSetIntersection :: (Ord a) => PartialSemigroupOp' (Set a) +psemigroupSetIntersection = total Set.intersection + +-- | IntSet union. +-- +-- >>> run psemigroupIntSetUnion (IntSet.fromList [1,2]) (IntSet.fromList [2,3]) +-- Just (fromList [1,2,3]) +psemigroupIntSetUnion :: PartialSemigroupOp' IntSet +psemigroupIntSetUnion = total IntSet.union + +-- | IntSet intersection. +-- +-- >>> run psemigroupIntSetIntersection (IntSet.fromList [1,2,3]) (IntSet.fromList [2,3,4]) +-- Just (fromList [2,3]) +psemigroupIntSetIntersection :: PartialSemigroupOp' IntSet +psemigroupIntSetIntersection = total IntSet.intersection + +-- | HashSet union. +-- +-- >>> fmap sort (fmap HashSet.toList (run psemigroupHashSetUnion (HashSet.fromList [1,2]) (HashSet.fromList [2,3 :: Int]))) +-- Just [1,2,3] +psemigroupHashSetUnion :: (Eq a, Hashable a) => PartialSemigroupOp' (HashSet a) +psemigroupHashSetUnion = total HashSet.union + +-- | HashSet intersection. +-- +-- >>> fmap sort (fmap HashSet.toList (run psemigroupHashSetIntersection (HashSet.fromList [1,2,3]) (HashSet.fromList [2,3,4 :: Int]))) +-- Just [2,3] +psemigroupHashSetIntersection :: (Eq a, Hashable a) => PartialSemigroupOp' (HashSet a) +psemigroupHashSetIntersection = total HashSet.intersection + +-- | Map union (left-biased on overlapping keys). +-- +-- >>> run psemigroupMapUnion (Map.fromList [(1 :: Int,'a'),(2,'b')]) (Map.fromList [(2,'x'),(3,'c')]) +-- Just (fromList [(1,'a'),(2,'b'),(3,'c')]) +psemigroupMapUnion :: (Ord k) => PartialSemigroupOp' (Map k v) +psemigroupMapUnion = total Map.union + +-- | Map intersection (left-biased on overlapping keys). +-- +-- >>> run psemigroupMapIntersection (Map.fromList [(1 :: Int,'a'),(2,'b'),(3,'c')]) (Map.fromList [(2,'x'),(3,'y'),(4,'z')]) +-- Just (fromList [(2,'b'),(3,'c')]) +psemigroupMapIntersection :: (Ord k) => PartialSemigroupOp' (Map k v) +psemigroupMapIntersection = total Map.intersection + +-- | IntMap union (left-biased on overlapping keys). +-- +-- >>> run psemigroupIntMapUnion (IntMap.fromList [(1,'a'),(2,'b')]) (IntMap.fromList [(2,'x'),(3,'c')]) +-- Just (fromList [(1,'a'),(2,'b'),(3,'c')]) +psemigroupIntMapUnion :: PartialSemigroupOp' (IntMap v) +psemigroupIntMapUnion = total IntMap.union + +-- | IntMap intersection (left-biased on overlapping keys). +-- +-- >>> run psemigroupIntMapIntersection (IntMap.fromList [(1,'a'),(2,'b'),(3,'c')]) (IntMap.fromList [(2,'x'),(3,'y'),(4,'z')]) +-- Just (fromList [(2,'b'),(3,'c')]) +psemigroupIntMapIntersection :: PartialSemigroupOp' (IntMap v) +psemigroupIntMapIntersection = total IntMap.intersection + +-- | HashMap union (left-biased on overlapping keys). +-- +-- >>> fmap sort (fmap HashMap.toList (run psemigroupHashMapUnion (HashMap.fromList [(1 :: Int,'a'),(2,'b')]) (HashMap.fromList [(2,'x'),(3,'c')]))) +-- Just [(1,'a'),(2,'b'),(3,'c')] +psemigroupHashMapUnion :: (Eq k, Hashable k) => PartialSemigroupOp' (HashMap k v) +psemigroupHashMapUnion = total HashMap.union + +-- | HashMap intersection (left-biased on overlapping keys). +-- +-- >>> fmap sort (fmap HashMap.toList (run psemigroupHashMapIntersection (HashMap.fromList [(1 :: Int,'a'),(2,'b'),(3,'c')]) (HashMap.fromList [(2,'x'),(3,'y'),(4,'z')]))) +-- Just [(2,'b'),(3,'c')] +psemigroupHashMapIntersection :: (Eq k, Hashable k) => PartialSemigroupOp' (HashMap k v) +psemigroupHashMapIntersection = total HashMap.intersection diff --git a/src/Data/Associative/SemigroupOp.hs b/src/Data/Associative/SemigroupOp.hs new file mode 100644 --- /dev/null +++ b/src/Data/Associative/SemigroupOp.hs @@ -0,0 +1,865 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wall -Werror #-} + +-- | +-- A semigroup operation is an associative binary operation that is defined +-- for all pairs of inputs. +module Data.Associative.SemigroupOp + ( -- * Types + SemigroupOpT (..), + SemigroupOp, + SemigroupOpT', + SemigroupOp', + + -- * Isomorphisms + iSemigroupOpT, + iSemigroupOp, + + -- * Running + runSemigroupOpT, + runSemigroupOp, + + -- * Smart constructors + op, + semigroupSemigroup, + + -- * Laws + semigroupLawAssociative, + semigroupLawSemigroupAssociative, + semigroupLawMonoidLeftIdentity, + semigroupLawMonoidRightIdentity, + semigroupLawFunctorIdentity, + semigroupLawFunctorComposition, + semigroupLawProfunctorIdentity, + semigroupLawExtendAssociative, + semigroupLawSemigroupoidAssociative, + + -- * Classy optics + HasSemigroupOpT (..), + AsSemigroupOpT (..), + + -- * Values (via semigroup) + semigroupUnit, + semigroupVoid, + semigroupOrdering, + semigroupList, + semigroupNonEmpty, + semigroupEither, + semigroupProxy, + semigroupMaybe, + semigroupDual, + semigroupDown, + semigroupIdentity, + semigroupTuple, + semigroupWrappedMonoid, + semigroupFunction, + semigroupAlt, + semigroupAlternative, + + -- * Values (via op) + semigroupFirst, + semigroupLast, + semigroupMin, + semigroupMax, + semigroupAll, + semigroupAny, + semigroupAddition, + semigroupMultiplication, + semigroupEndo, + semigroupAnd, + semigroupIor, + semigroupXor, + semigroupIff, + + -- * Collection values + semigroupSetUnion, + semigroupSetIntersection, + semigroupIntSetUnion, + semigroupIntSetIntersection, + semigroupHashSetUnion, + semigroupHashSetIntersection, + semigroupMapUnion, + semigroupMapIntersection, + semigroupIntMapUnion, + semigroupIntMapIntersection, + semigroupHashMapUnion, + semigroupHashMapIntersection, + ) +where + +import Control.Applicative (Alternative (..)) +import Control.Lens + ( Iso, + Lens', + Prism', + Rewrapped, + Wrapped (..), + iso, + review, + view, + _Wrapped, + ) +import Control.Monad.Cont.Class (MonadCont (..)) +import Control.Monad.Error.Class (MonadError (..)) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.RWS.Class (MonadRWS) +import Control.Monad.Reader.Class (MonadReader (..)) +import Control.Monad.State.Class (MonadState (..)) +import Control.Monad.Writer.Class (MonadWriter (..)) +import Control.Selective (Selective (..), selectM) +import Data.Bits (Bits, FiniteBits, complement, xor, (.&.), (.|.)) +import Data.Functor.Alt (Alt (..)) +import Data.Functor.Apply (Apply (..)) +import Data.Functor.Bind (Bind (..)) +import Data.Functor.Extend (Extend (..)) +import Data.Functor.Identity (Identity (..)) +import Data.Functor.Plus (Plus (..)) +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.List.NonEmpty (NonEmpty) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Ord (Down) +import Data.Profunctor (Choice (..), Profunctor (..), Strong (..)) +import Data.Proxy (Proxy) +import Data.Semigroup (Dual, WrappedMonoid) +import Data.Semigroupoid (Semigroupoid (..)) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Void (Void) +import GHC.Generics (Generic, Generic1) + +-- $setup +-- >>> import Control.Lens (view, review) +-- >>> import Data.Functor.Apply (liftF2) +-- >>> import Data.Functor.Bind ((>>-)) +-- >>> import Data.Functor.Extend (extended) +-- >>> import Data.Functor.Identity (Identity(..)) +-- >>> import Data.Profunctor (dimap, lmap, rmap, first', left') +-- >>> import Data.Semigroupoid (o) +-- >>> import Data.List.NonEmpty (NonEmpty(..)) +-- >>> 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 = SemigroupOpT (\a b -> Identity (a + b)) :: SemigroupOp' Int +-- >>> let cat = op (++) :: SemigroupOp' [Int] +-- >>> let run = runSemigroupOp + +-- | A semigroup operation transformer. The wrapped operation must be associative +-- (see 'semigroupLawAssociative'). +-- +-- >>> run add 3 4 +-- 7 +newtype SemigroupOpT f a b = SemigroupOpT (a -> a -> f b) + deriving (Generic, Generic1) + +-- | A semigroup operation using 'Identity' as the base functor. +type SemigroupOp a b = SemigroupOpT Identity a b + +-- | A semigroup operation transformer where input and output types coincide. +type SemigroupOpT' f x = SemigroupOpT f x x + +-- | A semigroup operation where input and output types coincide. +type SemigroupOp' x = SemigroupOp x x + +-- | Iso between 'SemigroupOpT' and its underlying function. +-- +-- >>> view iSemigroupOpT add 3 4 +-- Identity 7 +iSemigroupOpT :: Iso (SemigroupOpT f a b) (SemigroupOpT f' a' b') (a -> a -> f b) (a' -> a' -> f' b') +iSemigroupOpT = _Wrapped +{-# INLINE iSemigroupOpT #-} + +-- | Iso between 'SemigroupOp' and a pure function. +-- +-- >>> view iSemigroupOp add 3 4 +-- 7 +iSemigroupOp :: Iso (SemigroupOp a b) (SemigroupOp a' b') (a -> a -> b) (a' -> a' -> b') +iSemigroupOp = + iso + (\(SemigroupOpT j) a1 a2 -> runIdentity (j a1 a2)) + (\k -> SemigroupOpT (\a1 a2 -> Identity (k a1 a2))) +{-# INLINE iSemigroupOp #-} + +-- | Unwrap a 'SemigroupOpT' to its underlying function. +-- +-- >>> runSemigroupOpT add 3 4 +-- Identity 7 +runSemigroupOpT :: SemigroupOpT f a b -> a -> a -> f b +runSemigroupOpT = view iSemigroupOpT +{-# INLINE runSemigroupOpT #-} + +-- | Run a 'SemigroupOp' (specialised to 'Identity'). +-- +-- >>> runSemigroupOp add 3 4 +-- 7 +runSemigroupOp :: SemigroupOp a b -> a -> a -> b +runSemigroupOp = view iSemigroupOp +{-# INLINE runSemigroupOp #-} + +-- | Lift a pure binary operation into 'SemigroupOp'. +-- +-- >>> run (op (+) :: SemigroupOp' Int) 3 4 +-- 7 +op :: (a -> a -> b) -> SemigroupOp a b +op = review iSemigroupOp +{-# INLINE op #-} + +-- | The 'Semigroup' class operation as a 'SemigroupOp''. +-- +-- >>> run (semigroupSemigroup :: SemigroupOp' [Int]) [1,2] [3,4] +-- [1,2,3,4] +semigroupSemigroup :: (Semigroup a) => SemigroupOp' a +semigroupSemigroup = op (<>) +{-# INLINE semigroupSemigroup #-} + +instance + (SemigroupOpT f a b ~ t) => + Rewrapped (SemigroupOpT f' a' b') t + +instance Wrapped (SemigroupOpT f a b) where + type Unwrapped (SemigroupOpT f a b) = a -> a -> f b + _Wrapped' = iso (\(SemigroupOpT x) -> x) SemigroupOpT + +-- | >>> run (fmap (*10) add) 3 4 +-- 70 +instance (Functor f) => Functor (SemigroupOpT f a) where + fmap g (SemigroupOpT k) = + SemigroupOpT (\a1 a2 -> fmap g (k a1 a2)) + +-- | >>> run (liftF2 (+) add add) 3 4 +-- 14 +instance (Apply f) => Apply (SemigroupOpT f a) where + liftF2 g (SemigroupOpT kx) (SemigroupOpT ky) = + SemigroupOpT (\a1 a2 -> liftF2 g (kx a1 a2) (ky a1 a2)) + +-- | >>> run (pure 42 :: SemigroupOp' Int) 0 0 +-- 42 +-- >>> run (liftA2 (+) add add) 3 4 +-- 14 +instance (Applicative f) => Applicative (SemigroupOpT f a) where + pure b = SemigroupOpT (\_ _ -> pure b) + liftA2 g (SemigroupOpT kx) (SemigroupOpT ky) = + SemigroupOpT (\a1 a2 -> liftA2 g (kx a1 a2) (ky a1 a2)) + +-- | >>> run (add >>- \n -> pure (n * 10)) 3 4 +-- 70 +instance (Bind f) => Bind (SemigroupOpT f a) where + SemigroupOpT ka >>- g = + SemigroupOpT + ( \a1 a2 -> + ka a1 a2 >>- \x -> let SemigroupOpT kb = g x in kb a1 a2 + ) + +-- | >>> run (add >>= \n -> pure (n * 10)) 3 4 +-- 70 +instance (Monad f) => Monad (SemigroupOpT f a) where + SemigroupOpT ka >>= g = + SemigroupOpT + ( \a1 a2 -> + ka a1 a2 >>= \x -> let SemigroupOpT kb = g x in kb a1 a2 + ) + +-- | >>> run (lmap negate add) (-3) (-4) +-- 7 +-- >>> run (rmap (*10) add) 3 4 +-- 70 +-- >>> run (dimap negate (*10) add) (-3) (-4) +-- 70 +instance (Functor f) => Profunctor (SemigroupOpT f) where + dimap f g (SemigroupOpT k) = + SemigroupOpT (\a1 a2 -> fmap g (k (f a1) (f a2))) + lmap f (SemigroupOpT k) = + SemigroupOpT (\a1 a2 -> k (f a1) (f a2)) + rmap g (SemigroupOpT k) = + SemigroupOpT (\a1 a2 -> fmap g (k a1 a2)) + +-- | Pairs the first input's extra component with the result. +-- +-- >>> run (first' add) (3, "x") (4, "y") +-- (7,"x") +instance (Functor f) => Strong (SemigroupOpT f) where + first' (SemigroupOpT k) = + SemigroupOpT (\(a1, c) (a2, _) -> fmap (,c) (k a1 a2)) + second' (SemigroupOpT k) = + SemigroupOpT (\(c, a1) (_, a2) -> fmap (c,) (k a1 a2)) + +-- | Routes matching 'Either' branches; passes through the other. +-- +-- >>> run (left' add) (Left 3 :: Either Int String) (Left 4) +-- Left 7 +-- >>> run (left' add) (Right "x" :: Either Int String) (Left 4) +-- Right "x" +-- >>> run (left' add) (Left 3 :: Either Int String) (Right "x") +-- Right "x" +instance (Applicative f) => Choice (SemigroupOpT f) where + left' (SemigroupOpT k) = + SemigroupOpT + ( \e1 e2 -> case (e1, e2) of + (Left a1, Left a2) -> fmap Left (k a1 a2) + (Right c, _) -> pure (Right c) + (Left _, Right c) -> pure (Right c) + ) + right' (SemigroupOpT k) = + SemigroupOpT + ( \e1 e2 -> case (e1, e2) of + (Right a1, Right a2) -> fmap Right (k a1 a2) + (Left c, _) -> pure (Left c) + (Right _, Left c) -> pure (Left c) + ) + +-- | Compose by feeding the result of the second into both arguments of the first. +-- +-- >>> let showOp = SemigroupOpT (\a _ -> Identity (show a)) :: SemigroupOpT Identity Int String +-- >>> run (o showOp add) 3 4 +-- "7" +instance (Monad f) => Semigroupoid (SemigroupOpT f) where + o (SemigroupOpT g) (SemigroupOpT h) = + SemigroupOpT + ( \a1 a2 -> + h a1 a2 >>= \b -> g b b + ) + +-- | Combines results pointwise via the inner 'Semigroup'. +-- +-- >>> run (cat <> cat) [1] [2 :: Int] +-- [1,2,1,2] +instance (Applicative f, Semigroup b) => Semigroup (SemigroupOpT f a b) where + SemigroupOpT k1 <> SemigroupOpT k2 = + SemigroupOpT + ( \a1 a2 -> + liftA2 (<>) (k1 a1 a2) (k2 a1 a2) + ) + +-- | The always-'mempty' semigroup operation. +-- +-- >>> run (mempty :: SemigroupOp' [Int]) [1] [2] +-- [] +-- >>> run (mempty <> cat) [1] [2 :: Int] +-- [1,2] +instance (Applicative f, Monoid b) => Monoid (SemigroupOpT f a b) where + mempty = SemigroupOpT (\_ _ -> pure mempty) + +-- | Delegates to the underlying 'Alt'. +instance (Alt f) => Alt (SemigroupOpT f a) where + SemigroupOpT k1 SemigroupOpT k2 = SemigroupOpT (\a1 a2 -> k1 a1 a2 k2 a1 a2) + +-- | Delegates to the underlying 'Plus'. +-- +-- >>> runSemigroupOpT (zero :: SemigroupOpT Maybe Int Int) 3 4 +-- Nothing +instance (Plus f) => Plus (SemigroupOpT f a) where + zero = SemigroupOpT (\_ _ -> zero) + +-- | >>> run (select (pure (Left 5)) (pure (+10)) :: SemigroupOp' Int) 0 0 +-- 15 +-- >>> run (select (pure (Right 42)) (pure (+10)) :: SemigroupOp' Int) 0 0 +-- 42 +instance (Monad f) => Selective (SemigroupOpT f a) where + select = selectM + +-- | @'duplicated' w = w '<$' w@: preserves the structure, +-- replacing each value with the original semigroup operation. +-- +-- >>> run (extended (\s -> runSemigroupOp s 10 20) add) 3 4 +-- 30 +instance (Functor f) => Extend (SemigroupOpT f a) where + duplicated w = w <$ w + +-- | Delegates to the underlying 'MonadReader'. +-- +-- >>> import Control.Monad.Reader (Reader, runReader) +-- >>> runReader (runSemigroupOpT (ask :: SemigroupOpT (Reader Int) () Int) () ()) 42 +-- 42 +instance (MonadReader r f) => MonadReader r (SemigroupOpT f a) where + ask = SemigroupOpT (\_ _ -> ask) + local g (SemigroupOpT k) = SemigroupOpT (\a1 a2 -> local g (k a1 a2)) + +-- | Delegates to the underlying 'MonadError'. +-- +-- >>> import Control.Monad.Except (Except, runExcept) +-- >>> runExcept (runSemigroupOpT (throwError "oops" :: SemigroupOpT (Except String) () Int) () ()) +-- Left "oops" +instance (MonadError e f) => MonadError e (SemigroupOpT f a) where + throwError e = SemigroupOpT (\_ _ -> throwError e) + catchError (SemigroupOpT k) h = + SemigroupOpT + ( \a1 a2 -> + catchError (k a1 a2) (\e -> let SemigroupOpT k' = h e in k' a1 a2) + ) + +-- | Delegates to the underlying 'MonadState'. +-- +-- >>> import Control.Monad.State (State, runState) +-- >>> runState (runSemigroupOpT (get :: SemigroupOpT (State Int) () Int) () ()) 5 +-- (5,5) +instance (MonadState s f) => MonadState s (SemigroupOpT f a) where + get = SemigroupOpT (\_ _ -> get) + put s = SemigroupOpT (\_ _ -> put s) + +-- | Delegates to the underlying 'MonadWriter'. +-- +-- >>> import Control.Monad.Writer (Writer, runWriter) +-- >>> runWriter (runSemigroupOpT (tell "hi" :: SemigroupOpT (Writer String) () ()) () ()) +-- ((),"hi") +instance (MonadWriter w f) => MonadWriter w (SemigroupOpT f a) where + tell w = SemigroupOpT (\_ _ -> tell w) + listen (SemigroupOpT k) = SemigroupOpT (\a1 a2 -> listen (k a1 a2)) + pass (SemigroupOpT k) = SemigroupOpT (\a1 a2 -> pass (k a1 a2)) + +instance (MonadRWS r w s f) => MonadRWS r w s (SemigroupOpT f a) + +-- | Lifts an 'IO' action. +instance (MonadIO f) => MonadIO (SemigroupOpT f a) where + liftIO io = SemigroupOpT (\_ _ -> liftIO io) + +-- | Delegates to the underlying 'MonadCont'. +instance (MonadCont f) => MonadCont (SemigroupOpT f a) where + callCC g = + SemigroupOpT + ( \a1 a2 -> + callCC + ( \c -> + let SemigroupOpT k = g (\b -> SemigroupOpT (\_ _ -> c b)) + in k a1 a2 + ) + ) + +{- HLINT ignore "Monoid law, left identity" -} +{- HLINT ignore "Monoid law, right identity" -} +{- HLINT ignore "Functor law" -} + +---- +-- Law-checking functions +---- + +-- | Associativity of the semigroup operation. +-- +-- Left- and right-association of three values must agree. +-- +-- >>> runIdentity $ semigroupLawAssociative add 1 2 3 +-- True +semigroupLawAssociative :: (Monad f, Eq a) => SemigroupOpT' f a -> a -> a -> a -> f Bool +semigroupLawAssociative (SemigroupOpT k) x y z = do + xy <- k x y + lhs <- k xy z + yz <- k y z + rhs <- k x yz + pure (lhs == rhs) + +-- | 'Semigroup' associativity: @(p '<>' q) '<>' r == p '<>' (q '<>' r)@ +-- +-- >>> semigroupLawSemigroupAssociative cat cat cat [1] [2 :: Int] +-- True +semigroupLawSemigroupAssociative :: (Applicative f, Semigroup b, Eq (f b)) => SemigroupOpT f a b -> SemigroupOpT f a b -> SemigroupOpT f a b -> a -> a -> Bool +semigroupLawSemigroupAssociative p q r a1 a2 = + runSemigroupOpT ((p <> q) <> r) a1 a2 == runSemigroupOpT (p <> (q <> r)) a1 a2 + +-- | 'Monoid' left identity: @'mempty' '<>' p == p@ +-- +-- >>> semigroupLawMonoidLeftIdentity cat [1] [2 :: Int] +-- True +semigroupLawMonoidLeftIdentity :: (Applicative f, Monoid b, Eq (f b)) => SemigroupOpT f a b -> a -> a -> Bool +semigroupLawMonoidLeftIdentity p a1 a2 = + runSemigroupOpT (mempty <> p) a1 a2 == runSemigroupOpT p a1 a2 + +-- | 'Monoid' right identity: @p '<>' 'mempty' == p@ +-- +-- >>> semigroupLawMonoidRightIdentity cat [1] [2 :: Int] +-- True +semigroupLawMonoidRightIdentity :: (Applicative f, Monoid b, Eq (f b)) => SemigroupOpT f a b -> a -> a -> Bool +semigroupLawMonoidRightIdentity p a1 a2 = + runSemigroupOpT (p <> mempty) a1 a2 == runSemigroupOpT p a1 a2 + +-- | 'Functor' identity: @'fmap' 'id' == 'id'@ +-- +-- >>> semigroupLawFunctorIdentity add 3 4 +-- True +semigroupLawFunctorIdentity :: (Functor f, Eq (f b)) => SemigroupOpT f a b -> a -> a -> Bool +semigroupLawFunctorIdentity p a1 a2 = + runSemigroupOpT (fmap id p) a1 a2 == runSemigroupOpT p a1 a2 + +-- | 'Functor' composition: @'fmap' (g '.' h) == 'fmap' g '.' 'fmap' h@ +-- +-- >>> semigroupLawFunctorComposition (*10) (+1) add 3 4 +-- True +semigroupLawFunctorComposition :: (Functor f, Eq (f d)) => (c -> d) -> (b -> c) -> SemigroupOpT f a b -> a -> a -> Bool +semigroupLawFunctorComposition g h p a1 a2 = + runSemigroupOpT (fmap (g . h) p) a1 a2 == runSemigroupOpT (fmap g (fmap h p)) a1 a2 + +-- | 'Profunctor' identity: @'dimap' 'id' 'id' == 'id'@ +-- +-- >>> semigroupLawProfunctorIdentity add 3 4 +-- True +semigroupLawProfunctorIdentity :: (Functor f, Eq (f b)) => SemigroupOpT f a b -> a -> a -> Bool +semigroupLawProfunctorIdentity p a1 a2 = + runSemigroupOpT (dimap id id p) a1 a2 == runSemigroupOpT p a1 a2 + +-- | 'Extend' associativity: @'extended' f '.' 'extended' g == 'extended' (f '.' 'extended' g)@ +-- +-- >>> semigroupLawExtendAssociative (const True) (const 'x') add 3 4 +-- True +semigroupLawExtendAssociative :: (Functor f, Eq (f c)) => (SemigroupOpT f a b -> c) -> (SemigroupOpT f a d -> b) -> SemigroupOpT f a d -> a -> a -> Bool +semigroupLawExtendAssociative f g p a1 a2 = + runSemigroupOpT (extended f (extended g p)) a1 a2 == runSemigroupOpT (extended (f . extended g) p) a1 a2 + +-- | 'Semigroupoid' associativity: @'o' f ('o' g h) == 'o' ('o' f g) h@ +-- +-- >>> semigroupLawSemigroupoidAssociative add add add 3 4 +-- True +semigroupLawSemigroupoidAssociative :: (Monad f, Eq (f d)) => SemigroupOpT f c d -> SemigroupOpT f b c -> SemigroupOpT f a b -> a -> a -> Bool +semigroupLawSemigroupoidAssociative f g h x1 x2 = + runSemigroupOpT (o f (o g h)) x1 x2 == runSemigroupOpT (o (o f g) h) x1 x2 + +-- | Classy lens for types that contain a 'SemigroupOpT'. +-- +-- >>> run (view semigroupOpT add) 3 4 +-- 7 +class HasSemigroupOpT c f a b | c -> f a b where + semigroupOpT :: Lens' c (SemigroupOpT f a b) + +instance HasSemigroupOpT (SemigroupOpT f a b) f a b where + semigroupOpT = id + +-- | Classy prism for types that can be constructed from a 'SemigroupOpT'. +-- +-- >>> run (review _SemigroupOpT add) 3 4 +-- 7 +class AsSemigroupOpT c f a b | c -> f a b where + _SemigroupOpT :: Prism' c (SemigroupOpT f a b) + +instance AsSemigroupOpT (SemigroupOpT f a b) f a b where + _SemigroupOpT = id + +---- +-- SemigroupOp' values via semigroup +---- + +-- | >>> run semigroupUnit () () +-- () +semigroupUnit :: SemigroupOp' () +semigroupUnit = semigroupSemigroup + +-- | Vacuously associative — 'Void' has no inhabitants. +semigroupVoid :: SemigroupOp' Void +semigroupVoid = semigroupSemigroup + +-- | Lexicographic composition of orderings. +-- +-- >>> run semigroupOrdering LT GT +-- LT +-- >>> run semigroupOrdering EQ GT +-- GT +-- >>> run semigroupOrdering EQ EQ +-- EQ +semigroupOrdering :: SemigroupOp' Ordering +semigroupOrdering = semigroupSemigroup + +-- | List concatenation. +-- +-- >>> run semigroupList [1,2] [3,4 :: Int] +-- [1,2,3,4] +semigroupList :: SemigroupOp' [a] +semigroupList = semigroupSemigroup + +-- | Non-empty list concatenation. +-- +-- >>> run semigroupNonEmpty (1 :| [2]) (3 :| [4 :: Int]) +-- 1 :| [2,3,4] +semigroupNonEmpty :: SemigroupOp' (NonEmpty a) +semigroupNonEmpty = semigroupSemigroup + +-- | First 'Right' wins; 'Left' is absorbed. +-- +-- >>> run semigroupEither (Left "a") (Right 1 :: Either String Int) +-- Right 1 +-- >>> run semigroupEither (Right 1) (Left "b" :: Either String Int) +-- Right 1 +-- >>> run semigroupEither (Left "a") (Left "b" :: Either String Int) +-- Left "b" +semigroupEither :: SemigroupOp' (Either a b) +semigroupEither = semigroupSemigroup + +-- | >>> run semigroupProxy Proxy (Proxy :: Proxy Int) +-- Proxy +semigroupProxy :: SemigroupOp' (Proxy a) +semigroupProxy = semigroupSemigroup + +-- | 'Nothing' is identity; 'Just' values are combined. +-- +-- >>> run semigroupMaybe (Just [1]) (Just [2 :: Int]) +-- Just [1,2] +-- >>> run semigroupMaybe Nothing (Just [2 :: Int]) +-- Just [2] +-- >>> run semigroupMaybe (Just [1 :: Int]) Nothing +-- Just [1] +semigroupMaybe :: (Semigroup a) => SemigroupOp' (Maybe a) +semigroupMaybe = semigroupSemigroup + +-- | First-success on 'Maybe' via 'Alt'. +-- +-- >>> run semigroupAlt (Just 1) (Just 2 :: Maybe Int) +-- Just 1 +-- >>> run semigroupAlt Nothing (Just 2 :: Maybe Int) +-- Just 2 +semigroupAlt :: SemigroupOp' (Maybe a) +semigroupAlt = op () + +-- | First-success on 'Maybe' via 'Alternative'. +-- +-- >>> run semigroupAlternative (Just 1) (Just 2 :: Maybe Int) +-- Just 1 +-- >>> run semigroupAlternative Nothing (Just 2 :: Maybe Int) +-- Just 2 +semigroupAlternative :: SemigroupOp' (Maybe a) +semigroupAlternative = op (<|>) + +-- | Reverses the inner semigroup. +-- +-- >>> run semigroupDual (Dual [1]) (Dual [2 :: Int]) +-- Dual {getDual = [2,1]} +semigroupDual :: (Semigroup a) => SemigroupOp' (Dual a) +semigroupDual = semigroupSemigroup + +-- | Delegates through 'Down'. +-- +-- >>> run semigroupDown (Down [1]) (Down [2 :: Int]) +-- Down [1,2] +semigroupDown :: (Semigroup a) => SemigroupOp' (Down a) +semigroupDown = semigroupSemigroup + +-- | Delegates through 'Identity'. +-- +-- >>> run semigroupIdentity (Identity [1]) (Identity [2 :: Int]) +-- Identity [1,2] +semigroupIdentity :: (Semigroup a) => SemigroupOp' (Identity a) +semigroupIdentity = semigroupSemigroup + +-- | Pairwise combination. +-- +-- >>> run semigroupTuple ([1 :: Int], [10]) ([2], [20 :: Int]) +-- ([1,2],[10,20]) +semigroupTuple :: (Semigroup a, Semigroup b) => SemigroupOp' (a, b) +semigroupTuple = semigroupSemigroup + +-- | Uses the underlying 'Monoid' operation. +-- +-- >>> run semigroupWrappedMonoid (WrapMonoid [1]) (WrapMonoid [2 :: Int]) +-- WrapMonoid {unwrapMonoid = [1,2]} +semigroupWrappedMonoid :: (Monoid a) => SemigroupOp' (WrappedMonoid a) +semigroupWrappedMonoid = semigroupSemigroup + +-- | Pointwise combination. +-- +-- >>> run semigroupFunction (++ "a") ((++ "b") :: String -> String) "x" +-- "xaxb" +semigroupFunction :: (Semigroup b) => SemigroupOp' (a -> b) +semigroupFunction = semigroupSemigroup + +---- +-- SemigroupOp' values via op +---- + +-- | Takes the first value ('First'). +-- +-- >>> run semigroupFirst 'a' 'b' +-- 'a' +semigroupFirst :: SemigroupOp' a +semigroupFirst = op const + +-- | Takes the last value ('Last'). +-- +-- >>> run semigroupLast 'a' 'b' +-- 'b' +semigroupLast :: SemigroupOp' a +semigroupLast = op (const id) + +-- | Takes the minimum ('Min'). +-- +-- >>> run semigroupMin (3 :: Int) 4 +-- 3 +semigroupMin :: (Ord a) => SemigroupOp' a +semigroupMin = op min + +-- | Takes the maximum ('Max'). +-- +-- >>> run semigroupMax (3 :: Int) 4 +-- 4 +semigroupMax :: (Ord a) => SemigroupOp' a +semigroupMax = op max + +-- | Logical conjunction ('All'). +-- +-- >>> run semigroupAll True True +-- True +-- >>> run semigroupAll True False +-- False +semigroupAll :: SemigroupOp' Bool +semigroupAll = op (&&) + +-- | Logical disjunction ('Any'). +-- +-- >>> run semigroupAny False False +-- False +-- >>> run semigroupAny False True +-- True +semigroupAny :: SemigroupOp' Bool +semigroupAny = op (||) + +-- | Addition ('Sum'). +-- +-- >>> run semigroupAddition (3 :: Int) 4 +-- 7 +semigroupAddition :: (Num a) => SemigroupOp' a +semigroupAddition = op (+) + +-- | Multiplication ('Product'). +-- +-- >>> run semigroupMultiplication (3 :: Int) 4 +-- 12 +semigroupMultiplication :: (Num a) => SemigroupOp' a +semigroupMultiplication = op (*) + +-- | Function composition ('Endo'). +-- +-- >>> run semigroupEndo (+1) ((*10) :: Int -> Int) 3 +-- 31 +semigroupEndo :: SemigroupOp' (a -> a) +semigroupEndo = op (.) + +-- | Bitwise AND ('Data.Bits.And'). +-- +-- >>> run semigroupAnd (0xFF :: Word8) 0x0F +-- 15 +semigroupAnd :: (Bits a) => SemigroupOp' a +semigroupAnd = op (.&.) + +-- | Bitwise inclusive OR ('Data.Bits.Ior'). +-- +-- >>> run semigroupIor (0xF0 :: Word8) 0x0F +-- 255 +semigroupIor :: (Bits a) => SemigroupOp' a +semigroupIor = op (.|.) + +-- | Bitwise exclusive OR ('Data.Bits.Xor'). +-- +-- >>> run semigroupXor (0xFF :: Word8) 0x0F +-- 240 +semigroupXor :: (Bits a) => SemigroupOp' a +semigroupXor = op xor + +-- | Bitwise equivalence / XNOR ('Data.Bits.Iff'). +-- +-- >>> run semigroupIff (0xFF :: Word8) 0x0F +-- 15 +semigroupIff :: (FiniteBits a) => SemigroupOp' a +semigroupIff = op (\a b -> complement (xor a b)) + +---- +-- Collection values +---- + +-- | Set union. +-- +-- >>> run semigroupSetUnion (Set.fromList [1,2]) (Set.fromList [2,3 :: Int]) +-- fromList [1,2,3] +semigroupSetUnion :: (Ord a) => SemigroupOp' (Set a) +semigroupSetUnion = op Set.union + +-- | Set intersection. +-- +-- >>> run semigroupSetIntersection (Set.fromList [1,2,3]) (Set.fromList [2,3,4 :: Int]) +-- fromList [2,3] +semigroupSetIntersection :: (Ord a) => SemigroupOp' (Set a) +semigroupSetIntersection = op Set.intersection + +-- | IntSet union. +-- +-- >>> run semigroupIntSetUnion (IntSet.fromList [1,2]) (IntSet.fromList [2,3]) +-- fromList [1,2,3] +semigroupIntSetUnion :: SemigroupOp' IntSet +semigroupIntSetUnion = op IntSet.union + +-- | IntSet intersection. +-- +-- >>> run semigroupIntSetIntersection (IntSet.fromList [1,2,3]) (IntSet.fromList [2,3,4]) +-- fromList [2,3] +semigroupIntSetIntersection :: SemigroupOp' IntSet +semigroupIntSetIntersection = op IntSet.intersection + +-- | HashSet union. +-- +-- >>> sort (HashSet.toList (run semigroupHashSetUnion (HashSet.fromList [1,2]) (HashSet.fromList [2,3 :: Int]))) +-- [1,2,3] +semigroupHashSetUnion :: (Eq a, Hashable a) => SemigroupOp' (HashSet a) +semigroupHashSetUnion = op HashSet.union + +-- | HashSet intersection. +-- +-- >>> sort (HashSet.toList (run semigroupHashSetIntersection (HashSet.fromList [1,2,3]) (HashSet.fromList [2,3,4 :: Int]))) +-- [2,3] +semigroupHashSetIntersection :: (Eq a, Hashable a) => SemigroupOp' (HashSet a) +semigroupHashSetIntersection = op HashSet.intersection + +-- | Map union (left-biased on overlapping keys). +-- +-- >>> run semigroupMapUnion (Map.fromList [(1 :: Int,'a'),(2,'b')]) (Map.fromList [(2,'x'),(3,'c')]) +-- fromList [(1,'a'),(2,'b'),(3,'c')] +semigroupMapUnion :: (Ord k) => SemigroupOp' (Map k v) +semigroupMapUnion = op Map.union + +-- | Map intersection (left-biased on overlapping keys). +-- +-- >>> run semigroupMapIntersection (Map.fromList [(1 :: Int,'a'),(2,'b'),(3,'c')]) (Map.fromList [(2,'x'),(3,'y'),(4,'z')]) +-- fromList [(2,'b'),(3,'c')] +semigroupMapIntersection :: (Ord k) => SemigroupOp' (Map k v) +semigroupMapIntersection = op Map.intersection + +-- | IntMap union (left-biased on overlapping keys). +-- +-- >>> run semigroupIntMapUnion (IntMap.fromList [(1,'a'),(2,'b')]) (IntMap.fromList [(2,'x'),(3,'c')]) +-- fromList [(1,'a'),(2,'b'),(3,'c')] +semigroupIntMapUnion :: SemigroupOp' (IntMap v) +semigroupIntMapUnion = op IntMap.union + +-- | IntMap intersection (left-biased on overlapping keys). +-- +-- >>> run semigroupIntMapIntersection (IntMap.fromList [(1,'a'),(2,'b'),(3,'c')]) (IntMap.fromList [(2,'x'),(3,'y'),(4,'z')]) +-- fromList [(2,'b'),(3,'c')] +semigroupIntMapIntersection :: SemigroupOp' (IntMap v) +semigroupIntMapIntersection = op IntMap.intersection + +-- | HashMap union (left-biased on overlapping keys). +-- +-- >>> sort (HashMap.toList (run semigroupHashMapUnion (HashMap.fromList [(1 :: Int,'a'),(2,'b')]) (HashMap.fromList [(2,'x'),(3,'c')]))) +-- [(1,'a'),(2,'b'),(3,'c')] +semigroupHashMapUnion :: (Eq k, Hashable k) => SemigroupOp' (HashMap k v) +semigroupHashMapUnion = op HashMap.union + +-- | HashMap intersection (left-biased on overlapping keys). +-- +-- >>> sort (HashMap.toList (run semigroupHashMapIntersection (HashMap.fromList [(1 :: Int,'a'),(2,'b'),(3,'c')]) (HashMap.fromList [(2,'x'),(3,'y'),(4,'z')]))) +-- [(2,'b'),(3,'c')] +semigroupHashMapIntersection :: (Eq k, Hashable k) => SemigroupOp' (HashMap k v) +semigroupHashMapIntersection = op HashMap.intersection diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -Wall -Werror #-} + +module Main where + +import System.Exit (exitWith) +import System.Process (rawSystem) + +main :: IO () +main = + exitWith + =<< rawSystem + "cabal" + [ "repl", + "--with-compiler=doctest", + "--repl-options=-w", + "--repl-options=-Wdefault", + "lib:associative" + ]