-- | A /semigroup/ ('Semigroup') is a set with a binary associative operation (@<>@).
--
-- This module defines a /partial semigroup/ ('PartialSemigroup'), a
-- semigroup for which @<>@ is not required to be defined over all inputs.
module Data.PartialSemigroup
  ( -- * Partial semigroup
    PartialSemigroup (..),

    -- * Either
    -- $either
    AppendLeft (..),
    AppendRight (..),

    -- * Tuples
    -- $tuple

    -- * Concatenation
    groupAndConcat,
    partialConcat,
    partialConcat1,

    -- * Zipping
    partialZip,
    partialZip1,

    -- * Total to partial
    -- $total
    Total (..),

    -- * Partial to total
    -- $partial
    Partial (..),

    -- * Refusing to combine
    -- $refusing
    One (..),
    AtMostOne (..),
  )
where

import Control.Applicative (ZipList (..), (<$>), (<*>))
import Control.Monad ((>>=))
import Data.Either (Either (..))
import Data.Function ((.))
import Data.Functor.Identity (Identity (..))
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import Data.Maybe (Maybe (..))
import Data.Monoid (Product (..), Sum (..))
import Data.Semigroup (Semigroup (..))
import Prelude (Eq, Num (..), Ord, Read, Show)

-- $setup
--
-- >>> import Data.Function (($))
-- >>> import Data.Functor (fmap)

-- The same fixity as <>
infixr 6 <>?

-- | A 'PartialSemigroup' is like a 'Semigroup', but with an operator returning
-- @'Maybe' a@ rather than @a@.
--
-- For comparison:
--
-- @
-- ('<>')  :: 'Semigroup' a        => a -> a -> a
-- ('<>?') :: 'PartialSemigroup' a => a -> a -> 'Maybe' a
-- @
--
-- === The associativity axiom for partial semigroups
--
-- For all @x@, @y@, @z@:
--
--  * If @x '<>?' y = 'Just' xy@ and @y '<>?' z = 'Just' yz@, then
--
--      * @x '<>?' yz = xy '<>?' z@.
--
-- ==== Relationship to the semigroup associativity axiom
--
-- The partial semigroup associativity axiom is a natural adaptation of the
-- semigroup associativity axiom
--
-- @x '<>' (y '<>' z) = (x '<>' y) '<>' z@
--
-- with a slight modification to accommodate situations where '<>' is undefined. We
-- may gain some insight into the connection between 'Semigroup' and
-- 'PartialSemigroup' by rephrasing the partial semigroup associativity in terms of
-- a partial '<>' operator thusly:
--
-- For all @x@, @y@, @z@:
--
--  * If @x '<>' y@ and @y '<>' z@ are both defined, then
--
--      * @x '<>' (y '<>' z)@ is defined if and only if @(x '<>' y) '<>' z@ is
--        defined, and
--
--      * if these things /are/ all defined, then the axiom for total semigroups
--        @x '<>' (y '<>' z) = (x '<>' y) '<>' z@ must hold.
class PartialSemigroup a where
  (<>?) :: a -> a -> Maybe a

--------------------------------------------------------------------------------

instance PartialSemigroup () where
  () <>? :: () -> () -> Maybe ()
<>? () = forall a. a -> Maybe a
Just ()

--------------------------------------------------------------------------------

instance PartialSemigroup [a] where
  [a]
x <>? :: [a] -> [a] -> Maybe [a]
<>? [a]
y = forall a. a -> Maybe a
Just ([a]
x forall a. Semigroup a => a -> a -> a
<> [a]
y)

--------------------------------------------------------------------------------

instance Num a => PartialSemigroup (Sum a) where
  Sum a
x <>? :: Sum a -> Sum a -> Maybe (Sum a)
<>? Sum a
y = forall a. a -> Maybe a
Just (Sum a
x forall a. Semigroup a => a -> a -> a
<> Sum a
y)

instance Num a => PartialSemigroup (Product a) where
  Product a
x <>? :: Product a -> Product a -> Maybe (Product a)
<>? Product a
y = forall a. a -> Maybe a
Just (Product a
x forall a. Semigroup a => a -> a -> a
<> Product a
y)

--------------------------------------------------------------------------------

instance PartialSemigroup a => PartialSemigroup (Identity a) where
  Identity a
x <>? :: Identity a -> Identity a -> Maybe (Identity a)
<>? Identity a
y = forall a. a -> Identity a
Identity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a
x forall a. PartialSemigroup a => a -> a -> Maybe a
<>? a
y)

--------------------------------------------------------------------------------

instance
  (PartialSemigroup a, PartialSemigroup b) =>
  PartialSemigroup (Either a b)
  where
  Left a
x <>? :: Either a b -> Either a b -> Maybe (Either a b)
<>? Left a
y = forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a
x forall a. PartialSemigroup a => a -> a -> Maybe a
<>? a
y)
  Right b
x <>? Right b
y = forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (b
x forall a. PartialSemigroup a => a -> a -> Maybe a
<>? b
y)
  Either a b
_ <>? Either a b
_ = forall a. Maybe a
Nothing

-- $either
--
-- The exemplary nontrivial 'PartialSemigroup' is 'Either', for which the append
-- operator produces a 'Just' result only if both arguments are 'Left' or both
-- arguments are 'Right'.
--
-- >>> Left "ab" <>? Left "cd"
-- Just (Left "abcd")
--
-- >>> Left "ab" <>? Right [1, 2]
-- Nothing

--------------------------------------------------------------------------------

-- $tuple
--
-- A tuple forms a partial semigroups when all of its constituent parts have
-- partial semigroups. The append operator returns a 'Just' value when /all/ of the
-- fields' append operators must return 'Just' values.
--
-- >>> x = (Left "ab", Right "hi")
-- >>> y = (Left "cd", Right "jk")
-- >>> x <>? y
-- Just (Left "abcd",Right "hijk")
--
-- >>> x = (Left "ab", Right "hi")
-- >>> y = (Left "cd", Left "jk")
-- >>> x <>? y
-- Nothing

instance (PartialSemigroup a, PartialSemigroup b) => PartialSemigroup (a, b) where
  (a
a, b
b) <>? :: (a, b) -> (a, b) -> Maybe (a, b)
<>? (a
a', b
b') =
    (,)
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a
a forall a. PartialSemigroup a => a -> a -> Maybe a
<>? a
a')
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (b
b forall a. PartialSemigroup a => a -> a -> Maybe a
<>? b
b')

instance
  (PartialSemigroup a, PartialSemigroup b, PartialSemigroup c) =>
  PartialSemigroup (a, b, c)
  where
  (a
a, b
b, c
c) <>? :: (a, b, c) -> (a, b, c) -> Maybe (a, b, c)
<>? (a
a', b
b', c
c') =
    (,,)
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a
a forall a. PartialSemigroup a => a -> a -> Maybe a
<>? a
a')
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (b
b forall a. PartialSemigroup a => a -> a -> Maybe a
<>? b
b')
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (c
c forall a. PartialSemigroup a => a -> a -> Maybe a
<>? c
c')

--------------------------------------------------------------------------------

-- | Apply a semigroup operation to any pairs of consecutive list elements where
-- the semigroup operation is defined over them.
--
-- ==== Examples
--
-- For 'Either', 'groupAndConcat' combines contiguous sublists of 'Left' and
-- contiguous sublists of 'Right'.
--
-- >>> xs = [Left "a", Right "b", Right "c", Left "d", Left "e", Left "f"]
-- >>> groupAndConcat xs
-- [Left "a",Right "bc",Left "def"]
groupAndConcat :: PartialSemigroup a => [a] -> [a]
groupAndConcat :: forall a. PartialSemigroup a => [a] -> [a]
groupAndConcat [] = []
groupAndConcat [a
x] = [a
x]
groupAndConcat (a
x : a
y : [a]
zs) =
  case a
x forall a. PartialSemigroup a => a -> a -> Maybe a
<>? a
y of
    Maybe a
Nothing -> a
x forall a. a -> [a] -> [a]
: forall a. PartialSemigroup a => [a] -> [a]
groupAndConcat (a
y forall a. a -> [a] -> [a]
: [a]
zs)
    Just a
a -> forall a. PartialSemigroup a => [a] -> [a]
groupAndConcat (a
a forall a. a -> [a] -> [a]
: [a]
zs)

-- | If @xs@ is nonempty and the partial semigroup operator is defined for all
-- pairs of values in @xs@, then @'partialConcat' xs@ produces a 'Just' result with
-- the combination of all the values. Otherwise, returns 'Nothing'.
--
-- ==== Examples
--
-- When all values can combine, we get a 'Just' of their combination.
--
-- >>> partialConcat [Left "a", Left "b", Left "c"]
-- Just (Left "abc")
--
-- When some values cannot be combined, we get 'Nothing'.
--
-- >>> partialConcat [Left "a", Left "b", Right "c"]
-- Nothing
--
-- When the list is empty, we get 'Nothing'.
--
-- >>> partialConcat []
-- Nothing
partialConcat :: PartialSemigroup a => [a] -> Maybe a
partialConcat :: forall a. PartialSemigroup a => [a] -> Maybe a
partialConcat [a]
x =
  forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [a]
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. PartialSemigroup a => NonEmpty a -> Maybe a
partialConcat1

-- | Like 'partialConcat', but for non-empty lists.
--
-- ==== Examples
--
-- When all values can combine, we get a 'Just' of their combination.
--
-- >>> partialConcat1 (Left "a" :| [Left "b", Left "c"])
-- Just (Left "abc")
--
-- When some values cannot be combined, we get 'Nothing'.
--
-- >>> partialConcat1 (Left "a" :| [Left "b", Right "c"])
-- Nothing
partialConcat1 :: PartialSemigroup a => NonEmpty a -> Maybe a
partialConcat1 :: forall a. PartialSemigroup a => NonEmpty a -> Maybe a
partialConcat1 (a
x :| []) = forall a. a -> Maybe a
Just a
x
partialConcat1 (a
x :| (a
y : [a]
zs)) =
  do
    a
a <- a
x forall a. PartialSemigroup a => a -> a -> Maybe a
<>? a
y
    forall a. PartialSemigroup a => NonEmpty a -> Maybe a
partialConcat1 (a
a forall a. a -> [a] -> NonEmpty a
:| [a]
zs)

-- | ==== Examples
--
-- If lists are the same length and each pair of elements successfully, then we get
-- a 'Just' result.
--
-- >>> xs = [Left "a", Left "b", Right "c"]
-- >>> ys = [Left "1", Left "2", Right "3"]
-- >>> partialZip xs ys
-- Just [Left "a1",Left "b2",Right "c3"]
--
-- If the pairs do not all combine, then we get 'Nothing'.
--
-- >>> xs = [Left "a", Left "b", Right "c"]
-- >>> ys = [Left "1", Right "2", Right "3"]
-- >>> partialZip xs ys
-- Nothing
--
-- If the lists have different lengths, then we get 'Nothing'.
--
-- >>> xs = [Left "a", Left "b", Right "c"]
-- >>> ys = [Left "1", Left "2"]
-- >>> partialZip xs ys
-- Nothing
partialZip :: PartialSemigroup a => [a] -> [a] -> Maybe [a]
partialZip :: forall a. PartialSemigroup a => [a] -> [a] -> Maybe [a]
partialZip [] [] = forall a. a -> Maybe a
Just []
partialZip [] [a]
_ = forall a. Maybe a
Nothing
partialZip [a]
_ [] = forall a. Maybe a
Nothing
partialZip (a
x : [a]
xs) (a
y : [a]
ys) =
  (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a
x forall a. PartialSemigroup a => a -> a -> Maybe a
<>? a
y) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. PartialSemigroup a => [a] -> [a] -> Maybe [a]
partialZip [a]
xs [a]
ys

-- | Like 'partialZip', but for non-empty lists.
--
-- ==== Examples
--
-- If lists are the same length and each pair of elements successfully, then we get
-- a 'Just' result.
--
-- >>> xs = Left "a" :| [Left "b", Right "c"]
-- >>> ys = Left "1" :| [Left "2", Right "3"]
-- >>> partialZip1 xs ys
-- Just (Left "a1" :| [Left "b2",Right "c3"])
--
-- If the pairs do not all combine, then we get 'Nothing'.
--
-- >>> xs = Left "a" :| [Left "b", Right "c"]
-- >>> ys = Left "1" :| [Right "2", Right "3"]
-- >>> partialZip1 xs ys
-- Nothing
--
-- If the lists have different lengths, then we get 'Nothing'.
--
-- >>> xs = Left "a" :| [Left "b", Right "c"]
-- >>> ys = Left "1" :| [Left "2"]
-- >>> partialZip1 xs ys
-- Nothing
partialZip1 ::
  PartialSemigroup a =>
  NonEmpty a ->
  NonEmpty a ->
  Maybe (NonEmpty a)
partialZip1 :: forall a.
PartialSemigroup a =>
NonEmpty a -> NonEmpty a -> Maybe (NonEmpty a)
partialZip1 (a
x :| [a]
xs) (a
y :| [a]
ys) =
  forall a. a -> [a] -> NonEmpty a
(:|) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a
x forall a. PartialSemigroup a => a -> a -> Maybe a
<>? a
y) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. PartialSemigroup a => [a] -> [a] -> Maybe [a]
partialZip [a]
xs [a]
ys

-- | 'partialZip'
instance PartialSemigroup a => PartialSemigroup (ZipList a) where
  ZipList [a]
x <>? :: ZipList a -> ZipList a -> Maybe (ZipList a)
<>? ZipList [a]
y = forall a. [a] -> ZipList a
ZipList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. PartialSemigroup a => [a] -> [a] -> Maybe [a]
partialZip [a]
x [a]
y

--------------------------------------------------------------------------------

-- $partial
--
-- For every type @a@ with a 'PartialSemigroup', we can construct a total
-- 'Semigroup' for @'Maybe' a@ as:
--
-- @
-- 'Just' x <> 'Just' y = x '<>?' y
-- _ '<>' _ = 'Nothing'
-- @
--
-- We don't actually define this instance for 'Maybe' because it already has a
-- different 'Semigroup' defined over it, but we do provide the 'Partial' wrapper
-- which has this instance.

-- | A wrapper for 'Maybe' with an error-propagating 'Semigroup'.
newtype Partial a = Partial {forall a. Partial a -> Maybe a
unPartial :: Maybe a}
  deriving (Partial a -> Partial a -> Bool
forall a. Eq a => Partial a -> Partial a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Partial a -> Partial a -> Bool
$c/= :: forall a. Eq a => Partial a -> Partial a -> Bool
== :: Partial a -> Partial a -> Bool
$c== :: forall a. Eq a => Partial a -> Partial a -> Bool
Eq, Partial a -> Partial a -> Bool
Partial a -> Partial a -> Ordering
Partial a -> Partial a -> Partial a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (Partial a)
forall a. Ord a => Partial a -> Partial a -> Bool
forall a. Ord a => Partial a -> Partial a -> Ordering
forall a. Ord a => Partial a -> Partial a -> Partial a
min :: Partial a -> Partial a -> Partial a
$cmin :: forall a. Ord a => Partial a -> Partial a -> Partial a
max :: Partial a -> Partial a -> Partial a
$cmax :: forall a. Ord a => Partial a -> Partial a -> Partial a
>= :: Partial a -> Partial a -> Bool
$c>= :: forall a. Ord a => Partial a -> Partial a -> Bool
> :: Partial a -> Partial a -> Bool
$c> :: forall a. Ord a => Partial a -> Partial a -> Bool
<= :: Partial a -> Partial a -> Bool
$c<= :: forall a. Ord a => Partial a -> Partial a -> Bool
< :: Partial a -> Partial a -> Bool
$c< :: forall a. Ord a => Partial a -> Partial a -> Bool
compare :: Partial a -> Partial a -> Ordering
$ccompare :: forall a. Ord a => Partial a -> Partial a -> Ordering
Ord, ReadPrec [Partial a]
ReadPrec (Partial a)
ReadS [Partial a]
forall a. Read a => ReadPrec [Partial a]
forall a. Read a => ReadPrec (Partial a)
forall a. Read a => Int -> ReadS (Partial a)
forall a. Read a => ReadS [Partial a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Partial a]
$creadListPrec :: forall a. Read a => ReadPrec [Partial a]
readPrec :: ReadPrec (Partial a)
$creadPrec :: forall a. Read a => ReadPrec (Partial a)
readList :: ReadS [Partial a]
$creadList :: forall a. Read a => ReadS [Partial a]
readsPrec :: Int -> ReadS (Partial a)
$creadsPrec :: forall a. Read a => Int -> ReadS (Partial a)
Read, Int -> Partial a -> ShowS
forall a. Show a => Int -> Partial a -> ShowS
forall a. Show a => [Partial a] -> ShowS
forall a. Show a => Partial a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Partial a] -> ShowS
$cshowList :: forall a. Show a => [Partial a] -> ShowS
show :: Partial a -> String
$cshow :: forall a. Show a => Partial a -> String
showsPrec :: Int -> Partial a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Partial a -> ShowS
Show)

instance PartialSemigroup a => Semigroup (Partial a) where
  Partial (Just a
x) <> :: Partial a -> Partial a -> Partial a
<> Partial (Just a
y) = forall a. Maybe a -> Partial a
Partial (a
x forall a. PartialSemigroup a => a -> a -> Maybe a
<>? a
y)
  Partial a
_ <> Partial a
_ = forall a. Maybe a -> Partial a
Partial forall a. Maybe a
Nothing

--------------------------------------------------------------------------------

-- $total
--
-- For every type with a 'Semigroup', we can trivially construct a
-- 'PartialSemigroup' as:
--
-- @
-- x '<>?' y = 'Just' (x '<>' y)
-- @
--
-- Additionally, any type with a 'Semigroup' can be treated as a 'PartialSemigroup'
-- by lifting it into 'Total'.

-- | A wrapper to turn any value with a 'Semigroup' instance into a value with a
-- 'PartialSemigroup' instance whose '<>?' operator always returns 'Just'.
--
-- ==== Examples
--
-- >>> Total "ab" <>? Total "cd"
-- Just (Total {unTotal = "abcd"})
--
-- >>> f = getProduct . unTotal
-- >>> g = Total . Product
-- >>> fmap f . partialConcat . fmap g $ [1..4]
-- Just 24
newtype Total a = Total {forall a. Total a -> a
unTotal :: a}
  deriving (Total a -> Total a -> Bool
forall a. Eq a => Total a -> Total a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Total a -> Total a -> Bool
$c/= :: forall a. Eq a => Total a -> Total a -> Bool
== :: Total a -> Total a -> Bool
$c== :: forall a. Eq a => Total a -> Total a -> Bool
Eq, Total a -> Total a -> Bool
Total a -> Total a -> Ordering
Total a -> Total a -> Total a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (Total a)
forall a. Ord a => Total a -> Total a -> Bool
forall a. Ord a => Total a -> Total a -> Ordering
forall a. Ord a => Total a -> Total a -> Total a
min :: Total a -> Total a -> Total a
$cmin :: forall a. Ord a => Total a -> Total a -> Total a
max :: Total a -> Total a -> Total a
$cmax :: forall a. Ord a => Total a -> Total a -> Total a
>= :: Total a -> Total a -> Bool
$c>= :: forall a. Ord a => Total a -> Total a -> Bool
> :: Total a -> Total a -> Bool
$c> :: forall a. Ord a => Total a -> Total a -> Bool
<= :: Total a -> Total a -> Bool
$c<= :: forall a. Ord a => Total a -> Total a -> Bool
< :: Total a -> Total a -> Bool
$c< :: forall a. Ord a => Total a -> Total a -> Bool
compare :: Total a -> Total a -> Ordering
$ccompare :: forall a. Ord a => Total a -> Total a -> Ordering
Ord, ReadPrec [Total a]
ReadPrec (Total a)
ReadS [Total a]
forall a. Read a => ReadPrec [Total a]
forall a. Read a => ReadPrec (Total a)
forall a. Read a => Int -> ReadS (Total a)
forall a. Read a => ReadS [Total a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Total a]
$creadListPrec :: forall a. Read a => ReadPrec [Total a]
readPrec :: ReadPrec (Total a)
$creadPrec :: forall a. Read a => ReadPrec (Total a)
readList :: ReadS [Total a]
$creadList :: forall a. Read a => ReadS [Total a]
readsPrec :: Int -> ReadS (Total a)
$creadsPrec :: forall a. Read a => Int -> ReadS (Total a)
Read, Int -> Total a -> ShowS
forall a. Show a => Int -> Total a -> ShowS
forall a. Show a => [Total a] -> ShowS
forall a. Show a => Total a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Total a] -> ShowS
$cshowList :: forall a. Show a => [Total a] -> ShowS
show :: Total a -> String
$cshow :: forall a. Show a => Total a -> String
showsPrec :: Int -> Total a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Total a -> ShowS
Show)

instance Semigroup a => PartialSemigroup (Total a) where
  Total a
x <>? :: Total a -> Total a -> Maybe (Total a)
<>? Total a
y = forall a. a -> Maybe a
Just (forall a. a -> Total a
Total (a
x forall a. Semigroup a => a -> a -> a
<> a
y))

--------------------------------------------------------------------------------

-- | A wrapper for 'Either' where the 'PartialSemigroup' operator is defined
-- only over 'Left' values.
--
-- ==== Examples
--
-- Two 'Left's make a 'Just'.
--
-- >>> AppendLeft (Left "ab") <>? AppendLeft (Left "cd")
-- Just (AppendLeft {unAppendLeft = Left "abcd"})
--
-- Anything else produces 'Nothing'
--
-- >>> AppendLeft (Right "ab") <>? AppendLeft (Right "cd")
-- Nothing
--
-- 'groupAndConcat' combines consecutive 'Left' values, leaving the 'Right' values
-- unmodified.
--
-- >>> xs = [Left "a", Left "b", Right "c", Right "d", Left "e", Left "f"]
-- >>> fmap unAppendLeft . groupAndConcat . fmap AppendLeft $ xs
-- [Left "ab",Right "c",Right "d",Left "ef"]
newtype AppendLeft a b = AppendLeft {forall a b. AppendLeft a b -> Either a b
unAppendLeft :: Either a b}
  deriving (AppendLeft a b -> AppendLeft a b -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b.
(Eq a, Eq b) =>
AppendLeft a b -> AppendLeft a b -> Bool
/= :: AppendLeft a b -> AppendLeft a b -> Bool
$c/= :: forall a b.
(Eq a, Eq b) =>
AppendLeft a b -> AppendLeft a b -> Bool
== :: AppendLeft a b -> AppendLeft a b -> Bool
$c== :: forall a b.
(Eq a, Eq b) =>
AppendLeft a b -> AppendLeft a b -> Bool
Eq, AppendLeft a b -> AppendLeft a b -> Bool
AppendLeft a b -> AppendLeft a b -> Ordering
AppendLeft a b -> AppendLeft a b -> AppendLeft a b
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a} {b}. (Ord a, Ord b) => Eq (AppendLeft a b)
forall a b.
(Ord a, Ord b) =>
AppendLeft a b -> AppendLeft a b -> Bool
forall a b.
(Ord a, Ord b) =>
AppendLeft a b -> AppendLeft a b -> Ordering
forall a b.
(Ord a, Ord b) =>
AppendLeft a b -> AppendLeft a b -> AppendLeft a b
min :: AppendLeft a b -> AppendLeft a b -> AppendLeft a b
$cmin :: forall a b.
(Ord a, Ord b) =>
AppendLeft a b -> AppendLeft a b -> AppendLeft a b
max :: AppendLeft a b -> AppendLeft a b -> AppendLeft a b
$cmax :: forall a b.
(Ord a, Ord b) =>
AppendLeft a b -> AppendLeft a b -> AppendLeft a b
>= :: AppendLeft a b -> AppendLeft a b -> Bool
$c>= :: forall a b.
(Ord a, Ord b) =>
AppendLeft a b -> AppendLeft a b -> Bool
> :: AppendLeft a b -> AppendLeft a b -> Bool
$c> :: forall a b.
(Ord a, Ord b) =>
AppendLeft a b -> AppendLeft a b -> Bool
<= :: AppendLeft a b -> AppendLeft a b -> Bool
$c<= :: forall a b.
(Ord a, Ord b) =>
AppendLeft a b -> AppendLeft a b -> Bool
< :: AppendLeft a b -> AppendLeft a b -> Bool
$c< :: forall a b.
(Ord a, Ord b) =>
AppendLeft a b -> AppendLeft a b -> Bool
compare :: AppendLeft a b -> AppendLeft a b -> Ordering
$ccompare :: forall a b.
(Ord a, Ord b) =>
AppendLeft a b -> AppendLeft a b -> Ordering
Ord, ReadPrec [AppendLeft a b]
ReadPrec (AppendLeft a b)
ReadS [AppendLeft a b]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall a b. (Read a, Read b) => ReadPrec [AppendLeft a b]
forall a b. (Read a, Read b) => ReadPrec (AppendLeft a b)
forall a b. (Read a, Read b) => Int -> ReadS (AppendLeft a b)
forall a b. (Read a, Read b) => ReadS [AppendLeft a b]
readListPrec :: ReadPrec [AppendLeft a b]
$creadListPrec :: forall a b. (Read a, Read b) => ReadPrec [AppendLeft a b]
readPrec :: ReadPrec (AppendLeft a b)
$creadPrec :: forall a b. (Read a, Read b) => ReadPrec (AppendLeft a b)
readList :: ReadS [AppendLeft a b]
$creadList :: forall a b. (Read a, Read b) => ReadS [AppendLeft a b]
readsPrec :: Int -> ReadS (AppendLeft a b)
$creadsPrec :: forall a b. (Read a, Read b) => Int -> ReadS (AppendLeft a b)
Read, Int -> AppendLeft a b -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> AppendLeft a b -> ShowS
forall a b. (Show a, Show b) => [AppendLeft a b] -> ShowS
forall a b. (Show a, Show b) => AppendLeft a b -> String
showList :: [AppendLeft a b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [AppendLeft a b] -> ShowS
show :: AppendLeft a b -> String
$cshow :: forall a b. (Show a, Show b) => AppendLeft a b -> String
showsPrec :: Int -> AppendLeft a b -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> AppendLeft a b -> ShowS
Show)

instance PartialSemigroup a => PartialSemigroup (AppendLeft a b) where
  AppendLeft (Left a
x) <>? :: AppendLeft a b -> AppendLeft a b -> Maybe (AppendLeft a b)
<>? AppendLeft (Left a
y) =
    forall a b. Either a b -> AppendLeft a b
AppendLeft forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a
x forall a. PartialSemigroup a => a -> a -> Maybe a
<>? a
y)
  AppendLeft a b
_ <>? AppendLeft a b
_ = forall a. Maybe a
Nothing

--------------------------------------------------------------------------------

-- | A wrapper for 'Either' where the 'PartialSemigroup' operator is defined
-- only over 'Right' values.
--
-- ==== Examples
--
-- Two 'Right's make a 'Just'.
--
-- >>> AppendRight (Right "ab") <>? AppendRight (Right "cd")
-- Just (AppendRight {unAppendRight = Right "abcd"})
--
-- Anything else produces 'Nothing'
--
-- >>> AppendRight (Left "ab") <>? AppendRight (Left "cd")
-- Nothing
--
-- 'groupAndConcat' combines consecutive 'Right' values, leaving the 'Left' values
-- unmodified.
--
-- >>> xs = [Left "a", Left "b", Right "c", Right "d", Left "e", Left "f"]
-- >>> fmap unAppendRight . groupAndConcat . fmap AppendRight $ xs
-- [Left "a",Left "b",Right "cd",Left "e",Left "f"]
newtype AppendRight a b = AppendRight {forall a b. AppendRight a b -> Either a b
unAppendRight :: Either a b}
  deriving (AppendRight a b -> AppendRight a b -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b.
(Eq a, Eq b) =>
AppendRight a b -> AppendRight a b -> Bool
/= :: AppendRight a b -> AppendRight a b -> Bool
$c/= :: forall a b.
(Eq a, Eq b) =>
AppendRight a b -> AppendRight a b -> Bool
== :: AppendRight a b -> AppendRight a b -> Bool
$c== :: forall a b.
(Eq a, Eq b) =>
AppendRight a b -> AppendRight a b -> Bool
Eq, AppendRight a b -> AppendRight a b -> Bool
AppendRight a b -> AppendRight a b -> Ordering
AppendRight a b -> AppendRight a b -> AppendRight a b
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a} {b}. (Ord a, Ord b) => Eq (AppendRight a b)
forall a b.
(Ord a, Ord b) =>
AppendRight a b -> AppendRight a b -> Bool
forall a b.
(Ord a, Ord b) =>
AppendRight a b -> AppendRight a b -> Ordering
forall a b.
(Ord a, Ord b) =>
AppendRight a b -> AppendRight a b -> AppendRight a b
min :: AppendRight a b -> AppendRight a b -> AppendRight a b
$cmin :: forall a b.
(Ord a, Ord b) =>
AppendRight a b -> AppendRight a b -> AppendRight a b
max :: AppendRight a b -> AppendRight a b -> AppendRight a b
$cmax :: forall a b.
(Ord a, Ord b) =>
AppendRight a b -> AppendRight a b -> AppendRight a b
>= :: AppendRight a b -> AppendRight a b -> Bool
$c>= :: forall a b.
(Ord a, Ord b) =>
AppendRight a b -> AppendRight a b -> Bool
> :: AppendRight a b -> AppendRight a b -> Bool
$c> :: forall a b.
(Ord a, Ord b) =>
AppendRight a b -> AppendRight a b -> Bool
<= :: AppendRight a b -> AppendRight a b -> Bool
$c<= :: forall a b.
(Ord a, Ord b) =>
AppendRight a b -> AppendRight a b -> Bool
< :: AppendRight a b -> AppendRight a b -> Bool
$c< :: forall a b.
(Ord a, Ord b) =>
AppendRight a b -> AppendRight a b -> Bool
compare :: AppendRight a b -> AppendRight a b -> Ordering
$ccompare :: forall a b.
(Ord a, Ord b) =>
AppendRight a b -> AppendRight a b -> Ordering
Ord, ReadPrec [AppendRight a b]
ReadPrec (AppendRight a b)
ReadS [AppendRight a b]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall a b. (Read a, Read b) => ReadPrec [AppendRight a b]
forall a b. (Read a, Read b) => ReadPrec (AppendRight a b)
forall a b. (Read a, Read b) => Int -> ReadS (AppendRight a b)
forall a b. (Read a, Read b) => ReadS [AppendRight a b]
readListPrec :: ReadPrec [AppendRight a b]
$creadListPrec :: forall a b. (Read a, Read b) => ReadPrec [AppendRight a b]
readPrec :: ReadPrec (AppendRight a b)
$creadPrec :: forall a b. (Read a, Read b) => ReadPrec (AppendRight a b)
readList :: ReadS [AppendRight a b]
$creadList :: forall a b. (Read a, Read b) => ReadS [AppendRight a b]
readsPrec :: Int -> ReadS (AppendRight a b)
$creadsPrec :: forall a b. (Read a, Read b) => Int -> ReadS (AppendRight a b)
Read, Int -> AppendRight a b -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> AppendRight a b -> ShowS
forall a b. (Show a, Show b) => [AppendRight a b] -> ShowS
forall a b. (Show a, Show b) => AppendRight a b -> String
showList :: [AppendRight a b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [AppendRight a b] -> ShowS
show :: AppendRight a b -> String
$cshow :: forall a b. (Show a, Show b) => AppendRight a b -> String
showsPrec :: Int -> AppendRight a b -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> AppendRight a b -> ShowS
Show)

instance PartialSemigroup b => PartialSemigroup (AppendRight a b) where
  AppendRight (Right b
x) <>? :: AppendRight a b -> AppendRight a b -> Maybe (AppendRight a b)
<>? AppendRight (Right b
y) =
    forall a b. Either a b -> AppendRight a b
AppendRight forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (b
x forall a. PartialSemigroup a => a -> a -> Maybe a
<>? b
y)
  AppendRight a b
_ <>? AppendRight a b
_ = forall a. Maybe a
Nothing

--------------------------------------------------------------------------------

-- $refusing
--
-- These are 'PartialSemigroup' instances that don't really combine their values
-- at all; whenever more than one thing is present, '<>?' fails.

-- | A partial semigroup operation which always fails.
newtype One a = One {forall a. One a -> a
theOne :: a}
  deriving (One a -> One a -> Bool
forall a. Eq a => One a -> One a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: One a -> One a -> Bool
$c/= :: forall a. Eq a => One a -> One a -> Bool
== :: One a -> One a -> Bool
$c== :: forall a. Eq a => One a -> One a -> Bool
Eq, One a -> One a -> Bool
One a -> One a -> Ordering
One a -> One a -> One a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (One a)
forall a. Ord a => One a -> One a -> Bool
forall a. Ord a => One a -> One a -> Ordering
forall a. Ord a => One a -> One a -> One a
min :: One a -> One a -> One a
$cmin :: forall a. Ord a => One a -> One a -> One a
max :: One a -> One a -> One a
$cmax :: forall a. Ord a => One a -> One a -> One a
>= :: One a -> One a -> Bool
$c>= :: forall a. Ord a => One a -> One a -> Bool
> :: One a -> One a -> Bool
$c> :: forall a. Ord a => One a -> One a -> Bool
<= :: One a -> One a -> Bool
$c<= :: forall a. Ord a => One a -> One a -> Bool
< :: One a -> One a -> Bool
$c< :: forall a. Ord a => One a -> One a -> Bool
compare :: One a -> One a -> Ordering
$ccompare :: forall a. Ord a => One a -> One a -> Ordering
Ord, ReadPrec [One a]
ReadPrec (One a)
ReadS [One a]
forall a. Read a => ReadPrec [One a]
forall a. Read a => ReadPrec (One a)
forall a. Read a => Int -> ReadS (One a)
forall a. Read a => ReadS [One a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [One a]
$creadListPrec :: forall a. Read a => ReadPrec [One a]
readPrec :: ReadPrec (One a)
$creadPrec :: forall a. Read a => ReadPrec (One a)
readList :: ReadS [One a]
$creadList :: forall a. Read a => ReadS [One a]
readsPrec :: Int -> ReadS (One a)
$creadsPrec :: forall a. Read a => Int -> ReadS (One a)
Read, Int -> One a -> ShowS
forall a. Show a => Int -> One a -> ShowS
forall a. Show a => [One a] -> ShowS
forall a. Show a => One a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [One a] -> ShowS
$cshowList :: forall a. Show a => [One a] -> ShowS
show :: One a -> String
$cshow :: forall a. Show a => One a -> String
showsPrec :: Int -> One a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> One a -> ShowS
Show)

instance PartialSemigroup (One a) where
  One a
_ <>? :: One a -> One a -> Maybe (One a)
<>? One a
_ = forall a. Maybe a
Nothing

-- | A wrapper for 'Maybe' whose partial semigroup operation fails when two
-- 'Just's are combined.
newtype AtMostOne a = AtMostOne {forall a. AtMostOne a -> Maybe a
theOneMaybe :: Maybe a}
  deriving (AtMostOne a -> AtMostOne a -> Bool
forall a. Eq a => AtMostOne a -> AtMostOne a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AtMostOne a -> AtMostOne a -> Bool
$c/= :: forall a. Eq a => AtMostOne a -> AtMostOne a -> Bool
== :: AtMostOne a -> AtMostOne a -> Bool
$c== :: forall a. Eq a => AtMostOne a -> AtMostOne a -> Bool
Eq, AtMostOne a -> AtMostOne a -> Bool
AtMostOne a -> AtMostOne a -> Ordering
AtMostOne a -> AtMostOne a -> AtMostOne a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (AtMostOne a)
forall a. Ord a => AtMostOne a -> AtMostOne a -> Bool
forall a. Ord a => AtMostOne a -> AtMostOne a -> Ordering
forall a. Ord a => AtMostOne a -> AtMostOne a -> AtMostOne a
min :: AtMostOne a -> AtMostOne a -> AtMostOne a
$cmin :: forall a. Ord a => AtMostOne a -> AtMostOne a -> AtMostOne a
max :: AtMostOne a -> AtMostOne a -> AtMostOne a
$cmax :: forall a. Ord a => AtMostOne a -> AtMostOne a -> AtMostOne a
>= :: AtMostOne a -> AtMostOne a -> Bool
$c>= :: forall a. Ord a => AtMostOne a -> AtMostOne a -> Bool
> :: AtMostOne a -> AtMostOne a -> Bool
$c> :: forall a. Ord a => AtMostOne a -> AtMostOne a -> Bool
<= :: AtMostOne a -> AtMostOne a -> Bool
$c<= :: forall a. Ord a => AtMostOne a -> AtMostOne a -> Bool
< :: AtMostOne a -> AtMostOne a -> Bool
$c< :: forall a. Ord a => AtMostOne a -> AtMostOne a -> Bool
compare :: AtMostOne a -> AtMostOne a -> Ordering
$ccompare :: forall a. Ord a => AtMostOne a -> AtMostOne a -> Ordering
Ord, ReadPrec [AtMostOne a]
ReadPrec (AtMostOne a)
ReadS [AtMostOne a]
forall a. Read a => ReadPrec [AtMostOne a]
forall a. Read a => ReadPrec (AtMostOne a)
forall a. Read a => Int -> ReadS (AtMostOne a)
forall a. Read a => ReadS [AtMostOne a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [AtMostOne a]
$creadListPrec :: forall a. Read a => ReadPrec [AtMostOne a]
readPrec :: ReadPrec (AtMostOne a)
$creadPrec :: forall a. Read a => ReadPrec (AtMostOne a)
readList :: ReadS [AtMostOne a]
$creadList :: forall a. Read a => ReadS [AtMostOne a]
readsPrec :: Int -> ReadS (AtMostOne a)
$creadsPrec :: forall a. Read a => Int -> ReadS (AtMostOne a)
Read, Int -> AtMostOne a -> ShowS
forall a. Show a => Int -> AtMostOne a -> ShowS
forall a. Show a => [AtMostOne a] -> ShowS
forall a. Show a => AtMostOne a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AtMostOne a] -> ShowS
$cshowList :: forall a. Show a => [AtMostOne a] -> ShowS
show :: AtMostOne a -> String
$cshow :: forall a. Show a => AtMostOne a -> String
showsPrec :: Int -> AtMostOne a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> AtMostOne a -> ShowS
Show)

instance PartialSemigroup (AtMostOne a) where
  AtMostOne Maybe a
Nothing <>? :: AtMostOne a -> AtMostOne a -> Maybe (AtMostOne a)
<>? AtMostOne a
x = forall a. a -> Maybe a
Just AtMostOne a
x
  AtMostOne a
x <>? AtMostOne Maybe a
Nothing = forall a. a -> Maybe a
Just AtMostOne a
x
  AtMostOne a
_ <>? AtMostOne a
_ = forall a. Maybe a
Nothing