@@ -0,0 +1,569 @@
1+-- |
2+-- Module : Streamly.Internal.Data.Stream.TypeGen
3+-- Copyright : (c) 2022 Composewell Technologies
4+-- License : BSD-3-Clause
5+-- Maintainer : streamly@composewell.com
6+-- Stability : experimental
7+-- Portability : GHC
8+--
9+-- Template Haskell macros to create useful stream types.
10+--
11+-- __Create a type with a serial zipping applicative property:__
12+--
13+-- @
14+-- import Control.Monad.Catch (MonadThrow(..))
15+-- import Control.Monad.IO.Class (MonadIO(..))
16+-- import Control.Monad.Reader.Class (MonadReader(..))
17+-- import Control.Monad.Trans.Class (MonadTrans(..))
18+-- import Streamly.Data.Stream (Stream)
19+--
20+-- import qualified Streamly.Data.Stream
21+-- import qualified Streamly.Data.Stream as Stream
22+-- import qualified Streamly.Internal.Data.Stream.TypeGen as StreamTypeGen
23+--
24+-- applySerial :: Monad m => Stream m (a -> b) -> Stream m a -> Stream m b
25+-- applySerial = Stream.zipWith ($)
26+--
27+-- \$(StreamTypeGen.mkZippingType \"ZipSerial\" "applySerial" False)
28+-- @
29+--
30+-- __Create a type with a concurrent zipping applicative property:__
31+--
32+-- @
33+-- import Control.Monad.Catch (MonadThrow(..))
34+-- import Control.Monad.IO.Class (MonadIO(..))
35+-- import Control.Monad.Reader.Class (MonadReader(..))
36+-- import Control.Monad.Trans.Class (MonadTrans(..))
37+-- import Streamly.Data.Stream (Stream)
38+--
39+-- import qualified Streamly.Data.Stream
40+-- import qualified Streamly.Data.Stream.Concurrent
41+-- import qualified Streamly.Data.Stream.Concurrent as Concur
42+-- import qualified Streamly.Internal.Data.Stream.TypeGen as StreamTypeGen
43+--
44+-- applyConcurrent :: Monad m => Stream m (a -> b) -> Stream m a -> Stream m b
45+-- applyConcurrent = Concur.zipWith ($)
46+--
47+-- \$(StreamTypeGen.mkZippingType \"ZipConcurrent\" "applyConcurrent" True)
48+-- @
49+--
50+-- __Create a type with serial interleave properties:__
51+--
52+-- @
53+-- import Control.Monad.Catch (MonadThrow(..))
54+-- import Control.Monad.IO.Class (MonadIO(..))
55+-- import Control.Monad.Reader.Class (MonadReader(..))
56+-- import Control.Monad.Trans.Class (MonadTrans(..))
57+-- import Streamly.Data.Stream (Stream)
58+--
59+-- import qualified Control.Monad
60+-- import qualified Streamly.Data.Stream
61+-- import qualified Streamly.Data.Stream as Stream
62+-- import qualified Streamly.Internal.Data.Stream.TypeGen as StreamTypeGen
63+--
64+-- bindInterleave :: Stream m a -> (a -> Stream m b) -> Stream m b
65+-- bindInterleave = flip (Stream.concatMapWith Stream.interleave)
66+--
67+-- \$(StreamTypeGen.mkNestingType \"InterleaveSerial\" "bindInterleave" False)
68+-- @
69+--
70+-- __Create a type with eager concurrency properties:__
71+--
72+-- @
73+-- import Control.Monad.Catch (MonadThrow(..))
74+-- import Control.Monad.IO.Class (MonadIO(..))
75+-- import Control.Monad.Reader.Class (MonadReader(..))
76+-- import Control.Monad.Trans.Class (MonadTrans(..))
77+-- import Streamly.Data.Stream (Stream)
78+-- import Streamly.Data.Stream.Concurrent (MonadAsync)
79+--
80+-- import qualified Control.Monad
81+-- import qualified Streamly.Data.Stream
82+-- import qualified Streamly.Data.Stream.Concurrent
83+-- import qualified Streamly.Data.Stream.Concurrent as Concur
84+-- import qualified Streamly.Internal.Data.Stream.TypeGen as StreamTypeGen
85+--
86+-- bindConcurrent :: MonadAsync m => Stream m a -> (a -> Stream m b) -> Stream m b
87+-- bindConcurrent = flip (Concur.concatMapWith (Concur.eager True))
88+--
89+-- \$(StreamTypeGen.mkNestingType \"Parallel\" "bindConcurrent" True)
90+-- @
91+--
92+module Streamly.Internal.Data.Stream.TypeGen
93+ ( mkZippingType
94+ , mkNestingType
95+ ) where
96+
97+--------------------------------------------------------------------------------
98+-- Developer notes
99+--------------------------------------------------------------------------------
100+
101+-- Debugging helpers,
102+--
103+-- >>> import Language.Haskell.TH
104+-- >>> import Streamly.Internal.Data.Stream.TypeGen
105+-- >>> expr <- runQ (mkNestingType "Parallel" "bindConcurrent" True)
106+-- >>> putStrLn $ pprint expr
107+
108+--------------------------------------------------------------------------------
109+-- Imports
110+--------------------------------------------------------------------------------
111+
112+import Language.Haskell.TH.Lib
113+import Language.Haskell.TH.Syntax
114+
115+-- $setup
116+-- >>> :m
117+-- >>> import Language.Haskell.TH
118+-- >>> import Streamly.Internal.Data.Stream.TypeGen
119+
120+--------------------------------------------------------------------------------
121+-- Helpers
122+--------------------------------------------------------------------------------
123+
124+toTypeStr :: String -> String
125+toTypeStr typ = "mk" ++ typ
126+
127+unTypeStr :: String -> String
128+unTypeStr typ = "un" ++ typ
129+
130+--------------------------------------------------------------------------------
131+-- Names
132+--------------------------------------------------------------------------------
133+
134+_m :: Name
135+_m = mkName "m"
136+
137+_a :: Name
138+_a = mkName "a"
139+
140+_r :: Name
141+_r = mkName "r"
142+
143+_Stream :: Name
144+_Stream = mkName "Stream"
145+
146+_fmap :: Name
147+_fmap = mkName "fmap"
148+
149+_pure :: Name
150+_pure = mkName "pure"
151+
152+_return :: Name
153+_return = mkName "return"
154+
155+_strm :: Name
156+_strm = mkName "strm"
157+
158+_strm1 :: Name
159+_strm1 = mkName "strm1"
160+
161+_strm2 :: Name
162+_strm2 = mkName "strm2"
163+
164+_Functor :: Name
165+_Functor = mkName "Functor"
166+
167+_Applicative :: Name
168+_Applicative = mkName "Applicative"
169+
170+_Monad :: Name
171+_Monad = mkName "Monad"
172+
173+_MonadTrans :: Name
174+_MonadTrans = mkName "MonadTrans"
175+
176+_MonadIO :: Name
177+_MonadIO = mkName "MonadIO"
178+
179+_MonadThrow :: Name
180+_MonadThrow = mkName "MonadThrow"
181+
182+_MonadReader :: Name
183+_MonadReader = mkName "MonadReader"
184+
185+_lift :: Name
186+_lift = mkName "lift"
187+
188+_ask :: Name
189+_ask = mkName "ask"
190+
191+_local :: Name
192+_local = mkName "local"
193+
194+_throwM :: Name
195+_throwM = mkName "throwM"
196+
197+_liftIO :: Name
198+_liftIO = mkName "liftIO"
199+
200+_f :: Name
201+_f = mkName "f"
202+
203+_f1 :: Name
204+_f1 = mkName "f1"
205+
206+_dotOp :: Name
207+_dotOp = mkName "."
208+
209+_apOp :: Name
210+_apOp = mkName "<*>"
211+
212+_bindOp :: Name
213+_bindOp = mkName ">>="
214+
215+--------------------------------------------------------------------------------
216+-- TH helpers
217+--------------------------------------------------------------------------------
218+
219+makeTypeDec :: String -> Q [Dec]
220+makeTypeDec dtNameStr = do
221+ typ <-
222+ newtypeD
223+ (return [])
224+ _Type
225+ [plainTV _m, plainTV _a]
226+ Nothing
227+ (normalC
228+ (mkName dtNameStr)
229+ [ bangType
230+ (bang noSourceUnpackedness noSourceStrictness)
231+ (appT (appT (conT _Stream) (varT _m)) (varT _a))
232+ ])
233+ []
234+ let streamType = appT (appT (conT _Stream) (varT _m)) (varT _a)
235+ nameType = appT (appT (conT _Type) (varT _m)) (varT _a)
236+ mkTypSig <- sigD _toType (appT (appT arrowT streamType) nameType)
237+ mkTyp <- funD _toType [clause [] (normalB (conE _Type)) []]
238+ unTypSig <- sigD _unType (appT (appT arrowT nameType) streamType)
239+ unTyp <-
240+ funD
241+ _unType
242+ [clause [conP _Type [varP _strm]] (normalB (varE _strm)) []]
243+ return [typ, mkTypSig, mkTyp, unTypSig, unTyp]
244+
245+ where
246+
247+ _Type = mkName dtNameStr
248+ _toType = mkName (toTypeStr dtNameStr)
249+ _unType = mkName (unTypeStr dtNameStr)
250+
251+makeStreamFunctor :: String -> Q Dec
252+makeStreamFunctor dtNameStr = do
253+ instanceD
254+ (pure <$> appT (conT _Monad) (varT _m))
255+ (appT (conT _Functor) (appT (conT _Type) (varT _m)))
256+ [ pragInlD _fmap Inline FunLike AllPhases
257+ , funD
258+ _fmap
259+ [ clause
260+ [varP _f, conP _Type [varP _strm]]
261+ (normalB
262+ (appE
263+ (conE _Type)
264+ (appE (appE (varE _fmap) (varE _f)) (varE _strm))))
265+ []
266+ ]
267+ ]
268+
269+ where
270+
271+ _Type = mkName dtNameStr
272+
273+mkStreamApplicative :: String -> [String] -> String -> String -> Q Dec
274+mkStreamApplicative dtNameStr ctxM pureDefStr apDefStr =
275+ instanceD
276+ (Prelude.mapM (\c -> appT (conT (mkName c)) (varT _m)) ctxM)
277+ (appT (conT _Applicative) (appT (conT _Type) (varT _m)))
278+ [ pragInlD _pure Inline FunLike AllPhases
279+ , funD
280+ _pure
281+ [ clause
282+ []
283+ (normalB
284+ (infixE
285+ (Just (conE _Type))
286+ (varE _dotOp)
287+ (Just (varE _pureDef))))
288+ []
289+ ]
290+ , pragInlD _apOp Inline FunLike AllPhases
291+ , funD
292+ _apOp
293+ [ clause
294+ [conP _Type [varP _strm1], conP _Type [varP _strm2]]
295+ (normalB
296+ (appE
297+ (conE _Type)
298+ (appE
299+ (appE (varE _apDef) (varE _strm1))
300+ (varE _strm2))))
301+ []
302+ ]
303+ ]
304+
305+ where
306+
307+ _Type = mkName dtNameStr
308+ _pureDef = mkName pureDefStr
309+ _apDef = mkName apDefStr
310+
311+mkStreamMonad :: String -> [String] -> String -> Q Dec
312+mkStreamMonad dtNameStr ctxM bindDefStr =
313+ instanceD
314+ (Prelude.mapM (\c -> appT (conT (mkName c)) (varT _m)) ctxM)
315+ (appT (conT _Monad) (appT (conT _Type) (varT _m)))
316+ [ pragInlD _bindOp Inline FunLike AllPhases
317+ , funD
318+ _bindOp
319+ [ clause
320+ [conP _Type [varP _strm1], varP _f]
321+ (normalB
322+ (letE
323+ [ funD
324+ _f1
325+ [ clause
326+ [varP _a]
327+ (normalB
328+ (appE
329+ (varE _unType)
330+ (appE (varE _f) (varE _a))))
331+ []
332+ ]
333+ ]
334+ (appE
335+ (conE _Type)
336+ (appE
337+ (appE (varE _bindDef) (varE _strm1))
338+ (varE _f1)))))
339+ []
340+ ]
341+ ]
342+
343+ where
344+
345+ _Type = mkName dtNameStr
346+ _unType = mkName (unTypeStr dtNameStr)
347+ _bindDef = mkName bindDefStr
348+
349+mkSimpleStreamInstances :: String -> Q [Dec]
350+mkSimpleStreamInstances dtNameStr = do
351+ trans <-
352+ instanceD
353+ (pure [])
354+ (appT (conT _MonadTrans) (conT _Type))
355+ [ pragInlD _lift Inline FunLike AllPhases
356+ , funD
357+ _lift
358+ [ clause
359+ []
360+ (normalB
361+ (infixE
362+ (Just (conE _Type))
363+ (varE _dotOp)
364+ (Just (varE _lift))))
365+ []
366+ ]
367+ ]
368+ io <-
369+ instanceD
370+ (sequence
371+ [ appT (conT _Monad) (appT (conT _Type) (varT _m))
372+ , appT (conT _MonadIO) (varT _m)
373+ ])
374+ (appT (conT _MonadIO) (appT (conT _Type) (varT _m)))
375+ [ pragInlD _liftIO Inline FunLike AllPhases
376+ , funD
377+ _liftIO
378+ [ clause
379+ []
380+ (normalB
381+ (infixE
382+ (Just (conE _Type))
383+ (varE _dotOp)
384+ (Just
385+ (infixE
386+ (Just (varE _lift))
387+ (varE _dotOp)
388+ (Just (varE _liftIO))))))
389+ []
390+ ]
391+ ]
392+ throw <-
393+ instanceD
394+ (sequence
395+ [ appT (conT _Monad) (appT (conT _Type) (varT _m))
396+ , appT (conT _MonadThrow) (varT _m)
397+ ])
398+ (appT (conT _MonadThrow) (appT (conT _Type) (varT _m)))
399+ [ pragInlD _throwM Inline FunLike AllPhases
400+ , funD
401+ _throwM
402+ [ clause
403+ []
404+ (normalB
405+ (infixE
406+ (Just (conE _Type))
407+ (varE _dotOp)
408+ (Just
409+ (infixE
410+ (Just (varE _lift))
411+ (varE _dotOp)
412+ (Just (varE _throwM))))))
413+ []
414+ ]
415+ ]
416+ reader <-
417+ instanceD
418+ (sequence
419+ [ appT (conT _Monad) (appT (conT _Type) (varT _m))
420+ , appT (appT (conT _MonadReader) (varT _r)) (varT _m)
421+ ])
422+ (appT
423+ (appT (conT _MonadReader) (varT _r))
424+ (appT (conT _Type) (varT _m)))
425+ [ pragInlD _ask Inline FunLike AllPhases
426+ , funD _ask [clause [] (normalB (appE (varE _lift) (varE _ask))) []]
427+ , pragInlD _local Inline FunLike AllPhases
428+ , funD
429+ _local
430+ [ clause
431+ [varP _f, conP _Type [varP _strm]]
432+ (normalB
433+ (appE
434+ (conE _Type)
435+ (appE
436+ (appE (varE _local) (varE _f))
437+ (varE _strm))))
438+ []
439+ ]
440+ ]
441+ return [trans, io, throw, reader]
442+
443+ where
444+
445+ _Type = mkName dtNameStr
446+ _unType = mkName (unTypeStr dtNameStr)
447+
448+--------------------------------------------------------------------------------
449+-- Functions
450+--------------------------------------------------------------------------------
451+
452+-- | Create a type with a zip-like applicative.
453+--
454+-- >>> expr <- runQ (mkZippingType "ZipSerial" "apZipSerial" False)
455+-- >>> putStrLn $ pprint expr
456+-- newtype ZipSerial m a = ZipSerial (Stream m a)
457+-- mkZipSerial :: Stream m a -> ZipSerial m a
458+-- mkZipSerial = ZipSerial
459+-- unZipSerial :: ZipSerial m a -> Stream m a
460+-- unZipSerial (ZipSerial strm) = strm
461+-- instance Monad m => Functor (ZipSerial m)
462+-- where {-# INLINE fmap #-}
463+-- fmap f (ZipSerial strm) = ZipSerial (fmap f strm)
464+-- instance Monad m => Applicative (ZipSerial m)
465+-- where {-# INLINE pure #-}
466+-- pure = ZipSerial . Streamly.Data.Stream.repeat
467+-- {-# INLINE (<*>) #-}
468+-- (<*>) (ZipSerial strm1) (ZipSerial strm2) = ZipSerial (apZipSerial strm1 strm2)
469+-- instance MonadTrans ZipSerial
470+-- where {-# INLINE lift #-}
471+-- lift = ZipSerial . lift
472+-- instance (Monad (ZipSerial m), MonadIO m) => MonadIO (ZipSerial m)
473+-- where {-# INLINE liftIO #-}
474+-- liftIO = ZipSerial . (lift . liftIO)
475+-- instance (Monad (ZipSerial m),
476+-- MonadThrow m) => MonadThrow (ZipSerial m)
477+-- where {-# INLINE throwM #-}
478+-- throwM = ZipSerial . (lift . throwM)
479+-- instance (Monad (ZipSerial m), MonadReader r m) => MonadReader r
480+-- (ZipSerial m)
481+-- where {-# INLINE ask #-}
482+-- ask = lift ask
483+-- {-# INLINE local #-}
484+-- local f (ZipSerial strm) = ZipSerial (local f strm)
485+mkZippingType
486+ :: String -- ^ Name of the type
487+ -> String -- ^ Function to use for (\<*\>)
488+ -> Bool -- ^ 'True' if (\<*\>) has concurrent properties
489+ -> Q [Dec]
490+mkZippingType dtNameStr apOpStr isConcurrent = do
491+ typeDec <- makeTypeDec dtNameStr
492+ functorI <- makeStreamFunctor dtNameStr
493+ applicativeI <-
494+ mkStreamApplicative
495+ dtNameStr
496+ classConstraints
497+ "Streamly.Data.Stream.repeat"
498+ apOpStr
499+ simpleInstances <- mkSimpleStreamInstances dtNameStr
500+ return $ typeDec ++ [functorI, applicativeI] ++ simpleInstances
501+
502+ where
503+
504+ classConstraints =
505+ if isConcurrent
506+ then ["Streamly.Internal.Data.Stream.Concurrent.MonadAsync"]
507+ else ["Monad"]
508+
509+-- | Create a type with specific stream combination properties.
510+--
511+-- >>> expr <- runQ (mkNestingType "Parallel" "bindConcurrent" True)
512+-- >>> putStrLn $ pprint expr
513+-- newtype Parallel m a = Parallel (Stream m a)
514+-- mkParallel :: Stream m a -> Parallel m a
515+-- mkParallel = Parallel
516+-- unParallel :: Parallel m a -> Stream m a
517+-- unParallel (Parallel strm) = strm
518+-- instance Monad m => Functor (Parallel m)
519+-- where {-# INLINE fmap #-}
520+-- fmap f (Parallel strm) = Parallel (fmap f strm)
521+-- instance Streamly.Internal.Data.Stream.Concurrent.MonadAsync m => Monad (Parallel m)
522+-- where {-# INLINE (>>=) #-}
523+-- (>>=) (Parallel strm1) f = let f1 a = unParallel (f a)
524+-- in Parallel (bindConcurrent strm1 f1)
525+-- instance Streamly.Internal.Data.Stream.Concurrent.MonadAsync m => Applicative (Parallel m)
526+-- where {-# INLINE pure #-}
527+-- pure = Parallel . Streamly.Data.Stream.fromPure
528+-- {-# INLINE (<*>) #-}
529+-- (<*>) (Parallel strm1) (Parallel strm2) = Parallel (Control.Monad.ap strm1 strm2)
530+-- instance MonadTrans Parallel
531+-- where {-# INLINE lift #-}
532+-- lift = Parallel . lift
533+-- instance (Monad (Parallel m), MonadIO m) => MonadIO (Parallel m)
534+-- where {-# INLINE liftIO #-}
535+-- liftIO = Parallel . (lift . liftIO)
536+-- instance (Monad (Parallel m),
537+-- MonadThrow m) => MonadThrow (Parallel m)
538+-- where {-# INLINE throwM #-}
539+-- throwM = Parallel . (lift . throwM)
540+-- instance (Monad (Parallel m), MonadReader r m) => MonadReader r
541+-- (Parallel m)
542+-- where {-# INLINE ask #-}
543+-- ask = lift ask
544+-- {-# INLINE local #-}
545+-- local f (Parallel strm) = Parallel (local f strm)
546+mkNestingType
547+ :: String -- ^ Name of the type
548+ -> String -- ^ Function to use for (>>=)
549+ -> Bool -- ^ 'True' if (>>=) has concurrent properties
550+ -> Q [Dec]
551+mkNestingType dtNameStr bindOpStr isConcurrent = do
552+ typeDec <- makeTypeDec dtNameStr
553+ functorI <- makeStreamFunctor dtNameStr
554+ monadI <- mkStreamMonad dtNameStr classConstraints bindOpStr
555+ applicativeI <-
556+ mkStreamApplicative
557+ dtNameStr
558+ classConstraints
559+ "Streamly.Data.Stream.fromPure"
560+ "Control.Monad.ap"
561+ simpleInstances <- mkSimpleStreamInstances dtNameStr
562+ return $ typeDec ++ [functorI, monadI, applicativeI] ++ simpleInstances
563+
564+ where
565+
566+ classConstraints =
567+ if isConcurrent
568+ then ["Streamly.Internal.Data.Stream.Concurrent.MonadAsync"]
569+ else ["Monad"]