folds 0.1 → 0.2

raw patch · 8 files changed

+211/−78 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• folds.cabal +3/−2
• src/Data/Fold.hs +10/−4
• src/Data/Fold/Class.hs +14/−0
• src/Data/Fold/Internal.hs +96/−0
• src/Data/Fold/L'.hs +22/−12
• src/Data/Fold/L.hs +25/−17
• src/Data/Fold/M.hs +22/−37
• src/Data/Fold/R.hs +19/−6

@@ -1,6 +1,6 @@ name:          folds-category:      Data, Vector-version:       0.1+category:      Data, Comonads, Enumerator+version:       0.2 license:       BSD3 cabal-version: >= 1.8 license-file:  LICENSE@@ -65,6 +65,7 @@   exposed-modules:     Data.Fold     Data.Fold.Class+    Data.Fold.Internal     Data.Fold.L     Data.Fold.L'     Data.Fold.M

@@ -54,12 +54,15 @@ -- 'right'' (f φ)         ≡ f ('right'' φ) -- 'dimap' l r (f φ)      ≡ f ('dimap' l r φ) -- 'extract' (f φ)        ≡ 'extract' φ--- 'extend' h (f φ)       ≡ f ('extend' (h . f) φ) -- 'pure' a               ≡ f ('pure' a) -- f φ '<*>' f ψ          ≡ f (φ '<*>' ψ) -- 'return' a             ≡ f ('return' a) -- f φ '>>=' f . k        ≡ f (φ '>>=' k)+-- 'filtering' p (f φ)     ≡ f ('filtering' p φ)+-- 'interspersing' a (f φ) ≡ f ('interspersing' a φ) -- @+--+-- Note: A law including 'extend' is explicitly excluded.  class AsRM p where   -- | 'asM' is a folding homomorphism to a monoidal folding@@ -74,11 +77,12 @@   -- 'right'' ('asM' φ)         ≡ 'asM' ('right'' φ)   -- 'dimap' l r ('asM' φ)      ≡ 'asM' ('dimap' l r φ)   -- 'extract' ('asM' φ)        ≡ 'extract' φ-  -- 'extend' h ('asM' φ)       ≡ 'asM' ('extend' (h . 'asM') φ)   -- 'pure' a                  ≡ 'asM' ('pure' a)   -- 'asM' φ '<*>' 'asM' ψ        ≡ 'asM' (φ '<*>' ψ)   -- 'return' a                ≡ 'asM' ('return' a)   -- 'asM' φ '>>=' 'asM' . k      ≡ 'asM' (φ '>>=' k)+  -- 'filtering' p ('asM' φ)     ≡ 'asM' ('filtering' p φ)+  -- 'interspersing' a ('asM' φ) ≡ 'asM' ('interspersing' a φ)   -- @   asM :: p a b -> M a b   asM = asM . asR@@ -95,11 +99,12 @@   -- 'right'' ('asR' φ)         ≡ 'asR' ('right'' φ)   -- 'dimap' l r ('asR' φ)      ≡ 'asR' ('dimap' l r φ)   -- 'extract' ('asR' φ)        ≡ 'extract' φ-  -- 'extend' h ('asR' φ)       ≡ 'asR' ('extend' (h . 'asR') φ)   -- 'pure' a                  ≡ 'asR' ('pure' a)   -- 'asR' φ '<*>' 'asR' ψ        ≡ 'asR' (φ '<*>' ψ)   -- 'return' a                ≡ 'asR' ('return' a)   -- 'asR' φ '>>=' 'asR' . k      ≡ 'asR' (φ '>>=' k)+  -- 'filtering' p ('asR' φ)     ≡ 'asR' ('filtering' p φ)+  -- 'interspersing' a ('asR' φ) ≡ 'asR' ('interspersing' a φ)   -- @   asR :: p a b -> R a b   asR = asR . asM@@ -136,11 +141,12 @@   -- 'right'' ('asL'' φ)         ≡ 'asL'' ('right'' φ)   -- 'dimap' l r ('asL'' φ)      ≡ 'asL'' ('dimap' l r φ)   -- 'extract' ('asL'' φ)        ≡ 'extract' φ-  -- 'extend' h ('asL'' φ)       ≡ 'asL'' ('extend' (h . 'asL'') φ)   -- 'pure' a                   ≡ 'asL'' ('pure' a)   -- 'asL'' φ '<*>' 'asL'' ψ       ≡ 'asL'' (φ '<*>' ψ)   -- 'return' a                 ≡ 'asL'' ('return' a)   -- 'asL'' φ '>>=' 'asL'' . k     ≡ 'asL'' (φ '>>=' k)+  -- 'filtering' p ('asL'' φ)     ≡ 'asL'' ('filtering' p φ)+  -- 'interspersing' a ('asL'' φ) ≡ 'asL'' ('interspersing' a φ)   -- @   asL' :: p a b -> L' a b 

@@ -20,6 +20,8 @@   foldMap f (One a) = f a  class Choice p => Folding p where+  -- | Partially apply a 'Folding' to some initial input on the left.+  --   prefix :: Foldable t => t a -> p a b -> p a b   prefix = prefixOf folded   {-# INLINE prefix #-}@@ -40,15 +42,27 @@    postfixOf :: Fold s a -> p a b -> s -> p a b +  -- | Apply a 'Folding' to a container full of input:+  --+  -- >>> run ["hello","world"] $ L id (++) []+  -- "helloworld"+  --+  -- >>> run [1,2,3] $ L id (+) 0+  -- 6   run :: Foldable t => t a -> p a b -> b   run = runOf folded   {-# INLINE run #-} +  -- | Apply a 'Folding' to a single element of input   run1 :: a -> p a b -> b   run1 = run . One   {-# INLINE run1 #-}    runOf :: Fold s a -> s -> p a b -> b++  filtering :: (a -> Bool) -> p a b -> p a b++  interspersing :: a -> p a b -> p a b  -- enscanOf :: Traversal s t a b -> s -> p a b -> t 

@@ -0,0 +1,96 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Data.Fold.Internal+  ( SnocList(..)+  , Maybe'(..), maybe'+  , Pair'(..)+  , N(..)+  , Tree(..)+  ) where++import Control.Applicative+import Data.Data+import Data.Foldable+import Data.Monoid+import Data.Proxy+import Data.Reflection+import Data.Traversable++-- | Reversed '[]'+data SnocList a = Snoc (SnocList a) a | Nil+  deriving (Eq,Ord,Show,Read,Typeable,Data)++instance Functor SnocList where+  fmap f (Snoc xs x) = Snoc (fmap f xs) (f x)+  fmap _ Nil = Nil++instance Foldable SnocList where+  foldl f z m0 = go m0 where+    go (Snoc xs x) = f (go xs) x+    go Nil = z+  {-# INLINE foldl #-}+  foldMap f (Snoc xs x) = foldMap f xs `mappend` f x+  foldMap _ Nil = mempty+  {-# INLINE foldMap #-}++instance Traversable SnocList where+  traverse f (Snoc xs x) = Snoc <$> traverse f xs <*> f x+  traverse _ Nil = pure Nil+  {-# INLINE traverse #-}++-- | Strict 'Maybe'+data Maybe' a = Nothing' | Just' !a+  deriving (Eq,Ord,Show,Read,Typeable,Data)++instance Foldable Maybe' where+  foldMap _ Nothing' = mempty+  foldMap f (Just' a) = f a++maybe' :: b -> (a -> b) -> Maybe' a -> b+maybe' _ f (Just' a) = f a+maybe' z _ Nothing'  = z+{-# INLINE maybe' #-}++-- | A reified 'Monoid'.+newtype N a s = N { runN :: a }+  deriving (Eq,Ord,Show,Read,Typeable,Data)++instance Reifies s (a -> a -> a, a) => Monoid (N a s) where+  mempty = N $ snd $ reflect (Proxy :: Proxy s)+  {-# INLINE mempty #-}+  mappend (N a) (N b) = N $ fst (reflect (Proxy :: Proxy s)) a b+  {-# INLINE mappend #-}++-- | The shape of a 'foldMap'+data Tree a+  = Zero+  | One a+  | Two (Tree a) (Tree a)+  deriving (Eq,Ord,Show,Read,Typeable,Data)++instance Functor Tree where+  fmap _ Zero = Zero+  fmap f (One a) = One (f a)+  fmap f (Two a b) = Two (fmap f a) (fmap f b)++instance Foldable Tree where+  foldMap _ Zero = mempty+  foldMap f (One a) = f a+  foldMap f (Two a b) = foldMap f a `mappend` foldMap f b++instance Traversable Tree where+  traverse _ Zero = pure Zero+  traverse f (One a) = One <$> f a+  traverse f (Two a b) = Two <$> traverse f a <*> traverse f b++-- | Strict Pair+data Pair' a b = Pair' !a !b+  deriving (Eq,Ord,Show,Read,Typeable,Data)++instance (Monoid a, Monoid b) => Monoid (Pair' a b) where+  mempty = Pair' mempty mempty+  {-# INLINE mempty #-}+  mappend (Pair' a b) (Pair' c d) = Pair' (mappend a c) (mappend b d)+  {-# INLINE mappend #-}

@@ -6,6 +6,7 @@ {-# LANGUAGE ExistentialQuantification #-} module Data.Fold.L'   ( L'(..)+  , unfoldL'   ) where  import Control.Applicative@@ -13,9 +14,9 @@ import Control.Lens import Data.Foldable import Data.Fold.Class+import Data.Fold.Internal import Data.Functor.Extend import Data.Functor.Bind-import Data.Monoid import Data.Profunctor.Unsafe import Unsafe.Coerce import Prelude hiding (foldl)@@ -23,6 +24,11 @@ -- | strict left folds data L' a b = forall r. L' (r -> b) (r -> a -> r) r +-- | Construct a strict Moore machine from a state valuation and transition function+unfoldL' :: (s -> (b, a -> s)) -> s -> L' a b+unfoldL' f = L' (fst . f) (snd . f)+{-# INLINE unfoldL' #-}+ -- | efficient 'prefix', leaky 'postfix' instance Folding L' where   run t (L' k h z)     = k $! foldl' h z t@@ -34,6 +40,21 @@   postfix t s          = extend (run s) t   postfix1 t a         = extend (run1 a) t   postfixOf l t s      = extend (runOf l s) t+  filtering p (L' k h z) = L' k (\r a -> if p a then h r a else r) z+  interspersing a (L' k h z) = L' (maybe' (k z) k) h' Nothing' where+    h' Nothing' b  = Just' (h z b)+    h' (Just' x) b = Just' (h (h x a) b)+  {-# INLINE run #-}+  {-# INLINE run1 #-}+  {-# INLINE runOf #-}+  {-# INLINE prefix #-}+  {-# INLINE prefix1 #-}+  {-# INLINE prefixOf #-}+  {-# INLINE postfix #-}+  {-# INLINE postfix1 #-}+  {-# INLINE postfixOf #-}+  {-# INLINE filtering #-}+  {-# INLINE interspersing #-}  instance Profunctor L' where   dimap f g (L' k h z) = L' (g.k) (\r -> h r . f) z@@ -131,14 +152,3 @@    _ @> m = m   {-# INLINE (@>) #-}--data SnocList a = Snoc (SnocList a) a | Nil--instance Foldable SnocList where-  foldl f z m0 = go m0 where-    go (Snoc xs x) = f (go xs) x-    go Nil = z-  {-# INLINE foldl #-}-  foldMap f (Snoc xs x) = foldMap f xs `mappend` f x-  foldMap _ Nil = mempty-  {-# INLINE foldMap #-}

@@ -6,6 +6,7 @@ {-# LANGUAGE ExistentialQuantification #-} module Data.Fold.L   ( L(..)+  , unfoldL   ) where  import Control.Applicative@@ -13,9 +14,9 @@ import Control.Lens import Data.Foldable import Data.Fold.Class+import Data.Fold.Internal import Data.Functor.Extend import Data.Functor.Bind-import Data.Monoid import Data.Profunctor.Unsafe import Unsafe.Coerce import Prelude hiding (foldl)@@ -23,6 +24,11 @@ -- left folds data L a b = forall r. L (r -> b) (r -> a -> r) r +-- | Construct a Moore machine from a state valuation and transition function+unfoldL :: (s -> (b, a -> s)) -> s -> L a b+unfoldL f = L (fst . f) (snd . f)+{-# INLINE unfoldL #-}+ -- | efficient 'prefix', leaky 'postfix' instance Folding L where   run t (L k h z)     = k (foldl h z t)@@ -34,6 +40,21 @@   postfix t s         = extend (run s) t   postfix1 t a        = extend (run1 a) t   postfixOf l t s     = extend (runOf l s) t+  filtering p (L k h z) = L k (\r a -> if p a then h r a else r) z+  interspersing a (L k h z) = L (maybe' (k z) k) h' Nothing' where+    h' Nothing' b  = Just' (h z b)+    h' (Just' x) b = Just' (h (h x a) b)+  {-# INLINE run #-}+  {-# INLINE run1 #-}+  {-# INLINE runOf #-}+  {-# INLINE prefix #-}+  {-# INLINE prefix1 #-}+  {-# INLINE prefixOf #-}+  {-# INLINE postfix #-}+  {-# INLINE postfix1 #-}+  {-# INLINE postfixOf #-}+  {-# INLINE filtering #-}+  {-# INLINE interspersing #-}  {- enscanl s (L k h z) = snd (mapAccumL h' z s) where@@ -85,16 +106,14 @@   extend f (L k h z)  = L (f . L k h) h z   {-# INLINE extend #-} -data Pair a b = Pair !a !b- instance Applicative (L a) where   pure b = L (\() -> b) (\() _ -> ()) ()   {-# INLINE pure #-}    L xf bxx xz <*> L ya byy yz = L-    (\(Pair x y) -> xf x $ ya y)-    (\(Pair x y) b -> Pair (bxx x b) (byy y b))-    (Pair xz yz)+    (\(Pair' x y) -> xf x $ ya y)+    (\(Pair' x y) b -> Pair' (bxx x b) (byy y b))+    (Pair' xz yz)   {-# INLINE (<*>) #-}    (<*) m = \_ -> m@@ -139,14 +158,3 @@    _ @> m = m   {-# INLINE (@>) #-}--data SnocList a = Snoc (SnocList a) a | Nil--instance Foldable SnocList where-  foldl f z m0 = go m0 where-    go (Snoc xs x) = f (go xs) x-    go Nil = z-  {-# INLINE foldl #-}-  foldMap f (Snoc xs x) = foldMap f xs `mappend` f x-  foldMap _ Nil = mempty-  {-# INLINE foldMap #-}

@@ -16,10 +16,10 @@ import Control.Comonad import Control.Lens import Data.Fold.Class+import Data.Fold.Internal import Data.Foldable hiding (sum, product) import Data.Functor.Extend import Data.Functor.Bind-import Data.Monoid import Data.Profunctor.Unsafe import Data.Proxy import Data.Reflection@@ -52,6 +52,23 @@   postfixOf l (M k h m (z :: m)) s = reify (m, z) $     \ (_ :: Proxy s) -> case runN (foldMapOf l (N #. h) s :: N m s) of       y -> M (\x -> k (m x y)) h m z+  filtering p (M k h m z) = M k (\a -> if p a then h a else z) m z+  interspersing a (M k h m z) = M (maybe' (k z) k) h' m' Nothing' where+    h' r  = Just' (h r)+    m' (Just' x) (Just' y) = Just' (x `m` h a `m` y)+    m' Nothing' my = my+    m' mx Nothing' = mx+  {-# INLINE run #-}+  {-# INLINE run1 #-}+  {-# INLINE runOf #-}+  {-# INLINE prefix #-}+  {-# INLINE prefix1 #-}+  {-# INLINE prefixOf #-}+  {-# INLINE postfix #-}+  {-# INLINE postfix1 #-}+  {-# INLINE postfixOf #-}+  {-# INLINE filtering #-}+  {-# INLINE interspersing #-}  instance Profunctor M where   dimap f g (M k h m e) = M (g.k) (h.f) m e@@ -92,17 +109,15 @@   duplicate (M k h m z) = M (\n -> M (k . m n) h m z) h m z   {-# INLINE duplicate #-} -data Pair a b = Pair !a !b- instance Applicative (M a) where   pure b = M (\() -> b) (\_ -> ()) (\() () -> ()) ()   {-# INLINE pure #-}    M xf bx xx xz <*> M ya by yy yz = M-    (\(Pair x y) -> xf x $ ya y)-    (\b -> Pair (bx b) (by b))-    (\(Pair x1 y1) (Pair x2 y2) -> Pair (xx x1 x2) (yy y1 y2))-    (Pair xz yz)+    (\(Pair' x y) -> xf x $ ya y)+    (\b -> Pair' (bx b) (by b))+    (\(Pair' x1 y1) (Pair' x2 y2) -> Pair' (xx x1 x2) (yy y1 y2))+    (Pair' xz yz)   {-# INLINE (<*>) #-}    (<*) m = \_ -> m@@ -147,33 +162,3 @@    _ @> m = m   {-# INLINE (@>) #-}---- * Internals---- | A reified 'Monoid'.-newtype N a s = N { runN :: a }--instance Reifies s (a -> a -> a, a) => Monoid (N a s) where-  mempty = N $ snd $ reflect (Proxy :: Proxy s)-  {-# INLINE mempty #-}-  mappend (N a) (N b) = N $ fst (reflect (Proxy :: Proxy s)) a b-  {-# INLINE mappend #-}---- | The shape of a 'foldMap'-data Tree a = Zero | One a | Two (Tree a) (Tree a)--instance Functor Tree where-  fmap _ Zero = Zero-  fmap f (One a) = One (f a)-  fmap f (Two a b) = Two (fmap f a) (fmap f b)--instance Foldable Tree where-  foldMap _ Zero = mempty-  foldMap f (One a) = f a-  foldMap f (Two a b) = foldMap f a `mappend` foldMap f b--instance Traversable Tree where-  traverse _ Zero = pure Zero-  traverse f (One a) = One <$> f a-  traverse f (Two a b) = Two <$> traverse f a <*> traverse f b-

@@ -13,10 +13,10 @@ import Control.Lens import Data.Foldable hiding (sum, product) import Data.Fold.Class+import Data.Fold.Internal import Data.Functor.Extend import Data.Functor.Bind import Data.Profunctor.Unsafe--- import Data.Traversable import Unsafe.Coerce import Prelude hiding (foldr, sum, product, length) @@ -34,6 +34,21 @@   postfix t s         = run s (duplicate t)   postfix1 t a        = run1 a (duplicate t)   postfixOf l t s     = runOf l s (duplicate t)+  filtering p (R k h z) = R k (\a r -> if p a then h a r else r) z+  interspersing a (R k h z) = R (maybe' (k z) k) h' Nothing' where+    h' b Nothing'  = Just' (h b z)+    h' b (Just' x) = Just' (h b (h a x))+  {-# INLINE run #-}+  {-# INLINE run1 #-}+  {-# INLINE runOf #-}+  {-# INLINE prefix #-}+  {-# INLINE prefix1 #-}+  {-# INLINE prefixOf #-}+  {-# INLINE postfix #-}+  {-# INLINE postfix1 #-}+  {-# INLINE postfixOf #-}+  {-# INLINE filtering #-}+  {-# INLINE interspersing #-}  instance Profunctor R where   dimap f g (R k h z) = R (g.k) (h.f) z@@ -77,8 +92,6 @@   extend f (R k h z)  = R (f . R k h) h z   {-# INLINE extend #-} -data Pair a b = Pair !a !b- instance Bind (R a) where   (>>-) = (>>=)   {-# INLINE (>>-) #-}@@ -95,9 +108,9 @@   {-# INLINE pure #-}    R xf bxx xz <*> R ya byy yz = R-    (\(Pair x y) -> xf x $ ya y)-    (\b (Pair x y) -> Pair (bxx b x) (byy b y))-    (Pair xz yz)+    (\(Pair' x y) -> xf x $ ya y)+    (\b (Pair' x y) -> Pair' (bxx b x) (byy b y))+    (Pair' xz yz)   {-# INLINE (<*>) #-}    (<*) m = \_ -> m