@@ -1,6 +1,15 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
4+#ifdef __HADDOCK_VERSION__
9+{-# LANGUAGE TemplateHaskell #-}
10+{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-}
5-- Module : Streamly.Internal.Data.Stream.SVar
14-- Module : Streamly.Internal.Data.Stream.SVar
6-- Copyright : (c) 2017 Harendra Kumar
15-- Copyright : (c) 2017 Harendra Kumar
@@ -33,10 +42,18 @@ import System.Mem (performMajorGC)
33import Streamly.Internal.Data.SVar
42import Streamly.Internal.Data.SVar
34import Streamly.Internal.Data.Stream.StreamK hiding (reverse)
43import Streamly.Internal.Data.Stream.StreamK hiding (reverse)
46+import Control.Exception (Exception)
47+import Control.Monad.Catch (MonadThrow)
48+import Control.Monad.Trans.Control (MonadBaseControl)
49+import Data.Typeable (Typeable)
50+import Test.Inspection (inspect, hasNoTypeClassesExcept)
36-- | Pull a stream from an SVar.
53-- | Pull a stream from an SVar.
37{-# NOINLINE fromStreamVar #-}
54{-# NOINLINE fromStreamVar #-}
38fromStreamVar :: MonadAsync m => SVar Stream m a -> Stream m a
55fromStreamVar :: MonadAsync m => SVar Stream m a -> Stream m a
39−fromStreamVar sv = mkStream $ \st yld sng stp -> do
56+fromStreamVar sv = MkStream $ \st yld sng stp -> do
40 list <- readOutputQ sv
57 list <- readOutputQ sv
41 -- Reversing the output is important to guarantee that we process the
58 -- Reversing the output is important to guarantee that we process the
42 -- outputs in the same order as they were generated by the constituent
59 -- outputs in the same order as they were generated by the constituent
@@ -53,13 +70,13 @@ fromStreamVar sv = mkStream $ \st yld sng stp -> do
55 {-# INLINE processEvents #-}
72 {-# INLINE processEvents #-}
56− processEvents [] = mkStream $ \st yld sng stp -> do
73+ processEvents [] = MkStream $ \st yld sng stp -> do
57 done <- postProcess sv
74 done <- postProcess sv
59 then allDone stp
76 then allDone stp
60 else foldStream st yld sng stp $ fromStreamVar sv
77 else foldStream st yld sng stp $ fromStreamVar sv
62− processEvents (ev : es) = mkStream $ \st yld sng stp -> do
79+ processEvents (ev : es) = MkStream $ \st yld sng stp -> do
63 let rest = processEvents es
80 let rest = processEvents es
64 case ev of
81 case ev of
65 ChildYield a -> yld a rest
82 ChildYield a -> yld a rest
@@ -84,6 +101,23 @@ fromStreamVar sv = mkStream $ \st yld sng stp -> do
84 sid <- liftIO $ readIORef (svarStopBy sv)
101 sid <- liftIO $ readIORef (svarStopBy sv)
85 return $ if tid == sid then True else False
102 return $ if tid == sid then True else False
105+-- Use of GHC constraint tuple (GHC.Classes.(%,,%)) in fromStreamVar leads to
106+-- space leak because the tuple gets allocated in every recursive call and each
107+-- allocation holds on to the previous allocation. This test is to make sure
108+-- that we do not use the constraint tuple type class.
110+inspect $ hasNoTypeClassesExcept 'fromStreamVar
116+ , ''MonadBaseControl
87{-# INLINE fromSVar #-}
121{-# INLINE fromSVar #-}
88fromSVar :: (MonadAsync m, IsStream t) => SVar Stream m a -> t m a
122fromSVar :: (MonadAsync m, IsStream t) => SVar Stream m a -> t m a
89fromSVar sv =
123fromSVar sv =