foldl-transduce 0.4.3.0 → 0.4.4.0

raw patch · 4 files changed

+140/−38 lines, 4 filesdep +profunctorsdep +tasty-quickcheckdep +voidPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: profunctors, tasty-quickcheck, void

API changes (from Hackage documentation)

Files

• CHANGELOG +6/−0
• foldl-transduce.cabal +4/−1
• src/Control/Foldl/Transduce.hs +104/−36
• tests/tests.hs +26/−1

@@ -1,4 +1,10 @@+# 0.4.4.0++- deprecated quiesceWith+- added Fallible.+ # 0.4.3.0+ - deprecated splitWhen in favor of break - deprecated textualSplitWhen in favor of textualBreak 

@@ -1,5 +1,5 @@ Name: foldl-transduce-Version: 0.4.3.0+Version: 0.4.4.0 Cabal-Version: >=1.8.0.2 Build-Type: Simple License: BSD3@@ -29,10 +29,12 @@         transformers  >= 0.2.0.0  && < 0.5 ,         containers                   < 0.6 ,         bifunctors    == 5.*               ,+        profunctors   == 5.*               ,         semigroupoids >= 5.0               ,         foldl         >= 1.1      && < 2   ,         comonad       == 4.*               ,         free          == 4.*               ,         +        void          >= 0.6               ,         monoid-subclasses == 0.4.*              Exposed-Modules:         Control.Foldl.Transduce,@@ -63,6 +65,7 @@         text                ,         tasty >= 0.10.1.1   ,         tasty-hunit >= 0.9.2,+        tasty-quickcheck >= 0.8.3.2,          monoid-subclasses == 0.4.*,         foldl               ,         foldl-transduce

@@ -6,11 +6,20 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} --- |------ This module builds on module "Control.Foldl", adding stateful transducers--- and grouping operations.+{-| This module builds on module "Control.Foldl", adding stateful transducers+    and grouping operations. +>>> L.fold (transduce (surround "[" "]") L.list) "middle"+"[middle]"++>>> L.fold (folds (chunksOf 2) L.length L.list) "aabbccdd"+[2,2,2,2]++>>> L.fold (groups (chunksOf 2) (surround "[" "]") L.list) "aabbccdd"+"[aa][bb][cc][dd]"++-}+ module Control.Foldl.Transduce (         -- * Transducer types         Transduction @@ -71,11 +80,11 @@     ,   condenseM     ,   hoistTransducer         -- * Fold utilities-    ,   quiesce-    ,   quiesceWith     ,   hoistFold     ,   unit     ,   trip+    ,   quiesce+    ,   Fallible(..)     ,   ToFold(..)     ,   ToFoldM(..)         -- * Re-exports@@ -85,12 +94,16 @@     ,   module Control.Comonad.Cofree         -- * Deprecated     ,   splitWhen+    ,   quiesceWith     ) where  import Prelude hiding (splitAt,break) +import Data.Functor import Data.Bifunctor+import Data.Profunctor import Data.Monoid+import Data.Void import qualified Data.Monoid.Cancellative as CM import qualified Data.Monoid.Null as NM import qualified Data.Monoid.Factorial as SFM@@ -101,6 +114,7 @@ import Control.Applicative import Control.Monad import Control.Monad.IO.Class+import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Comonad import Control.Comonad.Cofree @@ -312,6 +326,7 @@ instance Monad m => ToFoldM m Fold where     toFoldM = L.generalize + {-| Apply a 'Transducer' to a 'Fold', discarding the return value of the     'Transducer'.		 @@ -538,42 +553,95 @@                     Left e -> return (Left e)                     Right r -> return (Right r) -{-| Generalized version of 'quiesce' to turn a fallible 'FoldM' into another-    that starts a "fallback fold" when it encounters an error.+--{-| Generalized version of 'quiesce' to turn a fallible 'FoldM' into another+--    that starts a "fallback fold" when it encounters an error.+--+--    "Start folding this way, if you encounter an error, start folding this +--    other way".                               +--+-- >>> L.foldM (quiesceWith (L.generalize L.length) (FoldM (\_ _-> throwE ()) (return ()) (\_ -> throwE ()))) [1..7]+-- Left ((),7)+---}+{-# DEPRECATED quiesceWith "The signature of this function will change." #-}+quiesceWith :: (Functor m,Monad m) => FoldM m a v -> FoldM (ExceptT e m) a r -> FoldM m a (Either (e,v) r)+quiesceWith fallback original = hoistFold (fmap (either absurd id) . runExceptT) (getFallible (do+    e <- Fallible (fmap Right original)+    Fallible (hoistFold lift (fmap (\x -> Left (e,x)) fallback)))) -    "Start folding this way, if you encounter an error, start folding this -    other way".                               +newtype Fallible m r i e = Fallible { getFallible :: FoldM (ExceptT e m) i r } ->>> L.foldM (quiesceWith (L.generalize L.length) (FoldM (\_ _-> throwE ()) (return ()) (\_ -> throwE ()))) [1..7]-Left ((),7)--}-quiesceWith :: (Functor m,Monad m) => FoldM m a v -> FoldM (ExceptT e m) a r -> FoldM m a (Either (e,v) r)-quiesceWith fallbackFold (FoldM step initial done) = -    FoldM step' (runExceptT (withExceptT (Pair fallbackFold) initial)) done'-    where-    step' x i = do  -        case x of-            Left (Pair ffold e) -> do-                ffold' <- L.foldM (duplicated ffold) [i]-                return (Left (Pair ffold' e))+bindFallible :: (Functor m,Monad m) => Fallible m r i e -> (e -> Fallible m r i e') -> Fallible m r i e'+bindFallible (Fallible (FoldM step initial done)) k =+    Fallible (FoldM step' (lift (runExceptT (withExceptT (getFallible . k) initial))) done')+    where +        step' x i = ExceptT (case x of+            Left ffold -> do+                rx <- runExceptT (L.foldM (duplicated ffold) [i])+                case rx of+                    Left e' -> return (Left e') -- true failure+                    Right ffold' -> return (Right (Left ffold'))             Right notyetfail -> do                  x' <- runExceptT (step notyetfail i)                  case x' of                      Left e -> do-                         ffold <- L.foldM (duplicated fallbackFold) [i]-                         return (Left (Pair ffold e))-                     Right x'' -> return (Right x'')-    done' x = case x of-            Left (Pair ffold e) -> do-                alternativeResult <- L.foldM ffold []-                return (Left (e,alternativeResult))-            Right notyetfail -> do -                x' <- runExceptT (done notyetfail)-                case x' of-                    Left e -> do-                        alternativeResult <- L.foldM fallbackFold []-                        return (Left (e,alternativeResult))-                    Right x'' -> return (Right x'')+                         return (Right (Left ((getFallible . k) e)))+                     Right x'' -> return (Right (Right x'')))+        done' x = ExceptT (case x of+            Left ffold -> do+                rx <- runExceptT (L.foldM ffold [])+                case rx of+                    Left e' -> return (Left e') -- true failure+                    Right r -> return (Right r)+            Right notyetfail -> do+                 x' <- runExceptT (done notyetfail)+                 case x' of+                     Left e -> do+                         runExceptT (done' (Left (getFallible (k e))))+                     Right x'' -> return (Right x''))++instance (Functor m, Monad m) => Functor (Fallible m r i) where+    fmap g (Fallible fallible) = +        Fallible (hoistFold (withExceptT g) fallible)+++{-| 'pure' creates a 'Fallible' that starts in a failed state.		++-}+instance (Functor m,Monad m) => Applicative (Fallible m r i) where+    pure e = Fallible (FoldM (\_ _ -> throwE e) (throwE e) (\_ -> throwE e))++    u <*> v = u >>= \f -> fmap f v++instance (Functor m, Monad m) => Profunctor (Fallible m r) where+    lmap f (Fallible fallible) = +        Fallible (L.premapM f fallible)++    rmap g (Fallible fallible) = +        Fallible (hoistFold (withExceptT g) fallible)++{-| Fail immediately when an input comes in the wrong branch.		++-}+instance (Functor m,Monad m,Monoid r) => Choice (Fallible m r) where+    left' (Fallible fallible) = +        Fallible (liftA2 mappend (hoistFold (withExceptT Left) (L.handlesM _Left fallible)) (hoistFold (withExceptT Right) (L.handlesM _Right (trip $> mempty))))++_Left :: Applicative f => (a -> f a) -> Either a b -> f (Either a b)+_Left f e = case e of+    Right b -> pure (Right b)+    Left a -> fmap Left (f a)++_Right :: Applicative f => (b -> f b) -> Either a b -> f (Either a b)+_Right f e = case e of+    Left b -> pure (Left b)+    Right a -> fmap Right (f a)++{-| '>>=' continues folding after an error using a 'Fallible' constructed from the error.		++-}+instance (Functor m,Monad m) => Monad (Fallible m r i) where+    (>>=) = bindFallible+    return = pure  {-| The "do-nothing" fold.		 

@@ -1,14 +1,16 @@ module Main where -import Prelude hiding (splitAt)+import Prelude hiding (splitAt,lines,words) import Data.String hiding (lines,words) import Data.Monoid import Data.Bifunctor import qualified Data.Monoid.Factorial as SFM import Test.Tasty import Test.Tasty.HUnit+import Test.Tasty.QuickCheck  import qualified Data.Text as T+import qualified Data.Text.Lazy as TL  import qualified Control.Foldl as L import Control.Foldl.Transduce@@ -18,6 +20,15 @@ main :: IO () main = defaultMain tests +newtype WordQC = WordQC { getWordQC :: T.Text } deriving (Show)++instance Arbitrary WordQC where+    arbitrary = do+        firstChar <- oneof [pure ' ', pure '\n', arbitrary]+        lastChar <- oneof [pure ' ', pure '\n', arbitrary]+        middle <- listOf (frequency [(1,pure ' '),(4,arbitrary)])+        return (WordQC (T.pack (firstChar : (middle ++ [lastChar]))))+ tests :: TestTree tests =      testGroup "Tests" @@ -72,6 +83,20 @@                 assertEqual mempty                 (T.pack "\n")                 (mconcat (L.fold (transduce newline L.list) (map T.pack [""])))+        ]+        ,+        testGroup "words" +        [ +            testGroup "quickcheck" +            [ +                testProperty "quickcheck1" (\chunks -> +                         let tchunks = fmap getWordQC chunks +                         in+                         (case TL.words (TL.fromChunks tchunks) of+                            [] -> [mempty]+                            x -> x) ==+                         (fmap TL.fromChunks (L.fold (folds words L.list L.list) tchunks)))+            ]         ]         ,         testGroup "quiesceWith" $