Reducer.hs

{-# LANGUAGE UndecidableInstances , FlexibleContexts , MultiParamTypeClasses , FlexibleInstances , GeneralizedNewtypeDeriving, TypeOperators, ScopedTypeVariables, CPP #-}
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif

#ifndef MIN_VERSION_semigroups
#define MIN_VERSION_semigroups(x,y,z) 1
#endif

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Semigroup.Reducer
-- Copyright   :  (c) Edward Kmett 2009
-- License     :  BSD3
-- Maintainer  :  ekmett@gmail.com
-- Stability   :  experimental
-- Portability :  non-portable (MPTCs)
--
-- A @c@-'Reducer' is a 'Semigroup' with a canonical mapping from @c@ to the Semigroup.
--
-----------------------------------------------------------------------------

module Data.Semigroup.Reducer
  ( Reducer(..)
  , foldMapReduce, foldMapReduce1
  , foldReduce, foldReduce1
  , pureUnit
  , returnUnit
  , Count(..)
  ) where

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif

import qualified Data.Monoid as Monoid
import Data.Semigroup as Semigroup
import Data.Semigroup.Foldable
import Data.Semigroup.Instances ()
import Data.Hashable

#if __GLASGOW_HASKELL__ < 710
import Data.Foldable
#endif

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.HashMap.Lazy as HashMap
import Data.HashMap.Lazy (HashMap)

#ifdef LANGUAGE_DeriveDataTypeable
import Data.Data
#endif

--import Text.Parsec.Prim

-- | This type may be best read infix. A @c `Reducer` m@ is a 'Semigroup' @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'
class Semigroup m => Reducer c m where
  -- | Convert a value into a 'Semigroup'
  unit :: c -> m
  -- | Append a value to a 'Semigroup' for use in left-to-right reduction
  snoc :: m -> c -> m
  -- | Prepend a value onto a 'Semigroup' for use during right-to-left reduction
  cons :: c -> m -> m

  snoc m = (<>) m . unit
  cons = (<>) . unit

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

foldMapReduce1 :: (Foldable1 f, Reducer e m) => (a -> e) -> f a -> m
foldMapReduce1 f = foldMap1 (unit . f)

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

-- | Apply a 'Reducer' to a 'Foldable1' mapping each element through 'unit'
foldReduce1 :: (Foldable1 f, Reducer e m) => f e -> m
foldReduce1 = foldMap1 unit

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

pureUnit :: (Applicative f, Reducer c n) => c -> f n
pureUnit = pure . unit

newtype Count = Count { getCount :: Int } deriving
  ( Eq, Ord, Show, Read
#ifdef LANGUAGE_DeriveDataTypeable
  , Data, Typeable
#endif
  )

instance Hashable Count where
  hashWithSalt n = hashWithSalt n . getCount

instance Semigroup Count where
  Count a <> Count b = Count (a + b)
#if MIN_VERSION_semigroups(0,17,0)
  stimes n (Count a) = Count $ fromIntegral n * a
#else
  times1p n (Count a) = Count $ (fromIntegral n + 1) * a
#endif

instance Monoid Count where
  mempty = Count 0
#if !(MIN_VERSION_base(4,11,0))
  Count a `mappend` Count b = Count (a + b)
#endif

instance Reducer a Count where
  unit _ = Count 1
  Count n `snoc` _ = Count (n + 1)
  _ `cons` Count n = Count (n + 1)

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 Semigroup 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 Ord a => Reducer a (Min a) where
  unit = Min

instance Ord a => Reducer a (Max a) where
  unit = Max

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

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

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

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

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

--instance (Stream s m t, Reducer c 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 (Eq k, Hashable k) => Reducer (k, v) (HashMap k v) where
  unit = uncurry HashMap.singleton
  cons = uncurry HashMap.insert
  snoc = flip . uncurry . HashMap.insertWith $ const id

instance Monoid m => Reducer m (WrappedMonoid m) where
  unit = WrapMonoid