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