git.iko.soy/streamly
on 209e990 help sign in
streamly/src/Streamly/Internal/Data/Stream/Instances.hs
168 lines 11 kB history raw
1------------------------------------------------------------------------------
2-- CPP macros for common instances
3------------------------------------------------------------------------------
5-- XXX use template haskell instead and include Monoid and IsStream instances
6-- as well.
8#define MONADPARALLEL , MonadAsync m
10#define MONAD_COMMON_INSTANCES(STREAM,CONSTRAINT) \
11instance Monad m => Functor (STREAM m) where { \
12 {-# INLINE fmap #-}; \
13 fmap f (STREAM m) = \
14 STREAM $ D.toStreamK $ D.mapM (return . f) $ D.fromStreamK m; \
15 {-# INLINE (<$) #-}; \
16 (<$) = fmap . const }; \
17 \
18instance (MonadIO m CONSTRAINT) => MonadIO (STREAM m) where { \
19 liftIO x = STREAM $ K.fromEffect $ liftIO x }; \
20 \
21instance (MonadThrow m CONSTRAINT) => MonadThrow (STREAM m) where { \
22 throwM x = STREAM $ K.fromEffect $ throwM x }; \
23 \
24{- \
25instance (MonadError e m CONSTRAINT) => MonadError e (STREAM m) where { \
26 throwError = lift . throwError; \
27 catchError m h = \
28 fromStream $ withCatchError (toStream m) (\e -> toStream $ h e) }; \
29-} \
30 \
31instance (MonadReader r m CONSTRAINT) => MonadReader r (STREAM m) where { \
32 ask = STREAM $ K.fromEffect ask; \
33 local f (STREAM m) = STREAM $ withLocal f m }; \
34 \
35instance (MonadState s m CONSTRAINT) => MonadState s (STREAM m) where { \
36 {-# INLINE get #-}; \
37 get = STREAM $ K.fromEffect get; \
38 {-# INLINE put #-}; \
39 put x = STREAM $ K.fromEffect $ put x; \
40 {-# INLINE state #-}; \
41 state k = STREAM $ K.fromEffect $ state k }
43------------------------------------------------------------------------------
44-- Lists
45------------------------------------------------------------------------------
47-- Serial streams can act like regular lists using the Identity monad
49-- XXX Show instance is 10x slower compared to read, we can do much better.
50-- The list show instance itself is really slow.
52-- XXX The default definitions of "<" in the Ord instance etc. do not perform
53-- well, because they do not get inlined. Need to add INLINE in Ord class in
54-- base?
56#define NFDATA1_INSTANCE(STREAM) \
57instance NFData1 (STREAM Identity) where { \
58 {-# INLINE liftRnf #-}; \
59 liftRnf f (STREAM xs) = runIdentity $ P.foldl' (\_ x -> f x) () xs}
61#define LIST_INSTANCES(STREAM) \
62instance IsList (STREAM Identity a) where { \
63 type (Item (STREAM Identity a)) = a; \
64 {-# INLINE fromList #-}; \
65 fromList xs = STREAM $ P.fromList xs; \
66 {-# INLINE toList #-}; \
67 toList (STREAM xs) = runIdentity $ P.toList xs }; \
68 \
69instance Eq a => Eq (STREAM Identity a) where { \
70 {-# INLINE (==) #-}; \
71 (==) (STREAM xs) (STREAM ys) = runIdentity $ P.eqBy (==) xs ys }; \
72 \
73instance Ord a => Ord (STREAM Identity a) where { \
74 {-# INLINE compare #-}; \
75 compare (STREAM xs) (STREAM ys) = runIdentity $ P.cmpBy compare xs ys; \
76 {-# INLINE (<) #-}; \
77 x < y = case compare x y of { LT -> True; _ -> False }; \
78 {-# INLINE (<=) #-}; \
79 x <= y = case compare x y of { GT -> False; _ -> True }; \
80 {-# INLINE (>) #-}; \
81 x > y = case compare x y of { GT -> True; _ -> False }; \
82 {-# INLINE (>=) #-}; \
83 x >= y = case compare x y of { LT -> False; _ -> True }; \
84 {-# INLINE max #-}; \
85 max x y = if x <= y then y else x; \
86 {-# INLINE min #-}; \
87 min x y = if x <= y then x else y; }; \
88 \
89instance Show a => Show (STREAM Identity a) where { \
90 showsPrec p dl = showParen (p > 10) $ \
91 showString "fromList " . shows (toList dl) }; \
92 \
93instance Read a => Read (STREAM Identity a) where { \
94 readPrec = parens $ prec 10 $ do { \
95 Ident "fromList" <- lexP; \
96 fromList <$> readPrec }; \
97 readListPrec = readListPrecDefault }; \
98 \
99instance (a ~ Char) => IsString (STREAM Identity a) where { \
100 {-# INLINE fromString #-}; \
101 fromString xs = STREAM $ P.fromList xs }; \
102 \
103instance NFData a => NFData (STREAM Identity a) where { \
104 {-# INLINE rnf #-}; \
105 rnf (STREAM xs) = runIdentity $ P.foldl' (\_ x -> rnf x) () xs}; \
107-------------------------------------------------------------------------------
108-- Foldable
109-------------------------------------------------------------------------------
111-- The default Foldable instance has several issues:
112-- 1) several definitions do not have INLINE on them, so we provide
113-- re-implementations with INLINE pragmas.
114-- 2) the definitions of sum/product/maximum/minimum are inefficient as they
115-- use right folds, they cannot run in constant memory. We provide
116-- implementations using strict left folds here.
118#define FOLDABLE_INSTANCE(STREAM) \
119instance (Foldable m, Monad m) => Foldable (STREAM m) where { \
120 \
121 {-# INLINE foldMap #-}; \
122 foldMap f (STREAM xs) = fold $ P.foldr (mappend . f) mempty xs; \
123 \
124 {-# INLINE foldr #-}; \
125 foldr f z t = appEndo (foldMap (Endo #. f) t) z; \
126 \
127 {-# INLINE foldl' #-}; \
128 foldl' f z0 xs = foldr f' id xs z0 \
129 where {f' x k = oneShot $ \z -> k $! f z x}; \
130 \
131 {-# INLINE length #-}; \
132 length = foldl' (\n _ -> n + 1) 0; \
133 \
134 {-# INLINE elem #-}; \
135 elem = any . (==); \
136 \
137 {-# INLINE maximum #-}; \
138 maximum = \
139 fromMaybe (errorWithoutStackTrace "maximum: empty stream") \
140 . toMaybe \
141 . foldl' getMax Nothing' where { \
142 getMax Nothing' x = Just' x; \
143 getMax (Just' mx) x = Just' $! max mx x }; \
144 \
145 {-# INLINE minimum #-}; \
146 minimum = \
147 fromMaybe (errorWithoutStackTrace "minimum: empty stream") \
148 . toMaybe \
149 . foldl' getMin Nothing' where { \
150 getMin Nothing' x = Just' x; \
151 getMin (Just' mn) x = Just' $! min mn x }; \
152 \
153 {-# INLINE sum #-}; \
154 sum = foldl' (+) 0; \
155 \
156 {-# INLINE product #-}; \
157 product = foldl' (*) 1 }
159-------------------------------------------------------------------------------
160-- Traversable
161-------------------------------------------------------------------------------
163#define TRAVERSABLE_INSTANCE(STREAM) \
164instance Traversable (STREAM Identity) where { \
165 {-# INLINE traverse #-}; \
166 traverse f (STREAM xs) = \
167 fmap STREAM $ runIdentity $ P.foldr consA (pure mempty) xs \
168 where { consA x ys = liftA2 K.cons (f x) ys }}