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