{-# LANGUAGE CPP          #-}
{-# LANGUAGE TypeFamilies #-}

-- 'Option' will be removed in 'ghc-9.2'.
{-# OPTIONS_GHC -Wno-deprecations #-}

module Data.Semigroup.Abelian
    ( AbelianSemigroup
    , FreeAbelianSemigroup
    , toNonEmpty
    , fromNonEmpty
    ) where

import           Data.IntSet (IntSet)
import           Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.Set (Set)
import           Data.Semigroup
                    ( All
                    , Any
                    , Dual
                    , Max
                    , Min
#if __GLASGOW_HASKELL__ < 902
                    , Option
#endif
                    , Product
                    , Sum
                    )
import           Data.Void (Void)
import           Numeric.Natural (Natural)

import           Data.Algebra.Free
                    ( AlgebraType
                    , AlgebraType0
                    , FreeAlgebra (..)
                    )

-- | Class of commutative monoids, e.g. with additional law:
-- @
--  a <> b = b <> a
-- @
--
class Semigroup m => AbelianSemigroup m

instance AbelianSemigroup Void

instance AbelianSemigroup ()

instance AbelianSemigroup All

instance AbelianSemigroup Any

instance AbelianSemigroup a => AbelianSemigroup (Dual a)

instance Ord a => AbelianSemigroup (Max a)

instance Ord a => AbelianSemigroup (Min a)

instance AbelianSemigroup a => AbelianSemigroup (Maybe a)
#if __GLASGOW_HASKELL__ < 902
instance AbelianSemigroup a => AbelianSemigroup (Option a)
#endif

instance Num a => AbelianSemigroup (Product a)

instance Num a => AbelianSemigroup (Sum a)

instance Ord a => AbelianSemigroup (Set a)

instance AbelianSemigroup IntSet

-- | Free abelian semigroup is isomorphic to a non empty map with keys @a@ and
-- values positive natural numbers.
--
-- It is a monad on the full subcategory which satisfies the `Ord` constraint,
-- but base does not allow to define a functor \/ applicative \/ monad
-- instances which are constraint by a class.
--
newtype FreeAbelianSemigroup a = FreeAbelianSemigroup (Map a Natural)
    deriving (FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Ordering
FreeAbelianSemigroup a
-> FreeAbelianSemigroup a -> FreeAbelianSemigroup 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 (FreeAbelianSemigroup a)
forall a.
Ord a =>
FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
forall a.
Ord a =>
FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Ordering
forall a.
Ord a =>
FreeAbelianSemigroup a
-> FreeAbelianSemigroup a -> FreeAbelianSemigroup a
min :: FreeAbelianSemigroup a
-> FreeAbelianSemigroup a -> FreeAbelianSemigroup a
$cmin :: forall a.
Ord a =>
FreeAbelianSemigroup a
-> FreeAbelianSemigroup a -> FreeAbelianSemigroup a
max :: FreeAbelianSemigroup a
-> FreeAbelianSemigroup a -> FreeAbelianSemigroup a
$cmax :: forall a.
Ord a =>
FreeAbelianSemigroup a
-> FreeAbelianSemigroup a -> FreeAbelianSemigroup a
>= :: FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
$c>= :: forall a.
Ord a =>
FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
> :: FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
$c> :: forall a.
Ord a =>
FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
<= :: FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
$c<= :: forall a.
Ord a =>
FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
< :: FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
$c< :: forall a.
Ord a =>
FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
compare :: FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Ordering
$ccompare :: forall a.
Ord a =>
FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Ordering
Ord, FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
forall a.
Eq a =>
FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
$c/= :: forall a.
Eq a =>
FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
== :: FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
$c== :: forall a.
Eq a =>
FreeAbelianSemigroup a -> FreeAbelianSemigroup a -> Bool
Eq, Int -> FreeAbelianSemigroup a -> ShowS
forall a. Show a => Int -> FreeAbelianSemigroup a -> ShowS
forall a. Show a => [FreeAbelianSemigroup a] -> ShowS
forall a. Show a => FreeAbelianSemigroup a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FreeAbelianSemigroup a] -> ShowS
$cshowList :: forall a. Show a => [FreeAbelianSemigroup a] -> ShowS
show :: FreeAbelianSemigroup a -> String
$cshow :: forall a. Show a => FreeAbelianSemigroup a -> String
showsPrec :: Int -> FreeAbelianSemigroup a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> FreeAbelianSemigroup a -> ShowS
Show)

toNonEmpty :: FreeAbelianSemigroup a -> NonEmpty (a, Natural)
toNonEmpty :: forall a. FreeAbelianSemigroup a -> NonEmpty (a, Natural)
toNonEmpty (FreeAbelianSemigroup Map a Natural
as) = forall a. [a] -> NonEmpty a
NE.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ Map a Natural
as

-- | Smart constructor which creates `FreeAbelianSemigroup` from a non empty
-- list of pairs @(a, n) :: (a, Natural)@ where @n > 0@.
--
fromNonEmpty :: Ord a => NonEmpty (a, Natural) -> Maybe (FreeAbelianSemigroup a)
fromNonEmpty :: forall a.
Ord a =>
NonEmpty (a, Natural) -> Maybe (FreeAbelianSemigroup a)
fromNonEmpty = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Map a Natural -> FreeAbelianSemigroup a
FreeAbelianSemigroup forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b} {a}. (Eq b, Num b) => [(a, b)] -> Maybe [(a, b)]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NE.toList
    where
    go :: [(a, b)] -> Maybe [(a, b)]
go []            = forall a. a -> Maybe a
Just []
    go ((a
a, b
n) : [(a, b)]
as) | b
n forall a. Eq a => a -> a -> Bool
== b
0    = forall a. Maybe a
Nothing
                     | Bool
otherwise = ((a
a, b
n) forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, b)] -> Maybe [(a, b)]
go [(a, b)]
as

instance Ord a => Semigroup (FreeAbelianSemigroup a) where
    (FreeAbelianSemigroup Map a Natural
a) <> :: FreeAbelianSemigroup a
-> FreeAbelianSemigroup a -> FreeAbelianSemigroup a
<> (FreeAbelianSemigroup Map a Natural
b) = forall a. Map a Natural -> FreeAbelianSemigroup a
FreeAbelianSemigroup forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Num a => a -> a -> a
(+) Map a Natural
a Map a Natural
b

instance Ord a => AbelianSemigroup (FreeAbelianSemigroup a)

type instance AlgebraType0 FreeAbelianSemigroup a = Ord a
type instance AlgebraType  FreeAbelianSemigroup a = (Ord a, AbelianSemigroup a)

instance FreeAlgebra FreeAbelianSemigroup where
    returnFree :: forall a. a -> FreeAbelianSemigroup a
returnFree a
a = forall a. Map a Natural -> FreeAbelianSemigroup a
FreeAbelianSemigroup forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton a
a Natural
1

    foldMapFree :: forall d a.
(AlgebraType FreeAbelianSemigroup d,
 AlgebraType0 FreeAbelianSemigroup a) =>
(a -> d) -> FreeAbelianSemigroup a -> d
foldMapFree a -> d
f (FreeAbelianSemigroup Map a Natural
as)
                 = forall (m :: * -> *) d a.
(FreeAlgebra m, AlgebraType m d, AlgebraType0 m a) =>
(a -> d) -> m a -> d
foldMapFree a -> d
f (forall a. Map a Natural -> NonEmpty a
toNonEmpty_ Map a Natural
as)
      where
        replicate_ :: a -> Natural -> [a]                                     
        replicate_ :: forall a. a -> Natural -> [a]
replicate_ a
_ Natural
n | Natural
n forall a. Ord a => a -> a -> Bool
<= Natural
0 = forall a. HasCallStack => String -> a
error String
"foldMapFree @FreeAbelianSemigroup: impossible"
        replicate_ a
a Natural
1 = [a
a]                                                   
        replicate_ a
a Natural
n = a
a forall a. a -> [a] -> [a]
: forall a. a -> Natural -> [a]
replicate_ a
a (Natural
n forall a. Num a => a -> a -> a
- Natural
1)                             

        toNonEmpty_ :: Map a Natural -> NonEmpty a
        toNonEmpty_ :: forall a. Map a Natural -> NonEmpty a
toNonEmpty_ = forall a. [a] -> NonEmpty a
NE.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. a -> Natural -> [a]
replicate_) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList