3093e79 · streamly · git.iko.soy

git.iko.soy/streamly

on master help sign in

change "handle" to produce streams in exception case

3093e79Harendra Kumar7 years ago

benchmark/FileIO.hs+9

compare with master

unifiedsplit

@@ -130,12 +130,21 @@ main = do

130 , mkBench "catOnException" href $ do

131 Handles inh _ <- readIORef href

132 BFS.catOnException devNull inh

133+ , mkBench "catOnExceptionStream" href $ do

134+ Handles inh _ <- readIORef href

135+ BFS.catOnExceptionStream devNull inh

133 , mkBench "catHandle" href $ do

136 , mkBench "catHandle" href $ do

134 Handles inh _ <- readIORef href

137 Handles inh _ <- readIORef href

135 BFS.catHandle devNull inh

138 BFS.catHandle devNull inh

139+ , mkBench "catHandleStream" href $ do

140+ Handles inh _ <- readIORef href

141+ BFS.catHandleStream devNull inh

136 , mkBench "catFinally" href $ do

142 , mkBench "catFinally" href $ do

137 Handles inh _ <- readIORef href

143 Handles inh _ <- readIORef href

138 BFS.catFinally devNull inh

144 BFS.catFinally devNull inh

145+ , mkBench "catFinallyStream" href $ do

146+ Handles inh _ <- readIORef href

147+ BFS.catFinallyStream devNull inh

139 , mkBench "catBracketStream" href $ do

148 , mkBench "catBracketStream" href $ do

140 Handles inh _ <- readIORef href

149 Handles inh _ <- readIORef href

141 BFS.catBracketStream devNull inh

150 BFS.catBracketStream devNull inh

src/Streamly/Benchmark/FileIO/Stream.hs+26−1

@@ -33,8 +33,11 @@ module Streamly.Benchmark.FileIO.Stream

33 , catBracket

34 , catBracketStream

35 , catOnException

36+ , catOnExceptionStream

36 , catHandle

37 , catHandle

38+ , catHandleStream

37 , catFinally

39 , catFinally

40+ , catFinallyStream

38 , copy

41 , copy

39 , linesUnlinesCopy

42 , linesUnlinesCopy

40 , wordsUnwordsCopyWord8

43 , wordsUnwordsCopyWord8

@@ -227,6 +230,13 @@ inspect $ hasNoTypeClasses 'catOnException

227-- inspect $ 'catOnException `hasNoType` ''D.ConcatMapUState

230-- inspect $ 'catOnException `hasNoType` ''D.ConcatMapUState

228#endif

231#endif

229

232

233+-- | Send the file contents to /dev/null with exception handling

234+{-# INLINE catOnExceptionStream #-}

235+catOnExceptionStream :: Handle -> Handle -> IO ()

236+catOnExceptionStream devNull inh =

237+ let readEx = S.onException (hClose inh) (S.unfold FH.read inh)

238+ in S.fold (FH.write devNull) $ readEx

239+

230-- | Send the file contents to /dev/null with exception handling

240-- | Send the file contents to /dev/null with exception handling

231{-# INLINE catFinally #-}

241{-# INLINE catFinally #-}

232catFinally :: Handle -> Handle -> IO ()

242catFinally :: Handle -> Handle -> IO ()

@@ -241,11 +251,18 @@ inspect $ hasNoTypeClasses 'catFinally

241-- inspect $ 'catFinally `hasNoType` ''D.ConcatMapUState

251-- inspect $ 'catFinally `hasNoType` ''D.ConcatMapUState

242#endif

252#endif

243

253

254+-- | Send the file contents to /dev/null with exception handling

255+{-# INLINE catFinallyStream #-}

256+catFinallyStream :: Handle -> Handle -> IO ()

257+catFinallyStream devNull inh =

258+ let readEx = S.finally (hClose inh) (S.unfold FH.read inh)

259+ in S.fold (FH.write devNull) readEx

260+

244-- | Send the file contents to /dev/null with exception handling

261-- | Send the file contents to /dev/null with exception handling

245{-# INLINE catHandle #-}

262{-# INLINE catHandle #-}

246catHandle :: Handle -> Handle -> IO ()

263catHandle :: Handle -> Handle -> IO ()

247catHandle devNull inh =

264catHandle devNull inh =

248− let handler = \(_e :: SomeException) -> hClose inh >> return 10

265+ let handler (_e :: SomeException) = hClose inh >> return 10

249 readEx = IUF.handle (IUF.singleton handler) FH.read

266 readEx = IUF.handle (IUF.singleton handler) FH.read

250 in S.fold (FH.write devNull) $ S.unfold readEx inh

267 in S.fold (FH.write devNull) $ S.unfold readEx inh

251

268

@@ -256,6 +273,14 @@ inspect $ hasNoTypeClasses 'catHandle

256-- inspect $ 'catHandle `hasNoType` ''D.ConcatMapUState

273-- inspect $ 'catHandle `hasNoType` ''D.ConcatMapUState

257#endif

274#endif

258

275

276+-- | Send the file contents to /dev/null with exception handling

277+{-# INLINE catHandleStream #-}

278+catHandleStream :: Handle -> Handle -> IO ()

279+catHandleStream devNull inh =

280+ let handler (_e :: SomeException) = S.yieldM (hClose inh >> return 10)

281+ readEx = S.handle handler (S.unfold FH.read inh)

282+ in S.fold (FH.write devNull) $ readEx

283+

259-- | Copy file

284-- | Copy file

260{-# INLINE copy #-}

285{-# INLINE copy #-}

261copy :: Handle -> Handle -> IO ()

286copy :: Handle -> Handle -> IO ()

src/Streamly/Internal/Data/Unfold.hs+12−7

@@ -106,6 +106,7 @@ module Streamly.Internal.Data.Unfold

106 , outerProduct

107

108 -- * Exceptions

109+ , gbracket

109 , before

110 , before

110 , after

111 , after

111 , onException

112 , onException

@@ -553,16 +554,20 @@ concatMapM f (Unfold step1 inject1) = Unfold step inject

553-- Exceptions

554-- Exceptions

554------------------------------------------------------------------------------

555------------------------------------------------------------------------------

555

556

556−-- MBD: If we add an (Unfold m e b) argument to it we can encompass "handle" as

557+-- | The most general bracketing and exception combinator. All other

557−-- well under this.

558+-- combinators can be expressed in terms of this combinator. This can also be

559+-- used for cases which are not covered by the standard combinators.

560+--

561+-- /Internal/

562+--

558{-# INLINE_NORMAL gbracket #-}

563{-# INLINE_NORMAL gbracket #-}

559gbracket

564gbracket

560 :: Monad m

565 :: Monad m

561− => (a -> m c)

566+ => (a -> m c) -- ^ before

562− -> (forall s. m s -> m (Either e s))

567+ -> (forall s. m s -> m (Either e s)) -- ^ try (exception handling)

563− -> (c -> m d)

568+ -> (c -> m d) -- ^ after, on normal stop

564− -> Unfold m (c, e) b

569+ -> Unfold m (c, e) b -- ^ on exception

565− -> Unfold m c b

570+ -> Unfold m c b -- ^ unfold to run

566 -> Unfold m a b

571 -> Unfold m a b

567gbracket bef exc aft (Unfold estep einject) (Unfold step1 inject1) =

572gbracket bef exc aft (Unfold estep einject) (Unfold step1 inject1) =

568 Unfold step inject

573 Unfold step inject

src/Streamly/Internal/Prelude.hs+3−2

@@ -3504,5 +3504,6 @@ bracket bef aft bet = D.fromStreamD $

3504-- @since 0.7.0

3505{-# INLINE handle #-}

3506handle :: (IsStream t, MonadCatch m, Exception e)

3507− => (e -> m a) -> t m a -> t m a

3507+ => (e -> t m a) -> t m a -> t m a

3508+handle handler xs =

3508−handle handler xs = D.fromStreamD $ D.handle handler $ D.toStreamD xs

3509+ D.fromStreamD $ D.handle (\e -> D.toStreamD $ handler e) $ D.toStreamD xs

src/Streamly/Streams/StreamD.hs+99−23

@@ -257,6 +257,7 @@ module Streamly.Streams.StreamD

257 , the

258

259 -- * Exceptions

260+ , gbracket

260 , before

261 , before

261 , after

262 , after

262 , bracket

263 , bracket

@@ -273,7 +274,7 @@ module Streamly.Streams.StreamD

273 )

274 )

274where

275where

275

276

276−import Control.Exception (Exception)

277+import Control.Exception (Exception, SomeException)

277import Control.Monad (void)

278import Control.Monad (void)

278import Control.Monad.Catch (MonadCatch)

279import Control.Monad.Catch (MonadCatch)

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

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

@@ -2256,6 +2257,52 @@ interleaveFstThenConcat

2256-- Exceptions

2257-- Exceptions

2257------------------------------------------------------------------------------

2258------------------------------------------------------------------------------

2258

2259

2260+data GbracketState s1 s2 v

2261+ = GBracketInit

2262+ | GBracketNormal s1 v

2263+ | GBracketException s2

2264+

2265+-- | The most general bracketing and exception combinator. All other

2266+-- combinators can be expressed in terms of this combinator. This can also be

2267+-- used for cases which are not covered by the standard combinators.

2268+--

2269+-- /Internal/

2270+--

2271+{-# INLINE_NORMAL gbracket #-}

2272+gbracket

2273+ :: Monad m

2274+ => m c -- ^ before

2275+ -> (forall s. m s -> m (Either e s)) -- ^ try (exception handling)

2276+ -> (c -> m d) -- ^ after, on normal stop

2277+ -> (c -> e -> Stream m b) -- ^ on exception

2278+ -> (c -> Stream m b) -- ^ stream generator

2279+ -> Stream m b

2280+gbracket bef exc aft fexc fnormal =

2281+ Stream step GBracketInit

2282+

2283+ where

2284+

2285+ {-# INLINE_LATE step #-}

2286+ step _ GBracketInit = do

2287+ r <- bef

2288+ return $ Skip $ GBracketNormal (fnormal r) r

2289+

2290+ step gst (GBracketNormal (UnStream step1 st) v) = do

2291+ res <- exc $ step1 gst st

2292+ case res of

2293+ Right r -> case r of

2294+ Yield x s ->

2295+ return $ Yield x (GBracketNormal (Stream step1 s) v)

2296+ Skip s -> return $ Skip (GBracketNormal (Stream step1 s) v)

2297+ Stop -> aft v >> return Stop

2298+ Left e -> return $ Skip (GBracketException (fexc v e))

2299+ step gst (GBracketException (UnStream step1 st)) = do

2300+ res <- step1 gst st

2301+ case res of

2302+ Yield x s -> return $ Yield x (GBracketException (Stream step1 s))

2303+ Skip s -> return $ Skip (GBracketException (Stream step1 s))

2304+ Stop -> return Stop

2305+

2259-- | Run a side effect before the stream yields its first element.

2306-- | Run a side effect before the stream yields its first element.

2260{-# INLINE_NORMAL before #-}

2307{-# INLINE_NORMAL before #-}

2261before :: Monad m => m b -> Stream m a -> Stream m a

2308before :: Monad m => m b -> Stream m a -> Stream m a

@@ -2301,7 +2348,14 @@ after action (Stream step state) = Stream step' state

2301-- exception is not caught, simply rethrown.

2348-- exception is not caught, simply rethrown.

2302{-# INLINE_NORMAL onException #-}

2349{-# INLINE_NORMAL onException #-}

2303onException :: MonadCatch m => m b -> Stream m a -> Stream m a

2350onException :: MonadCatch m => m b -> Stream m a -> Stream m a

2351+onException action str =

2352+ gbracket (return ()) MC.try return

2353+ (\_ (_ :: MC.SomeException) -> nilM $ action)

2354+ (\_ -> str)

2355+

2356+{-# INLINE_NORMAL _onException #-}

2357+_onException :: MonadCatch m => m b -> Stream m a -> Stream m a

2304−onException action (Stream step state) = Stream step' state

2358+_onException action (Stream step state) = Stream step' state

2305

2359

2306 where

2360 where

2307

2361

@@ -2313,13 +2367,6 @@ onException action (Stream step state) = Stream step' state

2313 Skip s -> return $ Skip s

2367 Skip s -> return $ Skip s

2314 Stop -> return Stop

2368 Stop -> return Stop

2315

2369

2316−-- | Run a side effect whenever the stream stops normally or aborts due to an

2317−-- exception.

2318−{-# INLINE finally #-}

2319−finally :: MonadCatch m => m b -> Stream m a -> Stream m a

2320−-- finally action xs = after action $ onException action xs

2321−finally action xs = bracket (return ()) (\_ -> action) (const xs)

2322−

2323-- XXX bracket is like concatMap, it generates a stream and then flattens it.

2370-- XXX bracket is like concatMap, it generates a stream and then flattens it.

2324-- Like concatMap it has 10x worse performance compared to linear fused

2371-- Like concatMap it has 10x worse performance compared to linear fused

2325-- compositions.

2372-- compositions.

@@ -2330,41 +2377,70 @@ finally action xs = bracket (return ()) (\_ -> action) (const xs)

2330-- an exception.

2377-- an exception.

2331{-# INLINE_NORMAL bracket #-}

2378{-# INLINE_NORMAL bracket #-}

2332bracket :: MonadCatch m => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a

2379bracket :: MonadCatch m => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a

2333−bracket bef aft bet = Stream step' Nothing

2380+bracket bef aft bet =

2381+ gbracket bef MC.try aft (\a (_ :: SomeException) -> nilM $ aft a) bet

2382+

2383+data BracketState s v = BracketInit | BracketRun s v

2384+

2385+{-# INLINE_NORMAL _bracket #-}

2386+_bracket :: MonadCatch m => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a

2387+_bracket bef aft bet = Stream step' BracketInit

2334

2388

2335 where

2389 where

2336

2390

2337 {-# INLINE_LATE step' #-}

2391 {-# INLINE_LATE step' #-}

2338− step' _ Nothing = bef >>= \x -> return (Skip (Just (bet x, x)))

2392+ step' _ BracketInit = bef >>= \x -> return (Skip (BracketRun (bet x) x))

2339

2393

2340 -- NOTE: It is important to use UnStream instead of the Stream pattern

2394 -- NOTE: It is important to use UnStream instead of the Stream pattern

2341 -- here, otherwise we get huge perf degradation, see note in concatMap.

2395 -- here, otherwise we get huge perf degradation, see note in concatMap.

2342− step' gst (Just (UnStream step state, v)) = do

2396+ step' gst (BracketRun (UnStream step state) v) = do

2343− res <- step gst state `MC.onException` aft v

2397+ -- res <- step gst state `MC.onException` aft v

2398+ res <- MC.try $ step gst state

2344 case res of

2399 case res of

2400+ Left (_ :: SomeException) -> aft v >> return Stop

2401+ Right r -> case r of

2345− Yield x s -> return $ Yield x (Just (Stream step s, v))

2402+ Yield x s -> return $ Yield x (BracketRun (Stream step s) v)

2346− Skip s -> return $ Skip (Just (Stream step s, v))

2403+ Skip s -> return $ Skip (BracketRun (Stream step s) v)

2347− Stop -> aft v >> return Stop

2404+ Stop -> aft v >> return Stop

2405+

2406+-- | Run a side effect whenever the stream stops normally or aborts due to an

2407+-- exception.

2408+{-# INLINE finally #-}

2409+finally :: MonadCatch m => m b -> Stream m a -> Stream m a

2410+-- finally action xs = after action $ onException action xs

2411+finally action xs = bracket (return ()) (\_ -> action) (const xs)

2348

2412

2349-- | When evaluating a stream if an exception occurs, stream evaluation aborts

2413-- | When evaluating a stream if an exception occurs, stream evaluation aborts

2350-- and the specified exception handler is run with the exception as argument.

2414-- and the specified exception handler is run with the exception as argument.

2351{-# INLINE_NORMAL handle #-}

2415{-# INLINE_NORMAL handle #-}

2352−handle :: (MonadCatch m, Exception e) => (e -> m a) -> Stream m a -> Stream m a

2416+handle :: (MonadCatch m, Exception e)

2417+ => (e -> Stream m a) -> Stream m a -> Stream m a

2418+handle f str =

2419+ gbracket (return ()) MC.try return (\_ e -> f e) (\_ -> str)

2420+

2421+{-# INLINE_NORMAL _handle #-}

2422+_handle :: (MonadCatch m, Exception e)

2423+ => (e -> Stream m a) -> Stream m a -> Stream m a

2353−handle f (Stream step state) = Stream step' (Just state)

2424+_handle f (Stream step state) = Stream step' (Left state)

2354

2425

2355 where

2426 where

2356

2427

2357 {-# INLINE_LATE step' #-}

2428 {-# INLINE_LATE step' #-}

2358− step' gst (Just st) = do

2429+ step' gst (Left st) = do

2359 res <- MC.try $ step gst st

2430 res <- MC.try $ step gst st

2360 case res of

2431 case res of

2361− Left e -> f e >>= \x -> return (Yield x Nothing)

2432+ Left e -> return $ Skip $ Right (f e)

2362 Right r -> case r of

2433 Right r -> case r of

2363− Yield x s -> return $ Yield x (Just s)

2434+ Yield x s -> return $ Yield x (Left s)

2364− Skip s -> return $ Skip (Just s)

2435+ Skip s -> return $ Skip (Left s)

2365 Stop -> return Stop

2436 Stop -> return Stop

2366

2437

2438+ step' gst (Right (UnStream step1 st)) = do

2439+ res <- step1 gst st

2440+ case res of

2441+ Yield x s -> return $ Yield x (Right (Stream step1 s))

2442+ Skip s -> return $ Skip (Right (Stream step1 s))

2367− step' _ Nothing = return Stop

2443+ Stop -> return Stop

2368

2444

2369-------------------------------------------------------------------------------

2445-------------------------------------------------------------------------------

2370-- General transformation

2446-- General transformation