folds 0.2 → 0.3

raw patch · 11 files changed

+757/−86 lines, 11 filesdep +pointedPVP ok

version bump matches the API change (PVP)

Dependencies added: pointed

API changes (from Hackage documentation)

Files

• folds.cabal +6/−1
• src/Data/Fold.hs +53/−18
• src/Data/Fold/Class.hs +23/−19
• src/Data/Fold/L'.hs +18/−11
• src/Data/Fold/L.hs +17/−11
• src/Data/Fold/L1'.hs +150/−0
• src/Data/Fold/L1.hs +150/−0
• src/Data/Fold/M.hs +21/−15
• src/Data/Fold/M1.hs +153/−0
• src/Data/Fold/R.hs +16/−11
• src/Data/Fold/R1.hs +150/−0

@@ -1,6 +1,6 @@ name:          folds category:      Data, Comonads, Enumerator-version:       0.2+version:       0.3 license:       BSD3 cabal-version: >= 1.8 license-file:  LICENSE@@ -54,6 +54,7 @@     comonad           >= 3.1   && < 4,     contravariant     >= 0.4.2 && < 1,     lens              >= 3.9   && < 4,+    pointed           >= 3     && < 4,     profunctors       >= 3.3   && < 4,     reflection        >= 1.3   && < 2,     semigroupoids     >= 3.1   && < 4,@@ -68,8 +69,12 @@     Data.Fold.Internal     Data.Fold.L     Data.Fold.L'+    Data.Fold.L1+    Data.Fold.L1'     Data.Fold.M+    Data.Fold.M1     Data.Fold.R+    Data.Fold.R1    ghc-options: -Wall 

@@ -10,18 +10,31 @@ ---------------------------------------------------------------------------- module Data.Fold   (+  -- * Scaners and Foldings+    Scan(..)+  , Folding(..)+  -- * Combinators+  , beneath+  -- * Scans+  -- ** Left Scans+  , L1(..), L1'(..)+  -- ** Semigroup Scans+  , M1(..)+  -- ** Right Scans+  , R1(..)   -- * Foldings   -- ** Left Foldings-    L(..), L'(..)+  , L(..), L'(..)   -- ** Monoidal Foldings   , M(..)   -- ** Right Foldings   , R(..)-  -- * Folding Combinators-  , Folding(..)-  , beneath-  -- * Folding Homomorphisms-  -- $hom+  -- * Homomorphisms+  -- ** Scan Homomorphisms+  -- $scanhom++  -- ** Folding Homomorphisms+  -- $foldinghom   , AsRM(..)   , AsL'(..)   ) where@@ -29,40 +42,62 @@ import Data.Fold.Class import Data.Fold.L import Data.Fold.L'+import Data.Fold.L1+import Data.Fold.L1' import Data.Fold.M+import Data.Fold.M1 import Data.Fold.R+import Data.Fold.R1 import Control.Category ((>>>)) --- * Folding Homomorphisms+-- * Scan Homomorphisms --- $hom+-- $scanhom ----- We define @f@ to be a folding homomorphism betwen @p@ and @q@ when:+-- We define @f@ to be a scan homomorphism between @p@ and @q@ when: -- -- @ -- f :: forall a b. p a b -> q a b -- @ -- -- @+-- 'run1' xs (f φ)        ≡ 'run1' xs φ+-- 'prefix1' xs (f φ)     ≡ f ('prefix1' xs φ)+-- 'postfix1' (f φ) xs    ≡ f ('postfix1' φ xs)+-- 'dimap' l r (f φ)      ≡ f ('dimap' l r φ)+-- 'pure' a               ≡ f ('pure' a)+-- f φ '<*>' f ψ          ≡ f (φ '<*>' ψ)+-- 'return' a             ≡ f ('return' a)+-- f φ '>>=' f . k        ≡ f (φ '>>=' k)+-- 'interspersing' a (f φ) ≡ f ('interspersing' a φ)+-- @+--+-- Furthermore,+--+-- @'left'' (f φ)@ and @f ('left'' φ)@ should agree whenever either answer is 'Right'+-- @'right'' (f φ)@ and @f ('right'' φ)@ should agree whenver either answer is 'Left'+--++-- * Folding Homomorphisms++-- $foldinghom+--+-- We define @f@ to be a folding homomorphism between @p@ and @q@ when+-- @f@ is a scan homomorphism and additionally we can satisfy:+--+-- @ -- 'run' xs (f φ)         ≡ 'run' xs φ -- 'runOf' l xs (f φ)     ≡ 'runOf' l xs φ -- 'prefix' xs (f φ)      ≡ f ('prefix' xs φ) -- 'prefixOf' l xs (f φ)  ≡ f ('prefixOf' l xs φ) -- 'postfix' (f φ) xs     ≡ f ('postfix' φ xs) -- 'postfixOf' l (f φ) xs ≡ f ('postfixOf' l φ xs)--- 'left'' (f φ)          ≡ f ('left'' φ)--- 'right'' (f φ)         ≡ f ('right'' φ)--- 'dimap' l r (f φ)      ≡ f ('dimap' l r φ) -- 'extract' (f φ)        ≡ 'extract' φ--- '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.+-- Note: A law including 'extend' is explicitly excluded. To work consistenly+-- across foldings, use 'prefix' and 'postfix' instead.  class AsRM p where   -- | 'asM' is a folding homomorphism to a monoidal folding

@@ -1,7 +1,9 @@ {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE Trustworthy #-} module Data.Fold.Class-  ( Folding(..)+  ( Scan(..)+  , Folding(..)   , beneath   ) where @@ -19,27 +21,38 @@ instance Foldable One where   foldMap f (One a) = f a -class Choice p => Folding p where+class Choice p => Scan p where+  prefix1 :: a -> p a b -> p a b+  default prefix1 :: Folding p => a -> p a b -> p a b+  prefix1 = prefix . One+  {-# INLINE prefix1 #-}++  postfix1 :: p a b -> a -> p a b+  default postfix1 :: Folding p => p a b -> a -> p a b+  postfix1 p = postfix p . One+  {-# INLINE postfix1 #-}++  -- | Apply a 'Folding' to a single element of input+  run1 :: a -> p a b -> b+  default run1 :: Folding p => a -> p a b -> b+  run1 = run . One+  {-# INLINE run1 #-}++  interspersing :: a -> p a b -> p a b++class Scan 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 #-} -  prefix1 :: a -> p a b -> p a b-  prefix1 = prefix . One-  {-# INLINE prefix1 #-}-   prefixOf :: Fold s a -> s -> p a b -> p a b    postfix :: Foldable t => p a b -> t a -> p a b   postfix = postfixOf folded   {-# INLINE postfix #-} -  postfix1 :: p a b -> a -> p a b-  postfix1 p = postfix p . One-  {-# INLINE postfix1 #-}-   postfixOf :: Fold s a -> p a b -> s -> p a b    -- | Apply a 'Folding' to a container full of input:@@ -53,18 +66,9 @@   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  -- | Lift a 'Folding' into a 'Prism'. --

@@ -21,7 +21,7 @@ import Unsafe.Coerce import Prelude hiding (foldl) --- | strict left folds+-- | A strict left fold / strict Moore machine 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@@ -29,32 +29,35 @@ unfoldL' f = L' (fst . f) (snd . f) {-# INLINE unfoldL' #-} +instance Scan L' where+  run1 t (L' k h z)    = k $! h z t+  prefix1 a            = run1 a . duplicate+  postfix1 t a         = extend (run1 a) t+  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 run1 #-}+  {-# INLINE prefix1 #-}+  {-# INLINE postfix1 #-}+  {-# INLINE interspersing #-}+ -- | efficient 'prefix', leaky 'postfix' instance Folding L' where   run t (L' k h z)     = k $! foldl' h z t-  run1 t (L' k h z)    = k $! h z t   runOf l s (L' k h z) = k $! foldlOf' l h z s   prefix s             = run s . duplicate-  prefix1 a            = run1 a . duplicate   prefixOf l s         = runOf l s . duplicate   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@@ -123,8 +126,12 @@ instance Monad (L' a) where   return = pure   {-# INLINE return #-}+   m >>= f = L' (\xs a -> run xs (f a)) Snoc Nil <*> m   {-# INLINE (>>=) #-}++  _ >> n = n+  {-# INLINE (>>) #-}  instance Extend (L' a) where   extended = extend

@@ -21,7 +21,7 @@ import Unsafe.Coerce import Prelude hiding (foldl) --- left folds+-- | A Moore Machine data L a b = forall r. L (r -> b) (r -> a -> r) r  -- | Construct a Moore machine from a state valuation and transition function@@ -29,32 +29,34 @@ unfoldL f = L (fst . f) (snd . f) {-# INLINE unfoldL #-} +instance Scan L where+  run1 t (L k h z)    = k (h z t)+  prefix1 a           = run1 a . duplicate+  postfix1 t a        = extend (run1 a) t+  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 run1 #-}+  {-# INLINE prefix1 #-}+  {-# INLINE postfix1 #-}+  {-# INLINE interspersing #-}+ -- | efficient 'prefix', leaky 'postfix' instance Folding L where   run t (L k h z)     = k (foldl h z t)-  run1 t (L k h z)    = k (h z t)   runOf l s (L k h z) = k (foldlOf l h z s)   prefix s            = run s . duplicate-  prefix1 a           = run1 a . duplicate   prefixOf l s        = runOf l s . duplicate   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@@ -129,8 +131,12 @@ instance Monad (L a) where   return = pure   {-# INLINE return #-}+   m >>= f = L (\xs a -> run xs (f a)) Snoc Nil <*> m   {-# INLINE (>>=) #-}++  _ >> n = n+  {-# INLINE (>>) #-}  instance Extend (L a) where   extended = extend

@@ -0,0 +1,150 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Trustworthy #-}+module Data.Fold.L1'+  ( L1'(..)+  ) where++import Control.Applicative+import Control.Arrow+import Control.Category+import Control.Lens+import Data.Fold.Class+import Data.Fold.Internal+import Data.Functor.Apply+import Data.Pointed+import Data.Profunctor+import Data.Profunctor.Unsafe+import Data.Semigroupoid+import Prelude hiding (id,(.))+import Unsafe.Coerce++-- | A strict Mealy Machine+data L1' a b = forall c. L1' (c -> b) (c -> a -> c) (a -> c)++instance Scan L1' where+  run1 a (L1' k _ z) = k (z a)+  prefix1 a (L1' k h z) = L1' k h (h $! z a)+  postfix1 (L1' k h z) a = L1' (\c -> k $! h c a) h z+  interspersing a (L1' k h z) = L1' k (\x b -> (h $! h x a) b) z+  {-# INLINE run1 #-}+  {-# INLINE prefix1 #-}+  {-# INLINE postfix1 #-}+  {-# INLINE interspersing #-}++instance Functor (L1' a) where+  fmap f (L1' k h z) = L1' (f.k) h z+  {-# INLINE fmap #-}+  b <$ _ = pure b+  {-# INLINE (<$) #-}++instance Pointed (L1' a) where+  point x = L1' (\() -> x) (\() _ -> ()) (\_ -> ())+  {-# INLINE point #-}++instance Apply (L1' a) where+  (<.>) = (<*>)+  {-# INLINE (<.>) #-}+  (<.) m = \_ -> m+  {-# INLINE (<.) #-}+  _ .> m = m+  {-# INLINE (.>) #-}++instance Applicative (L1' a) where+  pure x = L1' (\() -> x) (\() _ -> ()) (\_ -> ())+  {-# INLINE pure #-}+  L1' kf hf zf <*> L1' ka ha za = L1'+    (\(Pair' x y) -> kf x (ka y))+    (\(Pair' x y) a -> Pair' (hf x a) (ha y a))+    (\a -> Pair' (zf a) (za a))+  (<*) m = \ _ -> m+  {-# INLINE (<*) #-}+  _ *> m = m+  {-# INLINE (*>) #-}++instance Monad (L1' a) where+  return x = L1' (\() -> x) (\() _ -> ()) (\_ -> ())+  {-# INLINE return #-}+  m >>= f = L1' (\xs a -> walk xs (f a)) Snoc1 First <*> m where+  {-# INLINE (>>=) #-}+  _ >> n = n+  {-# INLINE (>>) #-}++instance Semigroupoid L1' where+  o = (.)+  {-# INLINE o #-}++instance Category L1' where+  id = arr id+  {-# INLINE id #-}+  L1' k h z . L1' k' h' z' = L1' (\(Pair' b _) -> k b) h'' z'' where+    z'' a = Pair' (z (k' b)) b where b = z' a+    h'' (Pair' c d) a = Pair' (h c (k' d')) d' where d' = h' d a+  {-# INLINE (.) #-}++instance Arrow L1' where+  arr h = L1' h (\_ a -> a) id+  {-# INLINE arr #-}+  first (L1' k h z) = L1' (first k) h' (first z) where+    h' (a,b) (c,_) = (h a c, b)+  {-# INLINE first #-}+  second (L1' k h z) = L1' (second k) h' (second z) where+    h' (a,b) (_,c) = (a, h b c)+  {-# INLINE second #-}+  L1' k h z *** L1' k' h' z' = L1' (k *** k') h'' (z *** z') where+    h'' (a,b) (c,d) = (h a c, h' b d)+  {-# INLINE (***) #-}+  L1' k h z &&& L1' k' h' z' = L1' (k *** k') h'' (z &&& z') where+    h'' (c,d) a = (h c a, h' d a)+  {-# INLINE (&&&) #-}++instance Profunctor L1' where+  dimap f g (L1' k h z) = L1' (g.k) (\a -> h a . f) (z.f)+  {-# INLINE dimap #-}+  lmap f (L1' k h z) = L1' (k) (\a -> h a . f) (z.f)+  {-# INLINE lmap #-}+  rmap g (L1' k h z) = L1' (g.k) h z+  {-# INLINE rmap #-}+  ( #. ) _ = unsafeCoerce+  {-# INLINE (#.) #-}+  x .# _ = unsafeCoerce x+  {-# INLINE (.#) #-}++instance Strong L1' where+  first' = first+  {-# INLINE first' #-}+  second' = second+  {-# INLINE second' #-}++instance Choice L1' where+  left' (L1' k h z) = L1' (_Left %~ k) step (_Left %~ z) where+    step (Left x) (Left y) = Left (h x y)+    step (Right c) _ = Right c+    step _ (Right c) = Right c+  {-# INLINE left' #-}++  right' (L1' k h z) = L1' (_Right %~ k) step (_Right %~ z) where+    step (Right x) (Right y) = Right (h x y)+    step (Left c) _ = Left c+    step _ (Left c) = Left c+  {-# INLINE right' #-}++instance ArrowChoice L1' where+  left (L1' k h z) = L1' (_Left %~ k) step (_Left %~ z) where+    step (Left x) (Left y) = Left (h x y)+    step (Right c) _ = Right c+    step _ (Right c) = Right c+  {-# INLINE left #-}++  right (L1' k h z) = L1' (_Right %~ k) step (_Right %~ z) where+    step (Right x) (Right y) = Right (h x y)+    step (Left c) _ = Left c+    step _ (Left c) = Left c+  {-# INLINE right #-}++data SnocList1 a = Snoc1 (SnocList1 a) a | First a++walk :: SnocList1 a -> L1' a b -> b+walk xs0 (L1' k h z) = k (go xs0) where+  go (First a) = z a+  go (Snoc1 as a) = h (go as) a+{-# INLINE walk #-}

@@ -0,0 +1,150 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Trustworthy #-}+module Data.Fold.L1+  ( L1(..)+  ) where++import Control.Applicative+import Control.Arrow+import Control.Category+import Control.Lens+import Data.Fold.Class+import Data.Fold.Internal+import Data.Functor.Apply+import Data.Pointed+import Data.Profunctor+import Data.Profunctor.Unsafe+import Data.Semigroupoid+import Prelude hiding (id,(.))+import Unsafe.Coerce++-- | A Mealy Machine+data L1 a b = forall c. L1 (c -> b) (c -> a -> c) (a -> c)++instance Scan L1 where+  run1 a (L1 k _ z) = k (z a)+  prefix1 a (L1 k h z) = L1 k h (h (z a))+  postfix1 (L1 k h z) a = L1 (\c -> k (h c a)) h z+  interspersing a (L1 k h z) = L1 k (\x b -> h (h x a) b) z+  {-# INLINE run1 #-}+  {-# INLINE prefix1 #-}+  {-# INLINE postfix1 #-}+  {-# INLINE interspersing #-}++instance Functor (L1 a) where+  fmap f (L1 k h z) = L1 (f.k) h z+  {-# INLINE fmap #-}+  b <$ _ = pure b+  {-# INLINE (<$) #-}++instance Pointed (L1 a) where+  point x = L1 (\() -> x) (\() _ -> ()) (\_ -> ())+  {-# INLINE point #-}++instance Apply (L1 a) where+  (<.>) = (<*>)+  {-# INLINE (<.>) #-}+  (<.) m = \_ -> m+  {-# INLINE (<.) #-}+  _ .> m = m+  {-# INLINE (.>) #-}++instance Applicative (L1 a) where+  pure x = L1 (\() -> x) (\() _ -> ()) (\_ -> ())+  {-# INLINE pure #-}+  L1 kf hf zf <*> L1 ka ha za = L1+    (\(Pair' x y) -> kf x (ka y))+    (\(Pair' x y) a -> Pair' (hf x a) (ha y a))+    (\a -> Pair' (zf a) (za a))+  (<*) m = \ _ -> m+  {-# INLINE (<*) #-}+  _ *> m = m+  {-# INLINE (*>) #-}++instance Monad (L1 a) where+  return x = L1 (\() -> x) (\() _ -> ()) (\_ -> ())+  {-# INLINE return #-}+  m >>= f = L1 (\xs a -> walk xs (f a)) Snoc1 First <*> m where+  {-# INLINE (>>=) #-}+  _ >> n = n+  {-# INLINE (>>) #-}++instance Semigroupoid L1 where+  o = (.)+  {-# INLINE o #-}++instance Category L1 where+  id = arr id+  {-# INLINE id #-}+  L1 k h z . L1 k' h' z' = L1 (\(Pair' b _) -> k b) h'' z'' where+    z'' a = Pair' (z (k' b)) b where b = z' a+    h'' (Pair' c d) a = Pair' (h c (k' d')) d' where d' = h' d a+  {-# INLINE (.) #-}++instance Arrow L1 where+  arr h = L1 h (\_ a -> a) id+  {-# INLINE arr #-}+  first (L1 k h z) = L1 (first k) h' (first z) where+    h' (a,b) (c,_) = (h a c, b)+  {-# INLINE first #-}+  second (L1 k h z) = L1 (second k) h' (second z) where+    h' (a,b) (_,c) = (a, h b c)+  {-# INLINE second #-}+  L1 k h z *** L1 k' h' z' = L1 (k *** k') h'' (z *** z') where+    h'' (a,b) (c,d) = (h a c, h' b d)+  {-# INLINE (***) #-}+  L1 k h z &&& L1 k' h' z' = L1 (k *** k') h'' (z &&& z') where+    h'' (c,d) a = (h c a, h' d a)+  {-# INLINE (&&&) #-}++instance Profunctor L1 where+  dimap f g (L1 k h z) = L1 (g.k) (\a -> h a . f) (z.f)+  {-# INLINE dimap #-}+  lmap f (L1 k h z) = L1 (k) (\a -> h a . f) (z.f)+  {-# INLINE lmap #-}+  rmap g (L1 k h z) = L1 (g.k) h z+  {-# INLINE rmap #-}+  ( #. ) _ = unsafeCoerce+  {-# INLINE (#.) #-}+  x .# _ = unsafeCoerce x+  {-# INLINE (.#) #-}++instance Strong L1 where+  first' = first+  {-# INLINE first' #-}+  second' = second+  {-# INLINE second' #-}++instance Choice L1 where+  left' (L1 k h z) = L1 (_Left %~ k) step (_Left %~ z) where+    step (Left x) (Left y) = Left (h x y)+    step (Right c) _ = Right c+    step _ (Right c) = Right c+  {-# INLINE left' #-}++  right' (L1 k h z) = L1 (_Right %~ k) step (_Right %~ z) where+    step (Right x) (Right y) = Right (h x y)+    step (Left c) _ = Left c+    step _ (Left c) = Left c+  {-# INLINE right' #-}++instance ArrowChoice L1 where+  left (L1 k h z) = L1 (_Left %~ k) step (_Left %~ z) where+    step (Left x) (Left y) = Left (h x y)+    step (Right c) _ = Right c+    step _ (Right c) = Right c+  {-# INLINE left #-}++  right (L1 k h z) = L1 (_Right %~ k) step (_Right %~ z) where+    step (Right x) (Right y) = Right (h x y)+    step (Left c) _ = Left c+    step _ (Left c) = Left c+  {-# INLINE right #-}++data SnocList1 a = Snoc1 (SnocList1 a) a | First a++walk :: SnocList1 a -> L1 a b -> b+walk xs0 (L1 k h z) = k (go xs0) where+  go (First a) = z a+  go (Snoc1 as a) = h (go as) a+{-# INLINE walk #-}

@@ -26,49 +26,51 @@ import Unsafe.Coerce import Prelude hiding (sum, product, length) --- | A 'foldMap' caught in amber.+-- | A 'foldMap' caught in amber. a.k.a. a monoidal reducer data M a b = forall m. M (m -> b) (a -> m) (m -> m -> m) m +instance Scan M where+  run1 a (M k h _ _) = k (h a)+  prefix1 a (M k h m z) = case h a of+     x -> M (\y -> k (m x y)) h m z+  postfix1 (M k h m z) a = case h a of+     y -> M (\x -> k (m x y)) h 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 run1 #-}+  {-# INLINE prefix1 #-}+  {-# INLINE postfix1 #-}+  {-# INLINE interspersing #-}+ -- | efficient 'prefix', efficient 'postfix' instance Folding M where   run s (M k h m (z :: m)) = reify (m, z) $     \ (_ :: Proxy s) -> k $ runN (foldMap (N #. h) s :: N m s)-  run1 a (M k h _ _) = k (h a)   runOf l s (M k h m (z :: m)) = reify (m, z) $     \ (_ :: Proxy s) -> k $ runN (foldMapOf l (N #. h) s :: N m s)   prefix s (M k h m (z :: m)) = reify (m, z) $     \ (_ :: Proxy s) -> case runN (foldMap (N #. h) s :: N m s) of       x -> M (\y -> k (m x y)) h m z-  prefix1 a (M k h m z) = case h a of-     x -> M (\y -> k (m x y)) h m z   prefixOf l s (M k h m (z :: m)) = reify (m, z) $     \ (_ :: Proxy s) -> case runN (foldMapOf l (N #. h) s :: N m s) of       x -> M (\y -> k (m x y)) h m z   postfix (M k h m (z :: m)) s = reify (m, z) $     \ (_ :: Proxy s) -> case runN (foldMap (N #. h) s :: N m s) of       y -> M (\x -> k (m x y)) h m z-  postfix1 (M k h m z) a = case h a of-     y -> M (\x -> k (m x y)) h m z   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@@ -133,8 +135,12 @@ instance Monad (M a) where   return = pure   {-# INLINE return #-}+   m >>= f = M (\xs a -> run xs (f a)) One Two Zero <*> m   {-# INLINE (>>=) #-}++  _ >> n = n+  {-# INLINE (>>) #-}  instance Extend (M a) where   extended = extend

@@ -0,0 +1,153 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE ExistentialQuantification #-}+module Data.Fold.M1+  ( M1(..)+  ) where++import Control.Applicative+import Control.Arrow+import Control.Category+import Control.Lens+import Data.Fold.Class+import Data.Fold.Internal+import Data.Functor.Apply+import Data.Pointed+import Data.Profunctor+import Data.Profunctor.Unsafe+import Data.Semigroupoid+import Prelude hiding (id,(.))+import Unsafe.Coerce++-- | A semigroup reducer+data M1 a b = forall m. M1 (m -> b) (a -> m) (m -> m -> m)++instance Scan M1 where+  run1 a (M1 k h _) = k (h a)+  prefix1 a (M1 k h m) = case h a of+     x -> M1 (\y -> k (m x y)) h m+  postfix1 (M1 k h m) a = case h a of+     y -> M1 (\x -> k (m x y)) h m+  interspersing a (M1 k h m) = M1 k h m' where+    m' x y = x `m` h a `m` y+  {-# INLINE run1 #-}+  {-# INLINE prefix1 #-}+  {-# INLINE postfix1 #-}+  {-# INLINE interspersing #-}++instance Functor (M1 a) where+  fmap f (M1 k h m) = M1 (f.k) h m+  {-# INLINE fmap #-}+  b <$ _ = pure b+  {-# INLINE (<$) #-}++instance Pointed (M1 a) where+  point x = M1 (\() -> x) (\_ -> ()) (\() () -> ())+  {-# INLINE point #-}++instance Apply (M1 a) where+  (<.>) = (<*>)+  {-# INLINE (<.>) #-}+  (<.) m = \_ -> m+  {-# INLINE (<.) #-}+  _ .> m = m+  {-# INLINE (.>) #-}++instance Applicative (M1 a) where+  pure x = M1 (\() -> x) (\_ -> ()) (\() () -> ())+  {-# INLINE pure #-}+  M1 kf hf mf <*> M1 ka ha ma = M1+    (\(Pair' x y) -> kf x (ka y))+    (\a -> Pair' (hf a) (ha a))+    (\(Pair' x1 y1) (Pair' x2 y2) -> Pair' (mf x1 x2) (ma y1 y2))+  (<*) m = \ _ -> m+  {-# INLINE (<*) #-}+  _ *> m = m+  {-# INLINE (*>) #-}++instance Monad (M1 a) where+  return x = M1 (\() -> x) (\_ -> ()) (\() () -> ())+  {-# INLINE return #-}+  m >>= f = M1 (\xs a -> walk xs (f a)) Tip1 Bin1 <*> m where+  {-# INLINE (>>=) #-}+  _ >> n = n+  {-# INLINE (>>) #-}++instance Semigroupoid M1 where+  o = (.)+  {-# INLINE o #-}++instance Category M1 where+  id = M1 id id const+  {-# INLINE id #-}+  M1 k h m . M1 k' h' m' = M1 (\(Pair' b _) -> k b) h'' m'' where+    m'' (Pair' a b) (Pair' c d) = Pair' (m a c) (m' b d)+    h'' a = Pair' (h (k' d)) d where d = h' a+  {-# INLINE (.) #-}++instance Arrow M1 where+  arr h = M1 h id const+  {-# INLINE arr #-}+  first (M1 k h m) = M1 (first k) (first h) m' where+    m' (a,b) (c,_) = (m a c, b)+  {-# INLINE first #-}+  second (M1 k h m) = M1 (second k) (second h) m' where+    m' (a,b) (_,c) = (a, m b c)+  {-# INLINE second #-}+  M1 k h m *** M1 k' h' m' = M1 (k *** k') (h *** h') m'' where+    m'' (a,b) (c,d) = (m a c, m' b d)+  {-# INLINE (***) #-}+  M1 k h m &&& M1 k' h' m' = M1 (k *** k') (h &&& h') m'' where+    m'' (a,b) (c,d) = (m a c, m' b d)+  {-# INLINE (&&&) #-}++instance Profunctor M1 where+  dimap f g (M1 k h m) = M1 (g.k) (h.f) m+  {-# INLINE dimap #-}+  lmap f (M1 k h m) = M1 (k) (h.f) m+  {-# INLINE lmap #-}+  rmap g (M1 k h m) = M1 (g.k) h m+  {-# INLINE rmap #-}+  ( #. ) _ = unsafeCoerce+  {-# INLINE (#.) #-}+  x .# _ = unsafeCoerce x+  {-# INLINE (.#) #-}++instance Strong M1 where+  first' = first+  {-# INLINE first' #-}+  second' = second+  {-# INLINE second' #-}++instance Choice M1 where+  left' (M1 k h m) = M1 (_Left %~ k) (_Left %~ h) step where+    step (Left x) (Left y) = Left (m x y)+    step (Right c) _ = Right c+    step _ (Right c) = Right c+  {-# INLINE left' #-}++  right' (M1 k h m) = M1 (_Right %~ k) (_Right %~ h) step where+    step (Right x) (Right y) = Right (m x y)+    step (Left c) _ = Left c+    step _ (Left c) = Left c+  {-# INLINE right' #-}++instance ArrowChoice M1 where+  left (M1 k h m) = M1 (_Left %~ k) (_Left %~ h) step where+    step (Left x) (Left y) = Left (m x y)+    step (Right c) _ = Right c+    step _ (Right c) = Right c+  {-# INLINE left #-}++  right (M1 k h m) = M1 (_Right %~ k) (_Right %~ h) step where+    step (Right x) (Right y) = Right (m x y)+    step (Left c) _ = Left c+    step _ (Left c) = Left c+  {-# INLINE right #-}++data Tree1 a = Bin1 (Tree1 a) (Tree1 a) | Tip1 a++walk :: Tree1 a -> M1 a b -> b+walk xs0 (M1 k h m) = k (go xs0) where+  go (Tip1 a) = h a+  go (Bin1 xs ys) = m (go xs) (go ys)+{-# INLINE walk #-}

@@ -20,35 +20,37 @@ import Unsafe.Coerce import Prelude hiding (foldr, sum, product, length) --- right folds+-- | right folds / a reversed Moore machine data R a b = forall r. R (r -> b) (a -> r -> r) r +instance Scan R where+  run1 t (R k h z)    = k (h t z)+  prefix1 a           = extend (run1 a)+  postfix1 t a        = run1 a (duplicate t)+  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 run1 #-}+  {-# INLINE prefix1 #-}+  {-# INLINE postfix1 #-}+  {-# INLINE interspersing #-}+ -- | leaky 'prefix', efficient 'postfix' instance Folding R where   run t (R k h z)     = k (foldr h z t)-  run1 t (R k h z)    = k (h t z)   runOf l s (R k h z) = k (foldrOf l h z s)   prefix s            = extend (run s)-  prefix1 a           = extend (run1 a)   prefixOf l s        = extend (runOf l s)   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@@ -102,6 +104,9 @@    m >>= f = R (\xs a -> run xs (f a)) (:) [] <*> m   {-# INLINE (>>=) #-}++  _ >> n = n+  {-# INLINE (>>) #-}  instance Applicative (R a) where   pure b = R (\() -> b) (\_ () -> ()) ()

@@ -0,0 +1,150 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE ExistentialQuantification #-}+module Data.Fold.R1+  ( R1(..)+  ) where++import Control.Applicative+import Control.Arrow+import Control.Category+import Control.Lens+import Data.Fold.Class+import Data.Fold.Internal+import Data.Functor.Apply+import Data.Pointed+import Data.Profunctor+import Data.Profunctor.Unsafe+import Data.Semigroupoid+import Prelude hiding (id,(.))+import Unsafe.Coerce++-- | A reversed Mealy machine+data R1 a b = forall c. R1 (c -> b) (a -> c -> c) (a -> c)++instance Scan R1 where+  run1 a (R1 k _ z) = k (z a)+  prefix1 a (R1 k h z) = R1 (\c -> k (h a c)) h z+  postfix1 (R1 k h z) a = R1 k h (\c -> h c (z a))+  interspersing a (R1 k h z) = R1 k (\b x -> h b (h a x)) z+  {-# INLINE run1 #-}+  {-# INLINE prefix1 #-}+  {-# INLINE postfix1 #-}+  {-# INLINE interspersing #-}++instance Functor (R1 a) where+  fmap f (R1 k h z) = R1 (f.k) h z+  {-# INLINE fmap #-}+  b <$ _ = pure b+  {-# INLINE (<$) #-}++instance Pointed (R1 a) where+  point x = R1 (\() -> x) (\_ () -> ()) (\_ -> ())+  {-# INLINE point #-}++instance Apply (R1 a) where+  (<.>) = (<*>)+  {-# INLINE (<.>) #-}+  (<.) m = \_ -> m+  {-# INLINE (<.) #-}+  _ .> m = m+  {-# INLINE (.>) #-}++instance Applicative (R1 a) where+  pure x = R1 (\() -> x) (\_ () -> ()) (\_ -> ())+  {-# INLINE pure #-}+  R1 kf hf zf <*> R1 ka ha za = R1+    (\(Pair' x y) -> kf x (ka y))+    (\a (Pair' x y) -> Pair' (hf a x) (ha a y))+    (\a -> Pair' (zf a) (za a))+  (<*) m = \ _ -> m+  {-# INLINE (<*) #-}+  _ *> m = m+  {-# INLINE (*>) #-}++instance Monad (R1 a) where+  return x = R1 (\() -> x) (\_ () -> ()) (\_ -> ())+  {-# INLINE return #-}+  m >>= f = R1 (\xs a -> walk xs (f a)) Cons1 Last <*> m where+  {-# INLINE (>>=) #-}+  _ >> n = n+  {-# INLINE (>>) #-}++instance Semigroupoid R1 where+  o = (.)+  {-# INLINE o #-}++instance Category R1 where+  id = arr id+  {-# INLINE id #-}+  R1 k h z . R1 k' h' z' = R1 (\(Pair' b _) -> k b) h'' z'' where+    z'' a = Pair' (z (k' b)) b where b = z' a+    h'' a (Pair' c d) = Pair' (h (k' d') c) d' where d' = h' a d+  {-# INLINE (.) #-}++instance Arrow R1 where+  arr h = R1 h const id+  {-# INLINE arr #-}+  first (R1 k h z) = R1 (first k) h' (first z) where+    h' (a,b) (c,_) = (h a c, b)+  {-# INLINE first #-}+  second (R1 k h z) = R1 (second k) h' (second z) where+    h' (a,b) (_,c) = (a, h b c)+  {-# INLINE second #-}+  R1 k h z *** R1 k' h' z' = R1 (k *** k') h'' (z *** z') where +    h'' (a,b) (c,d) = (h a c, h' b d)+  {-# INLINE (***) #-}+  R1 k h z &&& R1 k' h' z' = R1 (k *** k') h'' (z &&& z') where+    h'' a (c,d) = (h a c, h' a d)+  {-# INLINE (&&&) #-}++instance Profunctor R1 where+  dimap f g (R1 k h z) = R1 (g.k) (h.f) (z.f)+  {-# INLINE dimap #-}+  lmap f (R1 k h z) = R1 (k) (h.f) (z.f)+  {-# INLINE lmap #-}+  rmap g (R1 k h z) = R1 (g.k) h z+  {-# INLINE rmap #-}+  ( #. ) _ = unsafeCoerce+  {-# INLINE (#.) #-}+  x .# _ = unsafeCoerce x+  {-# INLINE (.#) #-}++instance Strong R1 where+  first' = first+  {-# INLINE first' #-}+  second' = second+  {-# INLINE second' #-}++instance Choice R1 where+  left' (R1 k h z) = R1 (_Left %~ k) step (_Left %~ z) where+    step (Left x) (Left y) = Left (h x y)+    step (Right c) _ = Right c+    step _ (Right c) = Right c+  {-# INLINE left' #-}++  right' (R1 k h z) = R1 (_Right %~ k) step (_Right %~ z) where+    step (Right x) (Right y) = Right (h x y)+    step (Left c) _ = Left c+    step _ (Left c) = Left c+  {-# INLINE right' #-}++instance ArrowChoice R1 where+  left (R1 k h z) = R1 (_Left %~ k) step (_Left %~ z) where+    step (Left x) (Left y) = Left (h x y)+    step (Right c) _ = Right c+    step _ (Right c) = Right c+  {-# INLINE left #-}++  right (R1 k h z) = R1 (_Right %~ k) step (_Right %~ z) where+    step (Right x) (Right y) = Right (h x y)+    step (Left c) _ = Left c+    step _ (Left c) = Left c+  {-# INLINE right #-}++data List1 a = Cons1 a (List1 a) | Last a++walk :: List1 a -> R1 a b -> b+walk xs0 (R1 k h z) = k (go xs0) where+  go (Last a) = z a+  go (Cons1 a as) = h a (go as)+{-# INLINE walk #-}