Reducer.hs

{-# LANGUAGE UndecidableInstances , FlexibleContexts , MultiParamTypeClasses , FlexibleInstances , GeneralizedNewtypeDeriving #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Monoid.Reducer
-- Copyright   :  (c) Edward Kmett 2009
-- License     :  BSD-style
-- Maintainer  :  ekmett@gmail.com
-- Stability   :  experimental
-- Portability :  non-portable (MPTCs)
--
-- A @c@-'Reducer' is a 'Monoid' with a canonical mapping from @c@ to the Monoid.
-- This 'unit' acts in many ways like 'return' for a 'Monad' but is limited
-- to a single type.
--
-----------------------------------------------------------------------------

module Data.Monoid.Reducer
    ( module Data.Monoid
    , Reducer
    , unit, snoc, cons
    , foldMapReduce
    , foldReduce
    , pureUnit
    , returnUnit
    ) where

import Control.Applicative
import Control.Monad 

import Data.Monoid
import Data.Monoid.Instances ()

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 Text.Parsec.Prim

--import qualified Data.BitSet as BitSet
--import Data.BitSet (BitSet)

-- | 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 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 => Reducer a (FingerTree v a) where
    unit = singleton
    cons = (<|)
    snoc = (|>) 

instance (Stream s m t, c `Reducer` a) => Reducer c (ParsecT s u m a) where
    unit = return . unit

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

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