{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
module Data.Rope.Util.Reducer 
    ( Reducer(..)
    -- * Folding with 'Reducer's
    , foldMapReduce -- :: (Foldable f, e `Reducer` m) => (a -> e) -> f a -> m
    , foldReduce    -- :: (Foldable f, e `Reducer` m) => f e -> m 
    -- * 'Applicative' reduction
    , pureUnit      -- :: (Applicative f, c `Reducer` n) => c -> m n
    , returnUnit    -- :: (Monad m, c `Reducer` n) c -> m n
    ) where

import Control.Applicative
import Control.Monad 
import qualified Data.FingerTree as FingerTree
import Data.FingerTree (FingerTree, Measured)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as Lazy

import Data.Monoid

import Data.Foldable

{-
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)
-}

-- | This type may be best read infix. A @c `Reducer` m@ is a 'Monoid' @m@ that maps
-- values of type @c@ through @unit@ to values of type @m@. A @c@-'Reducer' may also
-- supply operations which tack-on another @c@ to an existing 'Monoid' @m@ on the left
-- or right. These specialized reductions may be more efficient in some scenarios
-- and are used when appropriate by a 'Generator'. The names 'cons' and 'snoc' work
-- by analogy to the synonymous operations in the list monoid.
--
-- This class deliberately avoids functional-dependencies, so that () can be a @c@-Reducer
-- for all @c@, and so many common reducers can work over multiple types, for instance,
-- First and Last may reduce both @a@ and 'Maybe' @a@. Since a 'Generator' has a fixed element
-- type, the input to the reducer is generally known and extracting from the monoid usually
-- is sufficient to fix the result type. Combinators are available for most scenarios where
-- this is not the case, and the few remaining cases can be handled by using an explicit 
-- type annotation.
--
-- Minimal definition: 'unit' or 'snoc'
class Monoid m => Reducer c m where
    -- | Convert a value into a 'Monoid'
    unit :: c -> m 
    -- | Append a value to a 'Monoid' for use in left-to-right reduction
    snoc :: m -> c -> m
    -- | Prepend a value onto a 'Monoid' for use during right-to-left reduction
    cons :: c -> m -> m 

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

-- | Apply a 'Reducer' to a 'Foldable' container, after mapping the contents into a suitable form for reduction.
foldMapReduce :: (Foldable f, e `Reducer` m) => (a -> e) -> f a -> m
foldMapReduce f = foldMap (unit . f)

-- | Apply a 'Reducer' to a 'Foldable' mapping each element through 'unit'
foldReduce :: (Foldable f, e `Reducer` m) => f e -> m
foldReduce = foldMap unit

returnUnit :: (Monad m, c `Reducer` n) => c -> m n 
returnUnit = return . unit

pureUnit :: (Applicative f, c `Reducer` n) => c -> f n
pureUnit = pure . 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 ByteString ByteString where
    unit = id
    snoc = mappend
    cons = mappend

instance Reducer ByteString Lazy.ByteString where
    unit = Lazy.fromChunks . return

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

-- instance Measured v a => Monoid (FingerTree v a) where
--    mempty = FingerTree.empty
--    mappend = (><)

instance Measured v a => Reducer a (FingerTree v a) where
    unit = FingerTree.singleton

{-
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 about order 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
-}