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