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

module Data.Monoid.Abelian
    ( FreeAbelianMonoid (..)
    ) where

import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Semigroup (Semigroup (..), stimes)
import           Numeric.Natural (Natural)

import           Data.Algebra.Free (AlgebraType, AlgebraType0, FreeAlgebra (..))
import           Data.Semigroup.Abelian (AbelianSemigroup)

-- | Free abelian monoid.  Note that `FreeAbelianMonoid () ≅ Natural` as
-- expected.
--
-- 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 FreeAbelianMonoid a = FreeAbelianMonoid {
        forall a. FreeAbelianMonoid a -> Map a Natural
runFreeAbelianMonoid :: Map a Natural
    }
    deriving (FreeAbelianMonoid a -> FreeAbelianMonoid a -> Bool
forall a.
Eq a =>
FreeAbelianMonoid a -> FreeAbelianMonoid a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FreeAbelianMonoid a -> FreeAbelianMonoid a -> Bool
$c/= :: forall a.
Eq a =>
FreeAbelianMonoid a -> FreeAbelianMonoid a -> Bool
== :: FreeAbelianMonoid a -> FreeAbelianMonoid a -> Bool
$c== :: forall a.
Eq a =>
FreeAbelianMonoid a -> FreeAbelianMonoid a -> Bool
Eq, FreeAbelianMonoid a -> FreeAbelianMonoid a -> Bool
FreeAbelianMonoid a -> FreeAbelianMonoid a -> Ordering
FreeAbelianMonoid a -> FreeAbelianMonoid a -> FreeAbelianMonoid 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 (FreeAbelianMonoid a)
forall a.
Ord a =>
FreeAbelianMonoid a -> FreeAbelianMonoid a -> Bool
forall a.
Ord a =>
FreeAbelianMonoid a -> FreeAbelianMonoid a -> Ordering
forall a.
Ord a =>
FreeAbelianMonoid a -> FreeAbelianMonoid a -> FreeAbelianMonoid a
min :: FreeAbelianMonoid a -> FreeAbelianMonoid a -> FreeAbelianMonoid a
$cmin :: forall a.
Ord a =>
FreeAbelianMonoid a -> FreeAbelianMonoid a -> FreeAbelianMonoid a
max :: FreeAbelianMonoid a -> FreeAbelianMonoid a -> FreeAbelianMonoid a
$cmax :: forall a.
Ord a =>
FreeAbelianMonoid a -> FreeAbelianMonoid a -> FreeAbelianMonoid a
>= :: FreeAbelianMonoid a -> FreeAbelianMonoid a -> Bool
$c>= :: forall a.
Ord a =>
FreeAbelianMonoid a -> FreeAbelianMonoid a -> Bool
> :: FreeAbelianMonoid a -> FreeAbelianMonoid a -> Bool
$c> :: forall a.
Ord a =>
FreeAbelianMonoid a -> FreeAbelianMonoid a -> Bool
<= :: FreeAbelianMonoid a -> FreeAbelianMonoid a -> Bool
$c<= :: forall a.
Ord a =>
FreeAbelianMonoid a -> FreeAbelianMonoid a -> Bool
< :: FreeAbelianMonoid a -> FreeAbelianMonoid a -> Bool
$c< :: forall a.
Ord a =>
FreeAbelianMonoid a -> FreeAbelianMonoid a -> Bool
compare :: FreeAbelianMonoid a -> FreeAbelianMonoid a -> Ordering
$ccompare :: forall a.
Ord a =>
FreeAbelianMonoid a -> FreeAbelianMonoid a -> Ordering
Ord, Int -> FreeAbelianMonoid a -> ShowS
forall a. Show a => Int -> FreeAbelianMonoid a -> ShowS
forall a. Show a => [FreeAbelianMonoid a] -> ShowS
forall a. Show a => FreeAbelianMonoid a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FreeAbelianMonoid a] -> ShowS
$cshowList :: forall a. Show a => [FreeAbelianMonoid a] -> ShowS
show :: FreeAbelianMonoid a -> String
$cshow :: forall a. Show a => FreeAbelianMonoid a -> String
showsPrec :: Int -> FreeAbelianMonoid a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> FreeAbelianMonoid a -> ShowS
Show)

instance Ord a => Semigroup (FreeAbelianMonoid a) where
    FreeAbelianMonoid Map a Natural
a <> :: FreeAbelianMonoid a -> FreeAbelianMonoid a -> FreeAbelianMonoid a
<> FreeAbelianMonoid Map a Natural
b =
        forall a. Map a Natural -> FreeAbelianMonoid a
FreeAbelianMonoid 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 (FreeAbelianMonoid a)

instance Ord a => Monoid (FreeAbelianMonoid a) where
    mempty :: FreeAbelianMonoid a
mempty = forall a. Map a Natural -> FreeAbelianMonoid a
FreeAbelianMonoid forall k a. Map k a
Map.empty
#if __GLASGOW_HASKELL__ <= 802
    mappend = (<>)
#endif

type instance AlgebraType0 FreeAbelianMonoid a = Ord a
type instance AlgebraType  FreeAbelianMonoid m = (Ord m, Monoid m, AbelianSemigroup m)

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

    foldMapFree :: forall d a.
(AlgebraType FreeAbelianMonoid d,
 AlgebraType0 FreeAbelianMonoid a) =>
(a -> d) -> FreeAbelianMonoid a -> d
foldMapFree a -> d
g (FreeAbelianMonoid Map a Natural
as)
                 = forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey (\a
a Natural
n -> forall a b. (Semigroup a, Integral b) => b -> a -> a
stimes Natural
n forall a b. (a -> b) -> a -> b
$ a -> d
g a
a) Map a Natural
as