{-# LANGUAGE LambdaCase          #-}

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

  ) where

import Control.Applicative   (ZipList (..), (<*>))
import Data.Functor.Identity (Identity (..))
import Data.List.NonEmpty    (NonEmpty (..), nonEmpty)
import Data.Monoid           (Product (..), Sum (..))
import Data.Semigroup        (Semigroup (..))

-- $setup
--
-- >>> :set -XExtendedDefaultRules
-- >>> import Data.Monoid
-- >>> import Prelude

-- 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 => PartialSemigroup (Identity a)
  where
    Identity x <>? Identity y = Identity <$> (x <>? y)

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

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 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 =
  \case
    []         -> []
    [x]        -> [x]
    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 =
  \case
    x :| [] -> Just x
    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

instance Monoid a => Monoid (Partial a)
  where
    mappend (Partial (Just x)) (Partial (Just y)) =
      Partial (Just (mappend x y))
    mappend _ _ = Partial Nothing

    mempty = Partial (Just mempty)

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

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