{-# LANGUAGE UndecidableInstances , FlexibleContexts , MultiParamTypeClasses , FlexibleInstances , GeneralizedNewtypeDeriving , FunctionalDependencies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Monoid.Reducer
    ( module Data.Monoid
    , Reducer
    , unit, snoc, cons
    , foldMapReduce
    , foldReduce
    ) where

import Data.Monoid
import Data.Foldable
import Data.FingerTree
import qualified Data.Sequence as Seq
import Data.Sequence (Seq)
import qualified Data.Set as Set
import Data.Set (Set)
import qualified Data.IntSet as IntSet
import Data.IntSet (IntSet)
import qualified Data.IntMap as IntMap
import Data.IntMap (IntMap)
import qualified Data.Map as Map
import Data.Map (Map)
--import qualified Data.BitSet as BitSet
--import Data.BitSet (BitSet)

-- minimal definition unit or snoc
class Monoid m => Reducer c m where
    unit :: c -> m 
    snoc :: m -> c -> m
    cons :: c -> m -> m 

    unit = snoc mempty 
    snoc m = mappend m . unit
    cons = mappend . unit

foldMapReduce :: (Foldable f, e `Reducer` m) => (a -> e) -> f a -> m
foldMapReduce f = foldMap (unit . f)

foldReduce :: (Foldable f, e `Reducer` m) => f e -> m
foldReduce = foldMap unit

instance (Reducer c m, Reducer c n) => Reducer c (m,n) where
    unit x = (unit x,unit x)
    (m,n) `snoc` x = (m `snoc` x, n `snoc` x)
    x `cons` (m,n) = (x `cons` m, x `cons` n)

instance (Reducer c m, Reducer c n, Reducer c o) => Reducer c (m,n,o) where
    unit x = (unit x,unit x, unit x)
    (m,n,o) `snoc` x = (m `snoc` x, n `snoc` x, o `snoc` x)
    x `cons` (m,n,o) = (x `cons` m, x `cons` n, x `cons` o)

instance (Reducer c m, Reducer c n, Reducer c o, Reducer c p) => Reducer c (m,n,o,p) where
    unit x = (unit x,unit x, unit x, unit x)
    (m,n,o,p) `snoc` x = (m `snoc` x, n `snoc` x, o `snoc` x, p `snoc` x)
    x `cons` (m,n,o,p) = (x `cons` m, x `cons` n, x `cons` o, x `cons` p)

instance Reducer c [c] where
    unit = return
    cons = (:)
    xs `snoc` x = xs ++ [x]

instance Reducer c () where
    unit _ = ()
    _ `snoc` _ = ()
    _ `cons` _ = ()

instance Reducer Bool Any where
    unit = Any

instance Reducer Bool All where
    unit = All

instance Reducer (a -> a) (Endo a) where
    unit = Endo

instance Monoid a => Reducer a (Dual a) where
    unit = Dual
    
instance Num a => Reducer a (Sum a) where
    unit = Sum

instance Num a => Reducer a (Product a) where
    unit = Product

instance Reducer (Maybe a) (First a) where
    unit = First

instance Reducer a (First a) where
    unit = First . Just

instance Reducer (Maybe a) (Last a) where
    unit = Last

instance Reducer a (Last a) where
    unit = Last . Just

-- orphan, which should be in Data.FingerTree
instance Measured v a => Monoid (FingerTree v a) where
    mempty = empty
    mappend = (><)

instance Measured v a => Reducer a (FingerTree v a) where
    unit = singleton
    cons = (<|)
    snoc = (|>) 

instance Reducer a (Seq a) where
    unit = Seq.singleton
    cons = (Seq.<|)
    snoc = (Seq.|>)

instance Reducer Int IntSet where
    unit = IntSet.singleton
    cons = IntSet.insert
    snoc = flip IntSet.insert -- left bias irrelevant

instance Ord a => Reducer a (Set a) where
    unit = Set.singleton
    cons = Set.insert
    -- pedantic in case Eq doesn't implement structural equality
    snoc s m | Set.member m s = s 
             | otherwise = Set.insert m s

instance Reducer (Int,v) (IntMap v) where
    unit = uncurry IntMap.singleton
    cons = uncurry IntMap.insert
    snoc = flip . uncurry . IntMap.insertWith $ const id

instance Ord k => Reducer (k,v) (Map k v) where
    unit = uncurry Map.singleton
    cons = uncurry Map.insert
    snoc = flip . uncurry . Map.insertWith $ const id

{-
instance Enum a => Monoid (BitSet a) where
    mempty = BitSet.empty
    mappend = BitSet.union -- not yet present, contacted library author

instance Enum a => Reducer a (BitSet a) where
    unit m = BitSet.insert m BitSet.empty
-}