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

{-# 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,
    nonPartialSemigroup,
    defaultSemigroupOpT,

    -- * 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,
    psemigroupApplyThen,
    psemigroupApplyFirst,
    psemigroupApplicativeThen,
    psemigroupApplicativeFirst,
    psemigroupLiftF2,
    psemigroupLiftA2,

    -- * 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.Associative.SemigroupOp (SemigroupOp, SemigroupOp', SemigroupOpT (..), op, runSemigroupOp)
import Data.Bits (Bits, FiniteBits, complement, xor, (.&.), (.|.))
import Data.Functor.Alt (Alt (..))
import Data.Functor.Apply (Apply (..), liftF2)
import Data.Functor.Bind (Bind (..))
import Data.Functor.Const (Const (..))
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.Maybe (fromMaybe)
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.Associative.SemigroupOp (SemigroupOp', op, semigroupList, runSemigroupOp)
-- >>> 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 cat = op (++) :: SemigroupOp' [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

-- | Convert a partial semigroup operation to a total one by providing a default
-- value for the undefined case.
--
-- >>> runSemigroupOp (defaultSemigroupOpT 0 addPos) 3 4
-- 7
-- >>> runSemigroupOp (defaultSemigroupOpT 0 addPos) (-1) 4
-- 0
defaultSemigroupOpT :: (Applicative f) => f b -> PartialSemigroupOpT f a b -> SemigroupOpT f a b
defaultSemigroupOpT x (PartialSemigroupOpT k) = SemigroupOpT (\a1 a2 -> fromMaybe <$> x <*> k a1 a2)
{-# INLINE defaultSemigroupOpT #-}

-- | 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 #-}

nonPartialSemigroup :: Iso (PartialSemigroupOpT (Const b) a b) (PartialSemigroupOpT (Const b') a' b') (SemigroupOp a b) (SemigroupOp a' b')
nonPartialSemigroup =
  iso
    (\k -> op (\a1 a2 -> getConst (runPartialSemigroupOpT k a1 a2)))
    (\k -> totalT (\a1 a2 -> Const (runSemigroupOp k a1 a2)))
{-# INLINE nonPartialSemigroup #-}

-- | 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 f) x y z = do
  mxy <- f x y
  lhs <- case mxy of
    Nothing -> pure Nothing
    Just xy -> f xy z
  myz <- f y z
  rhs <- case myz of
    Nothing -> pure Nothing
    Just yz -> f 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 cat) (Just [1]) (Just [2 :: Int])
-- Just (Just [1,2])
-- >>> run (psemigroupMaybe cat) Nothing (Just [2 :: Int])
-- Just (Just [2])
-- >>> run (psemigroupMaybe cat) (Just [1 :: Int]) Nothing
-- Just (Just [1])
psemigroupMaybe :: SemigroupOp' a -> PartialSemigroupOp' (Maybe a)
psemigroupMaybe s =
  total
    ( \mx my -> case (mx, my) of
        (Nothing, y) -> y
        (x, Nothing) -> x
        (Just x, Just y) -> Just (runSemigroupOp s x y)
    )

-- | Reverses the inner semigroup.
--
-- >>> run (psemigroupDual cat) (Dual [1]) (Dual [2 :: Int])
-- Just (Dual {getDual = [2,1]})
psemigroupDual :: SemigroupOp' a -> PartialSemigroupOp' (Dual a)
psemigroupDual s = total (\(Dual x) (Dual y) -> Dual (runSemigroupOp s y x))

-- | Delegates through 'Down'.
--
-- >>> run (psemigroupDown cat) (Down [1]) (Down [2 :: Int])
-- Just (Down [1,2])
psemigroupDown :: SemigroupOp' a -> PartialSemigroupOp' (Down a)
psemigroupDown s = total (\(Down x) (Down y) -> Down (runSemigroupOp s x y))

-- | Delegates through 'Identity'.
--
-- >>> run (psemigroupIdentity cat) (Identity [1]) (Identity [2 :: Int])
-- Just (Identity [1,2])
psemigroupIdentity :: SemigroupOp' a -> PartialSemigroupOp' (Identity a)
psemigroupIdentity s = total (\(Identity x) (Identity y) -> Identity (runSemigroupOp s x y))

-- | Pairwise combination.
--
-- >>> run (psemigroupTuple cat cat) ([1 :: Int], [10]) ([2], [20 :: Int])
-- Just ([1,2],[10,20])
psemigroupTuple :: SemigroupOp' a -> SemigroupOp' b -> PartialSemigroupOp' (a, b)
psemigroupTuple sa sb = total (\(a1, b1) (a2, b2) -> (runSemigroupOp sa a1 a2, runSemigroupOp sb b1 b2))

-- | Uses the underlying semigroup operation.
--
-- >>> run (psemigroupWrappedMonoid cat) (WrapMonoid [1]) (WrapMonoid [2 :: Int])
-- Just (WrapMonoid {unwrapMonoid = [1,2]})
psemigroupWrappedMonoid :: SemigroupOp' a -> PartialSemigroupOp' (WrappedMonoid a)
psemigroupWrappedMonoid s = total (\(WrapMonoid x) (WrapMonoid y) -> WrapMonoid (runSemigroupOp s x y))

-- | Pointwise combination.
--
-- >>> fmap ($ "x") (run (psemigroupFunction semigroupList) (++ "a") ((++ "b") :: String -> String))
-- Just "xaxb"
psemigroupFunction :: SemigroupOp' b -> PartialSemigroupOp' (a -> b)
psemigroupFunction s = total (\f g x -> runSemigroupOp s (f x) (g x))

-- | 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 (<|>)

-- | Sequence both, keep last result via 'Data.Functor.Apply.Apply'.
--
-- >>> run psemigroupApplyThen (Just 1) (Just 2 :: Maybe Int)
-- Just (Just 2)
-- >>> run psemigroupApplyThen Nothing (Just 2 :: Maybe Int)
-- Just Nothing
psemigroupApplyThen :: (Apply f) => PartialSemigroupOp' (f a)
psemigroupApplyThen = total (.>)

-- | Sequence both, keep first result via 'Data.Functor.Apply.Apply'.
--
-- >>> run psemigroupApplyFirst (Just 1) (Just 2 :: Maybe Int)
-- Just (Just 1)
-- >>> run psemigroupApplyFirst Nothing (Just 2 :: Maybe Int)
-- Just Nothing
psemigroupApplyFirst :: (Apply f) => PartialSemigroupOp' (f a)
psemigroupApplyFirst = total (<.)

-- | Sequence both, keep last result via 'Applicative'.
--
-- >>> run psemigroupApplicativeThen (Just 1) (Just 2 :: Maybe Int)
-- Just (Just 2)
-- >>> run psemigroupApplicativeThen Nothing (Just 2 :: Maybe Int)
-- Just Nothing
psemigroupApplicativeThen :: (Applicative f) => PartialSemigroupOp' (f a)
psemigroupApplicativeThen = total (*>)

-- | Sequence both, keep first result via 'Applicative'.
--
-- >>> run psemigroupApplicativeFirst (Just 1) (Just 2 :: Maybe Int)
-- Just (Just 1)
-- >>> run psemigroupApplicativeFirst Nothing (Just 2 :: Maybe Int)
-- Just Nothing
psemigroupApplicativeFirst :: (Applicative f) => PartialSemigroupOp' (f a)
psemigroupApplicativeFirst = total (<*)

-- | Lift a semigroup operation through an 'Data.Functor.Apply.Apply' functor via 'Data.Functor.Apply.liftF2'.
--
-- >>> run (psemigroupLiftF2 (op (+) :: SemigroupOp' Int)) (Just 3) (Just 4)
-- Just (Just 7)
-- >>> run (psemigroupLiftF2 (op (+) :: SemigroupOp' Int)) Nothing (Just 4)
-- Just Nothing
psemigroupLiftF2 :: (Apply f) => SemigroupOp' a -> PartialSemigroupOp' (f a)
psemigroupLiftF2 s = total (liftF2 (runSemigroupOp s))

-- | Lift a semigroup operation through an 'Applicative' functor via 'Control.Applicative.liftA2'.
--
-- >>> run (psemigroupLiftA2 (op (+) :: SemigroupOp' Int)) (Just 3) (Just 4)
-- Just (Just 7)
-- >>> run (psemigroupLiftA2 (op (+) :: SemigroupOp' Int)) Nothing (Just 4)
-- Just Nothing
psemigroupLiftA2 :: (Applicative f) => SemigroupOp' a -> PartialSemigroupOp' (f a)
psemigroupLiftA2 s = total (liftA2 (runSemigroupOp s))

----
-- 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