-- | 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
  () <>? () = Just ()

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

instance PartialSemigroup [a] where
  x <>? y = Just (x <> y)

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

instance Num a => PartialSemigroup (Sum a) where
  x <>? y = Just (x <> y)

instance Num a => PartialSemigroup (Product a) where
  x <>? y = Just (x <> y)

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

instance PartialSemigroup a => PartialSemigroup (Identity a) where
  Identity x <>? Identity y = Identity <$> (x <>? y)

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

instance
  (PartialSemigroup a, PartialSemigroup b) =>
  PartialSemigroup (Either a b)
  where
  Left x <>? Left y = Left <$> (x <>? y)
  Right x <>? Right y = Right <$> (x <>? y)
  _ <>? _ = 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, b) <>? (a', b') =
    (,)
      <$> (a <>? a')
      <*> (b <>? b')

instance
  (PartialSemigroup a, PartialSemigroup b, PartialSemigroup c) =>
  PartialSemigroup (a, b, c)
  where
  (a, b, c) <>? (a', b', c') =
    (,,)
      <$> (a <>? a')
      <*> (b <>? b')
      <*> (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 [] = []
groupAndConcat [x] = [x]
groupAndConcat (x : y : zs) =
  case x <>? y of
    Nothing -> x : groupAndConcat (y : zs)
    Just a -> groupAndConcat (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 x =
  nonEmpty x >>= 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 (x :| []) = Just x
partialConcat1 (x :| (y : zs)) =
  do
    a <- x <>? y
    partialConcat1 (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 [] [] = Just []
partialZip [] _ = Nothing
partialZip _ [] = Nothing
partialZip (x : xs) (y : ys) =
  (:) <$> (x <>? y) <*> partialZip xs 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 (x :| xs) (y :| ys) =
  (:|) <$> (x <>? y) <*> partialZip xs ys

-- | 'partialZip'
instance PartialSemigroup a => PartialSemigroup (ZipList a) where
  ZipList x <>? ZipList y = ZipList <$> partialZip x 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 {unPartial :: Maybe a}
  deriving (Eq, Ord, Read, Show)

instance PartialSemigroup a => Semigroup (Partial a) where
  Partial (Just x) <> Partial (Just y) = Partial (x <>? y)
  _ <> _ = Partial 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 {unTotal :: a}
  deriving (Eq, Ord, Read, Show)

instance Semigroup a => PartialSemigroup (Total a) where
  Total x <>? Total y = Just (Total (x <> 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 {unAppendLeft :: Either a b}
  deriving (Eq, Ord, Read, Show)

instance PartialSemigroup a => PartialSemigroup (AppendLeft a b) where
  AppendLeft (Left x) <>? AppendLeft (Left y) =
    AppendLeft . Left <$> (x <>? y)
  _ <>? _ = 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 {unAppendRight :: Either a b}
  deriving (Eq, Ord, Read, Show)

instance PartialSemigroup b => PartialSemigroup (AppendRight a b) where
  AppendRight (Right x) <>? AppendRight (Right y) =
    AppendRight . Right <$> (x <>? y)
  _ <>? _ = 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 {theOne :: a}
  deriving (Eq, Ord, Read, Show)

instance PartialSemigroup (One a) where
  _ <>? _ = Nothing

-- | A wrapper for 'Maybe' whose partial semigroup operation fails when two
-- 'Just's are combined.
newtype AtMostOne a = AtMostOne {theOneMaybe :: Maybe a}
  deriving (Eq, Ord, Read, Show)

instance PartialSemigroup (AtMostOne a) where
  AtMostOne Nothing <>? x = Just x
  x <>? AtMostOne Nothing = Just x
  _ <>? _ = Nothing