{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Monoid.Statistics.Class
(
StatMonoid(..)
, reduceSample
, reduceSampleVec
, Pair(..)
) where
import Data.Data (Typeable,Data)
#if MIN_VERSION_base(4,9,0)
import qualified Data.Semigroup as SG (Semigroup(..))
#endif
import Data.Monoid (Monoid(..),(<>),Sum(..),Product(..))
import Data.Vector.Unboxed (Unbox)
import Data.Vector.Unboxed.Deriving (derivingUnbox)
import qualified Data.Foldable as F
import qualified Data.Vector.Generic as G
import Numeric.Sum
import GHC.Generics (Generic)
class Monoid m => StatMonoid m a where
addValue :: m -> a -> m
addValue m a = m <> singletonMonoid a
{-# INLINE addValue #-}
singletonMonoid :: a -> m
singletonMonoid = addValue mempty
{-# INLINE singletonMonoid #-}
{-# MINIMAL addValue | singletonMonoid #-}
reduceSample :: (F.Foldable f, StatMonoid m a) => f a -> m
reduceSample = F.foldl' addValue mempty
reduceSampleVec :: (G.Vector v a, StatMonoid m a) => v a -> m
reduceSampleVec = G.foldl' addValue mempty
{-# INLINE reduceSampleVec #-}
instance (Num a, a ~ a') => StatMonoid (Sum a) a' where
singletonMonoid = Sum
instance (Num a, a ~ a') => StatMonoid (Product a) a' where
singletonMonoid = Product
instance Real a => StatMonoid KahanSum a where
addValue m x = add m (realToFrac x)
{-# INLINE addValue #-}
instance Real a => StatMonoid KBNSum a where
addValue m x = add m (realToFrac x)
{-# INLINE addValue #-}
data Pair a b = Pair !a !b
deriving (Show,Eq,Ord,Typeable,Data,Generic)
#if MIN_VERSION_base(4,9,0)
instance (SG.Semigroup a, SG.Semigroup b) => SG.Semigroup (Pair a b) where
Pair x y <> Pair x' y' = Pair (x SG.<> x') (y SG.<> y')
#endif
instance (Monoid a, Monoid b) => Monoid (Pair a b) where
mempty = Pair mempty mempty
mappend (Pair x y) (Pair x' y') = Pair (x <> x') (y <> y')
{-# INLINABLE mempty #-}
{-# INLINE mappend #-}
instance (StatMonoid a x, StatMonoid b x) => StatMonoid (Pair a b) x where
addValue (Pair a b) !x = Pair (addValue a x) (addValue b x)
singletonMonoid x = Pair (singletonMonoid x) (singletonMonoid x)
{-# INLINE addValue #-}
{-# INLINE singletonMonoid #-}
derivingUnbox "Pair"
[t| forall a b. (Unbox a, Unbox b) => Pair a b -> (a,b) |]
[| \(Pair a b) -> (a,b) |]
[| \(a,b) -> Pair a b |]