e411ab6 · streamly · git.iko.soy

git.iko.soy/streamly

Remove MonadError instance temporarily

It is not working correctly for parallel compositions.

commite411ab6abd63d81e854b60e6d6f6ccf67c6b77c2 authorHarendra Kumar <harendra.kumar@gmail.com> dateSun 22 Apr 2018, 22:57 (9 years ago) parent30a6e32

4 files changed+109−4

compare with master

unifiedsplit

Changelog.md+2 src/Streamly/Streams.hs+3−1 streamly.cabal+3−3 test/Main.hs+101

Changelog.md+2

@@ -28,6 +28,8 @@

2828 Stream types may have to be changed or type combinators may have to be added

2929 or removed to adapt to this change.

3030* Change the type of `foldrM` to make it consistent with `foldrM` in base.

31+* Remove the MonadError instance as it was not working correctly for the

32+ parallel compositions. Use MonadThrow instead for error propagation.

3133

3234### Deprecations

3335* Deprecate and rename the following symbols:

src/Streamly/Streams.hs+3−1

@@ -107,7 +107,7 @@ import Control.Applicative (liftA2)

107107import Control.Monad (ap)

108108import Control.Monad.Base (MonadBase (..), liftBaseDefault)

109109import Control.Monad.Catch (MonadThrow, throwM)

110−import Control.Monad.Error.Class (MonadError(..))

110+-- import Control.Monad.Error.Class (MonadError(..))

111111import Control.Monad.IO.Class (MonadIO(..))

112112import Control.Monad.Reader.Class (MonadReader(..))

113113import Control.Monad.State.Class (MonadState(..))

@@ -291,10 +291,12 @@ instance (MonadIO m CONSTRAINT) => MonadIO (STREAM m) where { \

291291instance (MonadThrow m CONSTRAINT) => MonadThrow (STREAM m) where { \

292292 throwM = lift . throwM }; \

293293 \

294+{- \

294295instance (MonadError e m CONSTRAINT) => MonadError e (STREAM m) where { \

295296 throwError = lift . throwError; \

296297 catchError m h = \

297298 fromStream $ S.withCatchError (toStream m) (\e -> toStream $ h e) }; \

299+-} \

298300 \

299301instance (MonadReader r m CONSTRAINT) => MonadReader r (STREAM m) where { \

300302 ask = lift ask; \

streamly.cabal+3−3

@@ -149,9 +149,9 @@ test-suite test

149149 , base >= 4.8 && < 5

150150 , hspec >= 2.0 && < 3

151151 , containers >= 0.5 && < 0.6

152− if impl(ghc < 8.0)

153− build-depends:

154− transformers >= 0.4 && < 0.6

152+ , transformers >= 0.4 && < 0.6

153+ , mtl >= 2.2 && < 3

154+ , exceptions >= 0.8 && < 0.11

155155 default-language: Haskell2010

156156

157157test-suite properties

test/Main.hs+101

@@ -5,6 +5,10 @@

55module Main (main) where

77import Control.Concurrent (threadDelay)

8+import Control.Exception (Exception, try)

9+import Control.Monad.Catch (throwM, MonadThrow)

10+import Control.Monad.Error.Class (throwError, MonadError)

11+import Control.Monad.Trans.Except (runExceptT, ExceptT)

812import Data.Foldable (forM_)

913import Data.List (sort)

1014import Test.Hspec

@@ -32,6 +36,7 @@ main :: IO ()

3236main = hspec $ do

3337 describe "Runners" $ do

3438 -- XXX move these to property tests

39+ -- XXX use an IORef to store and check the side effects

3540 it "simple serially" $

3641 (runStream . serially) (return (0 :: Int)) `shouldReturn` ()

3742 it "simple serially with IO" $

@@ -283,6 +288,102 @@ main = hspec $ do

283288

284289 -- TBD combine all binds and all compose in one example

285290 describe "Miscellaneous combined examples" mixedOps

291+ describe "Simple MonadError and MonadThrow" simpleMonadError

292+

293+ {-

294+ describe "Composed MonadError serially" $ composeWithMonadError serially

295+ describe "Composed MonadError coserially" $ composeWithMonadError coserially

296+ describe "Composed MonadError coparallely" $ composeWithMonadError coparallely

297+ describe "Composed MonadError parallely" $ composeWithMonadError parallely

298+ -}

299+

300+ describe "Composed MonadThrow serially" $ composeWithMonadThrow serially

301+ describe "Composed MonadThrow coserially" $ composeWithMonadThrow coserially

302+ describe "Composed MonadThrow coparallely" $ composeWithMonadThrow coparallely

303+ describe "Composed MonadThrow parallely" $ composeWithMonadThrow parallely

304+

305+-- XXX need to test that we have promptly cleaned up everything after the error

306+-- XXX We can also check the output that we are expected to get before the

307+-- error occurs.

308+

309+data ExampleException = ExampleException String deriving (Eq, Show)

310+

311+instance Exception ExampleException

312+

313+simpleMonadError :: Spec

314+simpleMonadError = do

315+{-

316+ it "simple runExceptT" $ do

317+ (runExceptT $ runStream $ return ())

318+ `shouldReturn` (Right () :: Either String ())

319+ it "simple runExceptT with error" $ do

320+ (runExceptT $ runStream $ throwError "E") `shouldReturn` Left "E"

321+ -}

322+ it "simple try" $ do

323+ (try $ runStream $ return ())

324+ `shouldReturn` (Right () :: Either ExampleException ())

325+ it "simple try with throw error" $ do

326+ (try $ runStream $ throwM $ ExampleException "E")

327+ `shouldReturn` (Left (ExampleException "E") :: Either ExampleException ())

328+

329+composeWithMonadThrow

330+ :: ( IsStream t

331+ , Semigroup (t IO Int)

332+ , MonadThrow (t IO)

333+ )

334+ => (t IO Int -> SerialT IO Int) -> Spec

335+composeWithMonadThrow t = do

336+ it "Compose throwM, nil" $

337+ (try $ tl (throwM (ExampleException "E") <> A.nil))

338+ `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])

339+ it "Compose nil, throwM" $

340+ (try $ tl (A.nil <> throwM (ExampleException "E")))

341+ `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])

342+ oneLevelNestedSum "serially" serially

343+ oneLevelNestedSum "coserially" coserially

344+ oneLevelNestedSum "coparallely" coparallely

345+ oneLevelNestedSum "parallely" parallely

346+ -- XXX add two level nesting

347+

348+ oneLevelNestedProduct "serially" serially

349+ oneLevelNestedProduct "coserially" coserially

350+ oneLevelNestedProduct "coparallely" coparallely

351+ oneLevelNestedProduct "parallely" parallely

352+

353+ where

354+ tl = A.toList . t

355+ oneLevelNestedSum desc t1 =

356+ it ("One level nested sum " ++ desc) $ do

357+ let nested = (A.fromFoldable [1..10] <> throwM (ExampleException "E")

358+ <> A.fromFoldable [1..10])

359+ (try $ tl (A.nil <> t1 nested <> A.fromFoldable [1..10]))

360+ `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])

361+

362+ oneLevelNestedProduct desc t1 =

363+ it ("One level nested product" ++ desc) $ do

364+ let s1 = t $ foldMapWith (<>) return [1..4]

365+ s2 = t1 $ foldMapWith (<>) return [5..8]

366+ try $ tl (do

367+ x <- adapt s1

368+ y <- s2

369+ if (x + y > 10)

370+ then throwM (ExampleException "E")

371+ else return (x + y)

372+ )

373+ `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int])

374+

375+_composeWithMonadError

376+ :: ( IsStream t

377+ , Semigroup (t (ExceptT String IO) Int)

378+ , MonadError String (t (ExceptT String IO))

379+ )

380+ => (t (ExceptT String IO) Int -> SerialT (ExceptT String IO) Int) -> Spec

381+_composeWithMonadError t = do

382+ let tl = A.toList . t

383+ it "Compose throwError, nil" $

384+ (runExceptT $ tl (throwError "E" <> A.nil)) `shouldReturn` Left "E"

385+ it "Compose nil, error" $

386+ (runExceptT $ tl (A.nil <> throwError "E")) `shouldReturn` Left "E"

286387

287388nestTwoSerial :: Expectation

288389nestTwoSerial =