foldl 1.1.1 → 1.1.2

raw patch · 2 files changed

+127/−21 lines, 2 filesdep +comonadPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: comonad

API changes (from Hackage documentation)

Files

• foldl.cabal +3/−2
• src/Control/Foldl.hs +124/−19

@@ -1,5 +1,5 @@ Name: foldl-Version: 1.1.1+Version: 1.1.2 Cabal-Version: >=1.8.0.2 Build-Type: Simple License: BSD3@@ -29,7 +29,8 @@         transformers >= 0.2.0.0  && < 0.5 ,         vector       >= 0.7      && < 0.12,         containers                  < 0.6,-        profunctors                 < 5.2+        profunctors                 < 5.2,+        comonad      == 4.*     Exposed-Modules:         Control.Foldl,         Control.Foldl.ByteString,

@@ -33,7 +33,10 @@  -} -{-# LANGUAGE ExistentialQuantification, RankNTypes, Trustworthy #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE Trustworthy               #-}  module Control.Foldl (     -- * Fold Types@@ -51,6 +54,7 @@     , head     , last     , lastDef+    , lastN     , null     , length     , and@@ -68,6 +72,8 @@     , elemIndex     , findIndex     , random+    , randomN+    , sink      -- * Generic Folds     , genericLength@@ -87,6 +93,7 @@     , impurely     , generalize     , simplify+    , duplicateM     , _Fold1     , premap     , premapM@@ -103,22 +110,20 @@     , module Data.Vector.Generic     ) where -import Control.Applicative (Applicative(pure, (<*>)),liftA2)+import Control.Applicative import Control.Foldl.Internal (Maybe'(..), lazy, Either'(..), hush) import Control.Monad ((>=>))-import Control.Monad.Primitive (PrimMonad)+import Control.Monad.Primitive (PrimMonad, RealWorld)+import Control.Comonad import Data.Foldable (Foldable)-import qualified Data.Foldable as F import Data.Functor.Constant (Constant(Constant, getConstant)) import Data.Functor.Identity (Identity, runIdentity)+import Data.Monoid import Data.Profunctor-import Data.Monoid (Monoid(mempty, mappend), Endo(Endo, appEndo))-import Data.Vector.Generic (Vector)-import qualified Data.Vector.Generic as V-import qualified Data.Vector.Generic.Mutable as M-import qualified Data.List as List-import qualified Data.Set as Set-import System.Random.MWC (createSystemRandom, uniformR)+import Data.Sequence ((<|))+import Data.Vector.Generic (Vector, Mutable)+import Data.Vector.Generic.Mutable (MVector)+import System.Random.MWC (GenIO, createSystemRandom, uniformR) import Prelude hiding     ( head     , last@@ -136,6 +141,13 @@     , notElem     ) +import qualified Data.Foldable               as F+import qualified Data.List                   as List+import qualified Data.Sequence               as Seq+import qualified Data.Set                    as Set+import qualified Data.Vector.Generic         as V+import qualified Data.Vector.Generic.Mutable as M+ {-| Efficient representation of a left fold that preserves the fold's step     function, initial accumulator, and extraction function @@ -159,6 +171,13 @@     lmap = premap     rmap = fmap +instance Comonad (Fold a) where+    extract (Fold _ begin done) = done begin+    {-#  INLINABLE extract #-}++    duplicate (Fold step begin done) = Fold step begin (\x -> Fold step x done)+    {-#  INLINABLE duplicate #-}+ instance Applicative (Fold a) where     pure b    = Fold (\() _ -> ()) () (\() -> b)     {-# INLINABLE pure #-}@@ -301,6 +320,10 @@         in  FoldM step begin done     {-# INLINABLE (<*>) #-} +instance Monad m => Profunctor (FoldM m) where+    rmap = fmap+    lmap = premapM+ instance (Monoid b, Monad m) => Monoid (FoldM m a b) where     mempty = pure mempty     {-# INLINABLE mempty #-}@@ -452,6 +475,22 @@ lastDef a = Fold (\_ a' -> a') a id {-# INLINABLE lastDef #-} +{-| Return the last N elements++-}+lastN :: Int -> Fold a [a]+lastN n = Fold step begin done+  where+    step s a = a <| s'+      where+        s' =+            if Seq.length s < n+            then s+            else Seq.drop 1 s+    begin = Seq.empty+    done  = F.toList+{-# INLINABLE lastN #-}+ -- | Returns 'True' if the container is empty, 'False' otherwise null :: Fold a Bool null = Fold (\_ _ -> False) True id@@ -571,18 +610,74 @@ random = FoldM step begin done   where     begin = do-        gen <- createSystemRandom-        return $! Pair3 gen Nothing' (1 :: Int)+        g <- createSystemRandom+        return $! Pair3 g Nothing' (1 :: Int) -    step (Pair3 gen Nothing'  _) a = return $! Pair3 gen (Just' a) 2-    step (Pair3 gen (Just' a) m) b = do-        n <- uniformR (1, m) gen+    step (Pair3 g Nothing'  _) a = return $! Pair3 g (Just' a) 2+    step (Pair3 g (Just' a) m) b = do+        n <- uniformR (1, m) g         let c = if n == 1 then b else a-        return $! Pair3 gen (Just' c) (m + 1)+        return $! Pair3 g (Just' c) (m + 1)      done (Pair3 _ ma _) = return (lazy ma) {-# INLINABLE random #-} +data VectorState = Incomplete {-# UNPACK #-} !Int | Complete++data RandomNState v a = RandomNState+    { _size      ::                !VectorState+    , _reservoir ::                !(Mutable v RealWorld a)+    , _position  :: {-# UNPACK #-} !Int+    , _gen       :: {-# UNPACK #-} !GenIO+    }++-- | Pick several random elements, using reservoir sampling+randomN :: Vector v a => Int -> FoldM IO a (Maybe (v a))+randomN n = FoldM step begin done+  where+    step+        :: MVector (Mutable v) a+        => RandomNState v a -> a -> IO (RandomNState v a)+    step (RandomNState (Incomplete m) mv i g) a = do+        M.write mv m a+        let m' = m + 1+        let s  = if n <= m' then Complete else Incomplete m'+        return $! RandomNState s mv (i + 1) g+    step (RandomNState  Complete      mv i g) a = do+        r <- uniformR (0, i - 1) g+        if r < n+            then M.unsafeWrite mv r a+            else return ()+        return (RandomNState Complete mv (i + 1) g)++    begin = do+        mv  <- M.new n+        gen <- createSystemRandom+        let s = if n <= 0 then Complete else Incomplete 0+        return (RandomNState s mv 1 gen)++    done :: Vector v a => RandomNState v a -> IO (Maybe (v a))+    done (RandomNState (Incomplete _) _  _ _) = return Nothing+    done (RandomNState  Complete      mv _ _) = do+        v <- V.freeze mv+        return (Just v)++{-| Converts an effectful function to a fold++> sink (f <> g) = sink f <> sink g -- if `(<>)` is commutative+> sink mempty = mempty+-}+++sink ::  (Monoid w, Monad m) => (a -> m w) -> FoldM m a w+sink act = FoldM step begin done  where+  done = return+  begin = return mempty+  step m a = do+    m' <- act a+    return $! mappend m m'+{-# INLINABLE sink #-}+ -- | Like 'length', except with a more general 'Num' return value genericLength :: Num b => Fold a b genericLength = Fold (\n _ -> n + 1) 0 id@@ -657,7 +752,7 @@         M.unsafeWrite mv' idx a         return (Pair mv' (idx + 1))     done (Pair mv idx) = do-        v <- V.unsafeFreeze mv+        v <- V.freeze mv         return (V.unsafeTake idx v) {-# INLINABLE vector #-} @@ -724,6 +819,16 @@     done' x   = runIdentity (done x) {-# INLINABLE simplify #-} +{-| Allows to continue feeding a 'FoldM' even after passing it to a function +that closes it.++For pure 'Fold's, this is provided by the 'Control.Comonad.Comonad' instance.+-}+duplicateM :: Applicative m => FoldM m a b -> FoldM m a (FoldM m a b)+duplicateM (FoldM step begin done) = +    FoldM step begin (\x -> pure (FoldM step (pure x) done))+{-# INLINABLE duplicateM #-}+ {-| @_Fold1 step@ returns a new 'Fold' using just a step function that has the same type for the accumulator and the element. The result type is the accumulator type wrapped in 'Maybe'. The initial accumulator is retrieved from@@ -773,7 +878,7 @@ > > premapM k (f <*> x) = premapM k f <*> premapM k x -}-premapM :: Monad m => (a -> b) -> FoldM m b r -> FoldM m a r+premapM :: (a -> b) -> FoldM m b r -> FoldM m a r premapM f (FoldM step begin done) = FoldM step' begin done   where     step' x a = step x (f a)