@@ -0,0 +1,569 @@
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
9+-- Template Haskell macros to create useful stream types.
11+-- __Create a type with a serial zipping applicative property:__
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)
20+-- import qualified Streamly.Data.Stream
21+-- import qualified Streamly.Data.Stream as Stream
22+-- import qualified Streamly.Internal.Data.Stream.TypeGen as StreamTypeGen
24+-- applySerial :: Monad m => Stream m (a -> b) -> Stream m a -> Stream m b
25+-- applySerial = Stream.zipWith ($)
27+-- \$(StreamTypeGen.mkZippingType \"ZipSerial\" "applySerial" False)
30+-- __Create a type with a concurrent zipping applicative property:__
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)
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
44+-- applyConcurrent :: Monad m => Stream m (a -> b) -> Stream m a -> Stream m b
45+-- applyConcurrent = Concur.zipWith ($)
47+-- \$(StreamTypeGen.mkZippingType \"ZipConcurrent\" "applyConcurrent" True)
50+-- __Create a type with serial interleave properties:__
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)
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
64+-- bindInterleave :: Stream m a -> (a -> Stream m b) -> Stream m b
65+-- bindInterleave = flip (Stream.concatMapWith Stream.interleave)
67+-- \$(StreamTypeGen.mkNestingType \"InterleaveSerial\" "bindInterleave" False)
70+-- __Create a type with eager concurrency properties:__
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)
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
86+-- bindConcurrent :: MonadAsync m => Stream m a -> (a -> Stream m b) -> Stream m b
87+-- bindConcurrent = flip (Concur.concatMapWith (Concur.eager True))
89+-- \$(StreamTypeGen.mkNestingType \"Parallel\" "bindConcurrent" True)
92+module Streamly.Internal.Data.Stream.TypeGen
97+--------------------------------------------------------------------------------
99+--------------------------------------------------------------------------------
101+-- Debugging helpers,
103+-- >>> import Language.Haskell.TH
104+-- >>> import Streamly.Internal.Data.Stream.TypeGen
105+-- >>> expr <- runQ (mkNestingType "Parallel" "bindConcurrent" True)
106+-- >>> putStrLn $ pprint expr
108+--------------------------------------------------------------------------------
110+--------------------------------------------------------------------------------
112+import Language.Haskell.TH.Lib
113+import Language.Haskell.TH.Syntax
117+-- >>> import Language.Haskell.TH
118+-- >>> import Streamly.Internal.Data.Stream.TypeGen
120+--------------------------------------------------------------------------------
122+--------------------------------------------------------------------------------
124+toTypeStr :: String -> String
125+toTypeStr typ = "mk" ++ typ
127+unTypeStr :: String -> String
128+unTypeStr typ = "un" ++ typ
130+--------------------------------------------------------------------------------
132+--------------------------------------------------------------------------------
144+_Stream = mkName "Stream"
147+_fmap = mkName "fmap"
150+_pure = mkName "pure"
153+_return = mkName "return"
156+_strm = mkName "strm"
159+_strm1 = mkName "strm1"
162+_strm2 = mkName "strm2"
165+_Functor = mkName "Functor"
168+_Applicative = mkName "Applicative"
171+_Monad = mkName "Monad"
174+_MonadTrans = mkName "MonadTrans"
177+_MonadIO = mkName "MonadIO"
180+_MonadThrow = mkName "MonadThrow"
183+_MonadReader = mkName "MonadReader"
186+_lift = mkName "lift"
192+_local = mkName "local"
195+_throwM = mkName "throwM"
198+_liftIO = mkName "liftIO"
213+_bindOp = mkName ">>="
215+--------------------------------------------------------------------------------
217+--------------------------------------------------------------------------------
219+makeTypeDec :: String -> Q [Dec]
220+makeTypeDec dtNameStr = do
225+ [plainTV _m, plainTV _a]
230+ (bang noSourceUnpackedness noSourceStrictness)
231+ (appT (appT (conT _Stream) (varT _m)) (varT _a))
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)
242+ [clause [conP _Type [varP _strm]] (normalB (varE _strm)) []]
243+ return [typ, mkTypSig, mkTyp, unTypSig, unTyp]
247+ _Type = mkName dtNameStr
248+ _toType = mkName (toTypeStr dtNameStr)
249+ _unType = mkName (unTypeStr dtNameStr)
251+makeStreamFunctor :: String -> Q Dec
252+makeStreamFunctor dtNameStr = do
254+ (pure <$> appT (conT _Monad) (varT _m))
255+ (appT (conT _Functor) (appT (conT _Type) (varT _m)))
256+ [ pragInlD _fmap Inline FunLike AllPhases
260+ [varP _f, conP _Type [varP _strm]]
264+ (appE (appE (varE _fmap) (varE _f)) (varE _strm))))
271+ _Type = mkName dtNameStr
273+mkStreamApplicative :: String -> [String] -> String -> String -> Q Dec
274+mkStreamApplicative dtNameStr ctxM pureDefStr apDefStr =
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
287+ (Just (varE _pureDef))))
290+ , pragInlD _apOp Inline FunLike AllPhases
294+ [conP _Type [varP _strm1], conP _Type [varP _strm2]]
299+ (appE (varE _apDef) (varE _strm1))
307+ _Type = mkName dtNameStr
308+ _pureDef = mkName pureDefStr
309+ _apDef = mkName apDefStr
311+mkStreamMonad :: String -> [String] -> String -> Q Dec
312+mkStreamMonad dtNameStr ctxM bindDefStr =
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
320+ [conP _Type [varP _strm1], varP _f]
330+ (appE (varE _f) (varE _a))))
337+ (appE (varE _bindDef) (varE _strm1))
345+ _Type = mkName dtNameStr
346+ _unType = mkName (unTypeStr dtNameStr)
347+ _bindDef = mkName bindDefStr
349+mkSimpleStreamInstances :: String -> Q [Dec]
350+mkSimpleStreamInstances dtNameStr = do
354+ (appT (conT _MonadTrans) (conT _Type))
355+ [ pragInlD _lift Inline FunLike AllPhases
364+ (Just (varE _lift))))
371+ [ appT (conT _Monad) (appT (conT _Type) (varT _m))
372+ , appT (conT _MonadIO) (varT _m)
374+ (appT (conT _MonadIO) (appT (conT _Type) (varT _m)))
375+ [ pragInlD _liftIO Inline FunLike AllPhases
388+ (Just (varE _liftIO))))))
395+ [ appT (conT _Monad) (appT (conT _Type) (varT _m))
396+ , appT (conT _MonadThrow) (varT _m)
398+ (appT (conT _MonadThrow) (appT (conT _Type) (varT _m)))
399+ [ pragInlD _throwM Inline FunLike AllPhases
412+ (Just (varE _throwM))))))
419+ [ appT (conT _Monad) (appT (conT _Type) (varT _m))
420+ , appT (appT (conT _MonadReader) (varT _r)) (varT _m)
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
431+ [varP _f, conP _Type [varP _strm]]
436+ (appE (varE _local) (varE _f))
441+ return [trans, io, throw, reader]
445+ _Type = mkName dtNameStr
446+ _unType = mkName (unTypeStr dtNameStr)
448+--------------------------------------------------------------------------------
450+--------------------------------------------------------------------------------
452+-- | Create a type with a zip-like applicative.
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
481+-- where {-# INLINE ask #-}
483+-- {-# INLINE local #-}
484+-- local f (ZipSerial strm) = ZipSerial (local f strm)
486+ :: String -- ^ Name of the type
487+ -> String -- ^ Function to use for (\<*\>)
488+ -> Bool -- ^ 'True' if (\<*\>) has concurrent properties
490+mkZippingType dtNameStr apOpStr isConcurrent = do
491+ typeDec <- makeTypeDec dtNameStr
492+ functorI <- makeStreamFunctor dtNameStr
497+ "Streamly.Data.Stream.repeat"
499+ simpleInstances <- mkSimpleStreamInstances dtNameStr
500+ return $ typeDec ++ [functorI, applicativeI] ++ simpleInstances
506+ then ["Streamly.Internal.Data.Stream.Concurrent.MonadAsync"]
509+-- | Create a type with specific stream combination properties.
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
542+-- where {-# INLINE ask #-}
544+-- {-# INLINE local #-}
545+-- local f (Parallel strm) = Parallel (local f strm)
547+ :: String -- ^ Name of the type
548+ -> String -- ^ Function to use for (>>=)
549+ -> Bool -- ^ 'True' if (>>=) has concurrent properties
551+mkNestingType dtNameStr bindOpStr isConcurrent = do
552+ typeDec <- makeTypeDec dtNameStr
553+ functorI <- makeStreamFunctor dtNameStr
554+ monadI <- mkStreamMonad dtNameStr classConstraints bindOpStr
559+ "Streamly.Data.Stream.fromPure"
561+ simpleInstances <- mkSimpleStreamInstances dtNameStr
562+ return $ typeDec ++ [functorI, monadI, applicativeI] ++ simpleInstances
568+ then ["Streamly.Internal.Data.Stream.Concurrent.MonadAsync"]