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