{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeSynonymInstances  #-}

{- |

The 'MultiInstance' module provides alternative versions of common typeclasses,
augmented with a phantom type parameter @x@. The purpose of this is to deal with
the case where a type has more than one candidate instance for the original,
unaugmented class.

= Example: Integer sum and product

The canonical example of this predicament is selecting the monoid instance for a
type which forms a ring (and thus has at least two strong candidates for
selection as /the/ monoid), such as 'Integer'. This therefore gives rise to the
'Data.Functor.Sum' and 'Data.Functor.Product' newtype wrappers, corresponding to
the additive and multiplicative monoids respectively.

The traditional 'Data.Foldable.fold'-based summation of a list of integers
looks like this:

>>> import Data.Foldable (fold)
>>> import Data.Monoid (Sum (..))
>>> getSum (fold [Sum 2, Sum 3, Sum 5]) :: Integer
10

By replacing 'Data.Foldable.fold' with 'multi'fold', whose constraint is
'MultiMonoid' rather than 'Data.Monoid.Monoid', we can write the same thing
without the newtype wrapper:

>>> :set -XFlexibleContexts -XTypeApplications
>>> multi'fold @Addition [2, 3, 5] :: Integer
10

= The typeclasses

The current list of "multi-instance" typeclasses:

- 'MultiSemigroup'
- 'MultiMonoid'

= The phantom types

The current list of phantom types used for the @x@ type parameter:

- 'Default'
- 'Conjunction'
- 'Disjunction'
- 'Addition' (alias for 'Disjunction')
- 'Multiplication' (alias for 'Conjunction')
- 'And' (alias for 'Conjunction')
- 'Or' (alias for 'Disjunction')
- 'Min'
- 'Max'
- 'MinMaybe'
- 'MaxMaybe'
- 'First'
- 'Last'
- 'ArrowComposition'
- 'MultiDual'

-}

module MultiInstance
  (
  -- * Semigroup
    MultiSemigroup (multi'append, multi'sconcat, multi'stimes)
  -- * Monoid
  , MultiMonoid (multi'empty, multi'mconcat)
  -- * Default
  , Default
  -- * Conjunction and disjunction
  , Conjunction, Disjunction
  -- * Addition and multiplication
  , Addition, Multiplication, multi'sum, multi'product
  -- * Boolean /and/ and /or/
  , And, Or, multi'and, multi'or, multi'any, multi'all
  -- * Min and max
  , Min, Max, MinMaybe, MaxMaybe
  -- * First and last
  , First, Last
  -- * Arrow composition
  , ArrowComposition
  -- * Dual
  , MultiDual
  -- * Monoidal folds
  , multi'fold, multi'foldMap
  -- * Looking for elements
  , multi'find
  ) where

import Control.Arrow      (Kleisli)
import Control.Category   (id, (.))
import Control.Monad      (Monad)
import Data.Bool          (Bool (..), otherwise, (&&), (||))
import Data.Eq            (Eq (..))
import Data.Foldable      (Foldable)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe         (Maybe (..))
import Data.Ord           (Ord (..))
import Numeric.Natural    (Natural)
import Prelude            (Int, Integer, Integral, Num (..),
                           errorWithoutStackTrace, even, pred, quot)

import qualified Data.Foldable
import qualified Data.Monoid
import qualified Data.Semigroup


--------------------------------------------------------------------------------
--  Semigroup
--------------------------------------------------------------------------------

-- | Akin to the 'Data.Semigroup.Semigroup' class, but with the addition of the
-- phantom type parameter @x@ which lets you specify /which/ semigroup to use.
--
-- For example, the integers form a semigroup via either 'Addition' or
-- 'Multiplication':
--
-- >>> :set -XFlexibleContexts -XTypeApplications
-- >>> multi'append @Addition 6 7 :: Integer
-- 13
-- >>> multi'append @Multiplication 6 7 :: Integer
-- 42
-- >>> multi'stimes @Addition (3 :: Natural) (4 :: Integer)
-- 12
-- >>> multi'stimes @Multiplication (3 :: Natural) (4 :: Integer)
-- 64
class MultiSemigroup x a where

  -- | An associative operation.
  --
  -- /Akin to 'Data.Semigroup.<>'./
  multi'append :: a -> a -> a

  -- | Reduce a non-empty list with 'multi'append'.
  --
  -- /Akin to 'Data.Semigroup.sconcat'./
  multi'sconcat :: NonEmpty a -> a
  multi'sconcat (a
a :| [a]
as) = a -> [a] -> a
forall t. MultiSemigroup x t => t -> [t] -> t
go a
a [a]
as where
    go :: t -> [t] -> t
go t
b (t
c:[t]
cs) = t -> t -> t
forall x a. MultiSemigroup x a => a -> a -> a
multi'append @x t
b (t -> [t] -> t
go t
c [t]
cs)
    go t
b []     = t
b

  -- | Repeat a value @n@ times.
  --
  -- /Akin to 'Data.Semigroup.stimes'./
  multi'stimes :: Integral b => b -> a -> a
  multi'stimes b
y0 a
x0
    | b
y0 b -> b -> Bool
forall a. Ord a => a -> a -> Bool
<= b
0   = [Char] -> a
forall a. [Char] -> a
errorWithoutStackTrace
                    [Char]
"multi'stimes: positive multiplier expected"
    | Bool
otherwise = a -> b -> a
forall a a. (Integral a, MultiSemigroup x a) => a -> a -> a
f a
x0 b
y0
    where
      f :: a -> a -> a
f a
x a
y
        | a -> Bool
forall a. Integral a => a -> Bool
even a
y    = a -> a -> a
f (a -> a -> a
forall x a. MultiSemigroup x a => a -> a -> a
multi'append @x a
x a
x) (a
y a -> a -> a
forall a. Integral a => a -> a -> a
`quot` a
2)
        | a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1    = a
x
        | Bool
otherwise = a -> a -> a -> a
forall a a. (Integral a, MultiSemigroup x a) => a -> a -> a -> a
g (a -> a -> a
forall x a. MultiSemigroup x a => a -> a -> a
multi'append @x a
x a
x) (a -> a
forall a. Enum a => a -> a
pred a
y a -> a -> a
forall a. Integral a => a -> a -> a
`quot` a
2) a
x
      g :: a -> a -> a -> a
g a
x a
y a
z
        | a -> Bool
forall a. Integral a => a -> Bool
even a
y    = a -> a -> a -> a
g (a -> a -> a
forall x a. MultiSemigroup x a => a -> a -> a
multi'append @x a
x a
x) (a
y a -> a -> a
forall a. Integral a => a -> a -> a
`quot` a
2) a
z
        | a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1    = a -> a -> a
forall x a. MultiSemigroup x a => a -> a -> a
multi'append @x a
x a
z
        | Bool
otherwise = a -> a -> a -> a
g (a -> a -> a
forall x a. MultiSemigroup x a => a -> a -> a
multi'append @x a
x a
x) (a -> a
forall a. Enum a => a -> a
pred a
y a -> a -> a
forall a. Integral a => a -> a -> a
`quot` a
2)
                        (a -> a -> a
forall x a. MultiSemigroup x a => a -> a -> a
multi'append @x a
x a
z)


--------------------------------------------------------------------------------
--  Monoid
--------------------------------------------------------------------------------

-- | Akin to the 'Data.Monoid.Monoid' class, but with the addition of the
-- phantom type parameter @x@ which lets you specify /which/ monoid to use.
--
-- For example, the integers form a monoid via either 'Addition' or
-- 'Multiplication':
--
-- >>> :set -XFlexibleContexts -XTypeApplications
-- >>> multi'fold @Addition [] :: Integer
-- 0
-- >>> multi'fold @Addition [2, 3, 5] :: Integer
-- 10
-- >>> multi'fold @Multiplication [] :: Integer
-- 1
-- >>> multi'fold @Multiplication [2, 3, 5] :: Integer
-- 30
class MultiSemigroup x a => MultiMonoid x a where

  -- | Identity of 'multi'append'.
  --
  -- /Akin to 'Data.Monoid.mempty'./
  multi'empty :: a

  -- | Fold a list using the monoid.
  --
  -- /Akin to 'Data.Monoid.mconcat'./
  multi'mconcat :: [a] -> a
  multi'mconcat = (a -> a -> a) -> a -> [a] -> a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
Data.Foldable.foldr (forall a. MultiSemigroup x a => a -> a -> a
forall x a. MultiSemigroup x a => a -> a -> a
multi'append @x) (forall a. MultiMonoid x a => a
forall x a. MultiMonoid x a => a
multi'empty @x)


--------------------------------------------------------------------------------
--  Foldable
--------------------------------------------------------------------------------

-- | Combine the elements of a structure using a monoid.
--
-- /Akin to 'Data.Foldable.fold'./
multi'fold :: forall x t m. (MultiMonoid x m, Foldable t) => t m -> m
multi'fold :: t m -> m
multi'fold = (m -> m) -> t m -> m
forall x (t :: * -> *) m a.
(MultiMonoid x m, Foldable t) =>
(a -> m) -> t a -> m
multi'foldMap @x m -> m
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

-- | Map each element of the structure to a monoid, and combine the results.
--
-- /Akin to 'Data.Foldable.foldMap'./
multi'foldMap :: forall x t m a. (MultiMonoid x m, Foldable t)
              => (a -> m) -> t a -> m
multi'foldMap :: (a -> m) -> t a -> m
multi'foldMap a -> m
f = (a -> m -> m) -> m -> t a -> m
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
Data.Foldable.foldr (forall a. MultiSemigroup x a => a -> a -> a
forall x a. MultiSemigroup x a => a -> a -> a
multi'append @x (m -> m -> m) -> (a -> m) -> a -> m -> m
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> m
f) (forall a. MultiMonoid x a => a
forall x a. MultiMonoid x a => a
multi'empty @x)

-- | The sum of the numbers in a structure.
--
-- /Equivalent to @'multi'fold' \@'Addition'@./
--
-- /Akin to 'Data.Foldable.sum'./
multi'sum :: (Foldable t, MultiMonoid Addition a) => t a -> a
multi'sum :: t a -> a
multi'sum = forall x (t :: * -> *) m. (MultiMonoid x m, Foldable t) => t m -> m
forall (t :: * -> *) m.
(MultiMonoid Addition m, Foldable t) =>
t m -> m
multi'fold @Addition

-- | The product of the numbers of a structure.
--
-- /Equivalent to @'multi'fold' \@'Multiplication'@./
--
-- /Akin to 'Data.Foldable.product'./
multi'product :: (Foldable t, MultiMonoid Multiplication a) => t a -> a
multi'product :: t a -> a
multi'product = forall x (t :: * -> *) m. (MultiMonoid x m, Foldable t) => t m -> m
forall (t :: * -> *) m.
(MultiMonoid Multiplication m, Foldable t) =>
t m -> m
multi'fold @Multiplication

-- | The conjunction of a container of Bools.
--
-- /Equivalent to @'multi'fold' \@'And'@./
--
-- /Akin to 'Data.Foldable.and'./
multi'and :: (Foldable t, MultiMonoid And a) => t a -> a
multi'and :: t a -> a
multi'and = forall x (t :: * -> *) m. (MultiMonoid x m, Foldable t) => t m -> m
forall (t :: * -> *) m.
(MultiMonoid Multiplication m, Foldable t) =>
t m -> m
multi'fold @And

-- | The disjunction of a container of Bools.
--
-- /Equivalent to @'multi'fold' \@'Or'@./
--
-- /Akin to 'Data.Foldable.or'./
multi'or :: (Foldable t, MultiMonoid Or a) => t a -> a
multi'or :: t a -> a
multi'or = forall x (t :: * -> *) m. (MultiMonoid x m, Foldable t) => t m -> m
forall (t :: * -> *) m.
(MultiMonoid Addition m, Foldable t) =>
t m -> m
multi'fold @Or

-- | Determines whether any element of the structure satisfies the predicate.
--
-- /Equivalent to @'multi'foldMap' \@'Or'@./
--
-- /Akin to 'Data.Foldable.any'./
multi'any :: (Foldable t, MultiMonoid Or b) => (a -> b) -> t a -> b
multi'any :: (a -> b) -> t a -> b
multi'any = forall x (t :: * -> *) m a.
(MultiMonoid x m, Foldable t) =>
(a -> m) -> t a -> m
forall (t :: * -> *) m a.
(MultiMonoid Addition m, Foldable t) =>
(a -> m) -> t a -> m
multi'foldMap @Or

-- | Determines whether all elements of the structure satisfy the predicate.
--
-- /Equivalent to @'multi'foldMap' \@'And'@./
--
-- /Akin to 'Data.Foldable.all'./
multi'all :: Foldable t => (a -> Bool) -> t a -> Bool
multi'all :: (a -> Bool) -> t a -> Bool
multi'all = forall x (t :: * -> *) m a.
(MultiMonoid x m, Foldable t) =>
(a -> m) -> t a -> m
forall (t :: * -> *) m a.
(MultiMonoid Multiplication m, Foldable t) =>
(a -> m) -> t a -> m
multi'foldMap @And

-- | Takes a predicate and a structure and returns the leftmost element of the
-- structure matching the predicate, or 'Nothing' if there is no such element.
--
-- /Akin to 'Data.Foldable.find'./
multi'find :: Foldable t => (a -> Bool) -> t a -> Maybe a
multi'find :: (a -> Bool) -> t a -> Maybe a
multi'find a -> Bool
p = (a -> Maybe a) -> t a -> Maybe a
forall x (t :: * -> *) m a.
(MultiMonoid x m, Foldable t) =>
(a -> m) -> t a -> m
multi'foldMap @First (\a
x -> if a -> Bool
p a
x then a -> Maybe a
forall a. a -> Maybe a
Just a
x else Maybe a
forall a. Maybe a
Nothing)


--------------------------------------------------------------------------------
--  Unit
--------------------------------------------------------------------------------

instance MultiSemigroup x ()
  where multi'append :: () -> () -> ()
multi'append ()
_ ()
_ = ()

instance MultiMonoid x ()
  where multi'empty :: ()
multi'empty = ()


--------------------------------------------------------------------------------
--  Default
--------------------------------------------------------------------------------

data Default

instance Data.Semigroup.Semigroup a => MultiSemigroup Default a
  where multi'append :: a -> a -> a
multi'append = a -> a -> a
forall a. Semigroup a => a -> a -> a
(Data.Semigroup.<>)

instance (Data.Semigroup.Semigroup a, Data.Monoid.Monoid a) =>
    MultiMonoid Default a
  where multi'empty :: a
multi'empty = a
forall a. Monoid a => a
Data.Monoid.mempty


--------------------------------------------------------------------------------
--  Conjunction and disjunction
--------------------------------------------------------------------------------

data Conjunction

data Disjunction


--------------------------------------------------------------------------------
--  Boolean /and/ and /or/
--------------------------------------------------------------------------------

type And = Conjunction

type Or = Disjunction

instance MultiSemigroup And Bool
  where multi'append :: Bool -> Bool -> Bool
multi'append = Bool -> Bool -> Bool
(&&)
instance MultiMonoid And Bool
  where multi'empty :: Bool
multi'empty = Bool
True

instance MultiSemigroup Or Bool
  where multi'append :: Bool -> Bool -> Bool
multi'append = Bool -> Bool -> Bool
(||)
instance MultiMonoid Or Bool
  where multi'empty :: Bool
multi'empty = Bool
False


--------------------------------------------------------------------------------
--  Addition and multiplication
--------------------------------------------------------------------------------

type Addition = Disjunction

type Multiplication = Conjunction

instance MultiSemigroup Addition Int
  where multi'append :: Int -> Int -> Int
multi'append = Int -> Int -> Int
forall a. Num a => a -> a -> a
(+)
instance MultiSemigroup Addition Integer
  where multi'append :: Integer -> Integer -> Integer
multi'append = Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+)
instance MultiSemigroup Addition Natural
  where multi'append :: Natural -> Natural -> Natural
multi'append = Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
(+)

instance MultiMonoid Addition Int
  where multi'empty :: Int
multi'empty = Int
0
instance MultiMonoid Addition Integer
  where multi'empty :: Integer
multi'empty = Integer
0
instance MultiMonoid Addition Natural
  where multi'empty :: Natural
multi'empty = Natural
0

instance MultiSemigroup Multiplication Int
  where multi'append :: Int -> Int -> Int
multi'append = Int -> Int -> Int
forall a. Num a => a -> a -> a
(*)
instance MultiSemigroup Multiplication Integer
  where multi'append :: Integer -> Integer -> Integer
multi'append = Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*)
instance MultiSemigroup Multiplication Natural
  where multi'append :: Natural -> Natural -> Natural
multi'append = Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
(*)

instance MultiMonoid Multiplication Int
  where multi'empty :: Int
multi'empty = Int
1
instance MultiMonoid Multiplication Integer
  where multi'empty :: Integer
multi'empty = Integer
1
instance MultiMonoid Multiplication Natural
  where multi'empty :: Natural
multi'empty = Natural
1


--------------------------------------------------------------------------------
--  Min and Max
--------------------------------------------------------------------------------

data Min

data Max

instance Ord a => MultiSemigroup Min a
  where multi'append :: a -> a -> a
multi'append = a -> a -> a
forall a. Ord a => a -> a -> a
min
instance Ord a => MultiSemigroup Max a
  where multi'append :: a -> a -> a
multi'append = a -> a -> a
forall a. Ord a => a -> a -> a
max

data MinMaybe

data MaxMaybe

instance Ord a => MultiSemigroup MinMaybe (Maybe a)
  where multi'append :: Maybe a -> Maybe a -> Maybe a
multi'append Maybe a
Nothing Maybe a
x = Maybe a
x
        multi'append Maybe a
x Maybe a
Nothing = Maybe a
x
        multi'append (Just a
x) (Just a
y) = a -> Maybe a
forall a. a -> Maybe a
Just (a -> a -> a
forall a. Ord a => a -> a -> a
min a
x a
y)
instance Ord a => MultiMonoid MinMaybe (Maybe a)
  where multi'empty :: Maybe a
multi'empty = Maybe a
forall a. Maybe a
Nothing

instance Ord a => MultiSemigroup MaxMaybe (Maybe a)
  where multi'append :: Maybe a -> Maybe a -> Maybe a
multi'append Maybe a
Nothing Maybe a
x = Maybe a
x
        multi'append Maybe a
x Maybe a
Nothing = Maybe a
x
        multi'append (Just a
x) (Just a
y) = a -> Maybe a
forall a. a -> Maybe a
Just (a -> a -> a
forall a. Ord a => a -> a -> a
max a
x a
y)
instance Ord a => MultiMonoid MaxMaybe (Maybe a)
  where multi'empty :: Maybe a
multi'empty = Maybe a
forall a. Maybe a
Nothing


--------------------------------------------------------------------------------
--  First and last
--------------------------------------------------------------------------------

data First

data Last

instance MultiSemigroup First (Maybe a)
  where multi'append :: Maybe a -> Maybe a -> Maybe a
multi'append x :: Maybe a
x@(Just a
_) Maybe a
_ = Maybe a
x
        multi'append Maybe a
_          Maybe a
x = Maybe a
x

instance MultiMonoid First (Maybe a)
  where multi'empty :: Maybe a
multi'empty = Maybe a
forall a. Maybe a
Nothing

instance MultiSemigroup Last (Maybe a)
  where multi'append :: Maybe a -> Maybe a -> Maybe a
multi'append Maybe a
_ x :: Maybe a
x@(Just a
_) = Maybe a
x
        multi'append Maybe a
x          Maybe a
_ = Maybe a
x

instance MultiMonoid Last (Maybe a)
  where multi'empty :: Maybe a
multi'empty = Maybe a
forall a. Maybe a
Nothing


--------------------------------------------------------------------------------
--  Arrow composition
--------------------------------------------------------------------------------

data ArrowComposition

instance MultiSemigroup ArrowComposition (a -> a)
  where multi'append :: (a -> a) -> (a -> a) -> a -> a
multi'append = (a -> a) -> (a -> a) -> a -> a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
(.)
instance MultiMonoid ArrowComposition (a -> a)
  where multi'empty :: a -> a
multi'empty  = a -> a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

instance Monad m => MultiSemigroup ArrowComposition (Kleisli m a a)
  where multi'append :: Kleisli m a a -> Kleisli m a a -> Kleisli m a a
multi'append = Kleisli m a a -> Kleisli m a a -> Kleisli m a a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
(.)
instance Monad m => MultiMonoid ArrowComposition (Kleisli m a a)
  where multi'empty :: Kleisli m a a
multi'empty  = Kleisli m a a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id


--------------------------------------------------------------------------------
--  List
--------------------------------------------------------------------------------

instance MultiSemigroup Addition [a]
  where multi'append :: [a] -> [a] -> [a]
multi'append = forall a. MultiSemigroup Default a => a -> a -> a
forall x a. MultiSemigroup x a => a -> a -> a
multi'append @Default
instance MultiMonoid Addition [a]
  where multi'empty :: [a]
multi'empty = forall a. MultiMonoid Default a => a
forall x a. MultiMonoid x a => a
multi'empty @Default

instance MultiSemigroup Addition (NonEmpty a)
  where multi'append :: NonEmpty a -> NonEmpty a -> NonEmpty a
multi'append = forall a. MultiSemigroup Default a => a -> a -> a
forall x a. MultiSemigroup x a => a -> a -> a
multi'append @Default


--------------------------------------------------------------------------------
--  Dual
--------------------------------------------------------------------------------

data MultiDual a

instance MultiSemigroup x a => MultiSemigroup (MultiDual x) a
  where multi'append :: a -> a -> a
multi'append a
a a
b = a -> a -> a
forall x a. MultiSemigroup x a => a -> a -> a
multi'append @x a
b a
a
instance MultiMonoid x a => MultiMonoid (MultiDual x) a
  where multi'empty :: a
multi'empty = forall a. MultiMonoid x a => a
forall x a. MultiMonoid x a => a
multi'empty @x