@@ -1,3 +1,6 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE QuasiQuotes #-}
3+
14-- |
25-- Module : Streamly.Internal.Data.Stream.MkType
36-- Copyright : (c) 2022 Composewell Technologies
@@ -35,6 +38,7 @@ import Control.Monad.Catch (MonadThrow(..))
3538import Control.Monad.IO.Class (MonadIO(..))
3639import Control.Monad.Reader.Class (MonadReader(..))
3740import Control.Monad.Trans.Class (MonadTrans(..))
41+import Data.List (singleton)
3842import Prelude hiding (repeat)
3943
4044-- $setup
@@ -138,12 +142,232 @@ _apOp = mkName "<*>"
138142_bindOp :: Name
139143_bindOp = mkName ">>="
140144
145+_IsList :: Name
146+_IsList = mkName "IsList"
147+
148+_IsString :: Name
149+_IsString = mkName "IsString"
150+
151+_Eq :: Name
152+_Eq = mkName "Eq"
153+
154+_Ord :: Name
155+_Ord = mkName "Ord"
156+
157+_Traversable :: Name
158+_Traversable = mkName "Traversable"
159+
160+_Identity :: Name
161+_Identity = mkName "Identity"
162+
163+_Read :: Name
164+_Read = mkName "Read"
165+
166+_Show :: Name
167+_Show = mkName "Show"
168+
169+_show :: Name
170+_show = mkName "show"
171+
172+_read :: Name
173+_read = mkName "read"
174+
175+_Semigroup :: Name
176+_Semigroup = mkName "Semigroup"
177+
178+_Monoid :: Name
179+_Monoid = mkName "Monoid"
180+
181+_Foldable :: Name
182+_Foldable = mkName "Foldable"
183+
141184--------------------------------------------------------------------------------
142−-- TH helpers
185+-- Simple derivations
143186--------------------------------------------------------------------------------
144187
145−makeTypeDec :: String -> Q [Dec]
146−makeTypeDec dtNameStr = do
188+derivIsListIdent :: Name -> Q Dec
189+derivIsListIdent _Type =
190+ standaloneDerivD
191+ (pure [])
192+ (appT (conT _IsList) (foldl1 appT [conT _Type, conT _Identity, varT _a]))
193+
194+derivIsStringIdent :: Name -> Q Dec
195+derivIsStringIdent _Type =
196+ standaloneDerivD
197+ (singleton <$> [t|$(varT _a) ~ Char|])
198+ (appT
199+ (conT _IsString)
200+ (foldl1 appT [conT _Type, conT _Identity, varT _a]))
201+
202+derivEqIdent :: Name -> Q Dec
203+derivEqIdent _Type =
204+ standaloneDerivD
205+ (singleton <$> [t|Eq $(varT _a)|])
206+ (appT (conT _Eq) (foldl1 appT [conT _Type, conT _Identity, varT _a]))
207+
208+derivOrdIdent :: Name -> Q Dec
209+derivOrdIdent _Type =
210+ standaloneDerivD
211+ (singleton <$> [t|Ord $(varT _a)|])
212+ (appT (conT _Ord) (foldl1 appT [conT _Type, conT _Identity, varT _a]))
213+
214+derivTraversableIdent :: Name -> Q Dec
215+derivTraversableIdent _Type =
216+ standaloneDerivD
217+ (pure [])
218+ (appT
219+ (conT _Traversable)
220+ (foldl1 appT [conT _Type, conT _Identity, varT _a]))
221+
222+showInstance :: Name -> Q Dec
223+showInstance _Type =
224+ instanceD
225+ (singleton <$> appT (conT _Show) (varT _a))
226+ (appT (conT _Show) (foldl1 appT [conT _Type, conT _Identity, varT _a]))
227+ [ pragInlD _show Inline FunLike AllPhases
228+ , funD
229+ _show
230+ [ clause
231+ [conP _Type [varP _strm]]
232+ (normalB (appE (varE _show) (varE _strm)))
233+ []
234+ ]
235+ ]
236+
237+readInstance :: Name -> Q Dec
238+readInstance _Type =
239+ instanceD
240+ (singleton <$> appT (conT _Read) (varT _a))
241+ (appT (conT _Read) (foldl1 appT [conT _Type, conT _Identity, varT _a]))
242+ [ pragInlD _read Inline FunLike AllPhases
243+ , funD
244+ _read
245+ [ clause
246+ []
247+ (normalB (foldl1 appE [varE _dotOp, conE _Type, varE _read]))
248+ []
249+ ]
250+ ]
251+
252+functorInstance :: Name -> Q Dec
253+functorInstance _Type = do
254+ instanceD
255+ (pure <$> appT (conT _Monad) (varT _m))
256+ (appT (conT _Functor) (appT (conT _Type) (varT _m)))
257+ [ pragInlD _fmap Inline FunLike AllPhases
258+ , funD
259+ _fmap
260+ [ clause
261+ [varP _f, conP _Type [varP _strm]]
262+ (normalB
263+ (appE
264+ (conE _Type)
265+ (appE (appE (varE _fmap) (varE _f)) (varE _strm))))
266+ []
267+ ]
268+ ]
269+
270+monadtransInstance :: Name -> Q Dec
271+monadtransInstance _Type =
272+ instanceD
273+ (pure [])
274+ (appT (conT _MonadTrans) (conT _Type))
275+ [ pragInlD _lift Inline FunLike AllPhases
276+ , funD
277+ _lift
278+ [ clause
279+ []
280+ (normalB
281+ (infixE
282+ (Just (conE _Type))
283+ (varE _dotOp)
284+ (Just (varE _lift))))
285+ []
286+ ]
287+ ]
288+
289+monadioInstance :: Name -> Q Dec
290+monadioInstance _Type =
291+ instanceD
292+ (sequence
293+ [ appT (conT _Monad) (appT (conT _Type) (varT _m))
294+ , appT (conT _MonadIO) (varT _m)
295+ ])
296+ (appT (conT _MonadIO) (appT (conT _Type) (varT _m)))
297+ [ pragInlD _liftIO Inline FunLike AllPhases
298+ , funD
299+ _liftIO
300+ [ clause
301+ []
302+ (normalB
303+ (infixE
304+ (Just (conE _Type))
305+ (varE _dotOp)
306+ (Just
307+ (infixE
308+ (Just (varE _lift))
309+ (varE _dotOp)
310+ (Just (varE _liftIO))))))
311+ []
312+ ]
313+ ]
314+
315+monadthrowInstance :: Name -> Q Dec
316+monadthrowInstance _Type =
317+ instanceD
318+ (sequence
319+ [ appT (conT _Monad) (appT (conT _Type) (varT _m))
320+ , appT (conT _MonadThrow) (varT _m)
321+ ])
322+ (appT (conT _MonadThrow) (appT (conT _Type) (varT _m)))
323+ [ pragInlD _throwM Inline FunLike AllPhases
324+ , funD
325+ _throwM
326+ [ clause
327+ []
328+ (normalB
329+ (infixE
330+ (Just (conE _Type))
331+ (varE _dotOp)
332+ (Just
333+ (infixE
334+ (Just (varE _lift))
335+ (varE _dotOp)
336+ (Just (varE _throwM))))))
337+ []
338+ ]
339+ ]
340+
341+monadreaderInstance :: Name -> Q Dec
342+monadreaderInstance _Type =
343+ instanceD
344+ (sequence
345+ [ appT (conT _Monad) (appT (conT _Type) (varT _m))
346+ , appT (appT (conT _MonadReader) (varT _r)) (varT _m)
347+ ])
348+ (appT (appT (conT _MonadReader) (varT _r)) (appT (conT _Type) (varT _m)))
349+ [ pragInlD _ask Inline FunLike AllPhases
350+ , funD _ask [clause [] (normalB (appE (varE _lift) (varE _ask))) []]
351+ , pragInlD _local Inline FunLike AllPhases
352+ , funD
353+ _local
354+ [ clause
355+ [varP _f, conP _Type [varP _strm]]
356+ (normalB
357+ (appE
358+ (conE _Type)
359+ (appE (appE (varE _local) (varE _f)) (varE _strm))))
360+ []
361+ ]
362+ ]
363+
364+
365+--------------------------------------------------------------------------------
366+-- Type declaration
367+--------------------------------------------------------------------------------
368+
369+typeDec :: String -> [Name] -> Q [Dec]
370+typeDec dtNameStr toDerive = do
147371 typ <-
148372 newtypeD
149373 (return [])
@@ -156,7 +380,7 @@ makeTypeDec dtNameStr = do
156380 (bang noSourceUnpackedness noSourceStrictness)
157381 (appT (appT (conT _Stream) (varT _m)) (varT _a))
158382 ])
159− []
383+ [derivClause Nothing (conT <$> toDerive)]
160384 let streamType = appT (appT (conT _Stream) (varT _m)) (varT _a)
161385 nameType = appT (appT (conT _Type) (varT _m)) (varT _a)
162386 mkTypSig <- sigD _toType (appT (appT arrowT streamType) nameType)
@@ -174,27 +398,9 @@ makeTypeDec dtNameStr = do
174398 _toType = mkName (toTypeStr dtNameStr)
175399 _unType = mkName (unTypeStr dtNameStr)
176400
177−makeStreamFunctor :: String -> Q Dec
178−makeStreamFunctor dtNameStr = do
179− instanceD
180− (pure <$> appT (conT _Monad) (varT _m))
181− (appT (conT _Functor) (appT (conT _Type) (varT _m)))
182− [ pragInlD _fmap Inline FunLike AllPhases
183− , funD
184− _fmap
185− [ clause
186− [varP _f, conP _Type [varP _strm]]
187− (normalB
188− (appE
189− (conE _Type)
190− (appE (appE (varE _fmap) (varE _f)) (varE _strm))))
191− []
192− ]
193− ]
194−
195− where
196−
197− _Type = mkName dtNameStr
401+--------------------------------------------------------------------------------
402+-- Main deivations
403+--------------------------------------------------------------------------------
198404
199405mkStreamApplicative :: String -> [String] -> String -> String -> Q Dec
200406mkStreamApplicative dtNameStr ctxM pureDefStr apDefStr =
@@ -272,118 +478,40 @@ mkStreamMonad dtNameStr ctxM bindDefStr =
272478 _unType = mkName (unTypeStr dtNameStr)
273479 _bindDef = mkName bindDefStr
274480
275−mkSimpleStreamInstances :: String -> Q [Dec]
276−mkSimpleStreamInstances dtNameStr = do
277− trans <-
278− instanceD
279− (pure [])
280− (appT (conT _MonadTrans) (conT _Type))
281− [ pragInlD _lift Inline FunLike AllPhases
282− , funD
283− _lift
284− [ clause
285− []
286− (normalB
287− (infixE
288− (Just (conE _Type))
289− (varE _dotOp)
290− (Just (varE _lift))))
291− []
292− ]
293− ]
294− io <-
295− instanceD
296− (sequence
297− [ appT (conT _Monad) (appT (conT _Type) (varT _m))
298− , appT (conT _MonadIO) (varT _m)
299− ])
300− (appT (conT _MonadIO) (appT (conT _Type) (varT _m)))
301− [ pragInlD _liftIO Inline FunLike AllPhases
302− , funD
303− _liftIO
304− [ clause
305− []
306− (normalB
307− (infixE
308− (Just (conE _Type))
309− (varE _dotOp)
310− (Just
311− (infixE
312− (Just (varE _lift))
313− (varE _dotOp)
314− (Just (varE _liftIO))))))
315− []
316− ]
317− ]
318− throw <-
319− instanceD
320− (sequence
321− [ appT (conT _Monad) (appT (conT _Type) (varT _m))
322− , appT (conT _MonadThrow) (varT _m)
323− ])
324− (appT (conT _MonadThrow) (appT (conT _Type) (varT _m)))
325− [ pragInlD _throwM Inline FunLike AllPhases
326− , funD
327− _throwM
328− [ clause
329− []
330− (normalB
331− (infixE
332− (Just (conE _Type))
333− (varE _dotOp)
334− (Just
335− (infixE
336− (Just (varE _lift))
337− (varE _dotOp)
338− (Just (varE _throwM))))))
339− []
340− ]
341− ]
342− rdr <-
343− instanceD
344− (sequence
345− [ appT (conT _Monad) (appT (conT _Type) (varT _m))
346− , appT (appT (conT _MonadReader) (varT _r)) (varT _m)
347− ])
348− (appT
349− (appT (conT _MonadReader) (varT _r))
350− (appT (conT _Type) (varT _m)))
351− [ pragInlD _ask Inline FunLike AllPhases
352− , funD _ask [clause [] (normalB (appE (varE _lift) (varE _ask))) []]
353− , pragInlD _local Inline FunLike AllPhases
354− , funD
355− _local
356− [ clause
357− [varP _f, conP _Type [varP _strm]]
358− (normalB
359− (appE
360− (conE _Type)
361− (appE
362− (appE (varE _local) (varE _f))
363− (varE _strm))))
364− []
365− ]
366− ]
367− return [trans, io, throw, rdr]
368−
369− where
370−
371− _Type = mkName dtNameStr
372− _unType = mkName (unTypeStr dtNameStr)
373−
374481--------------------------------------------------------------------------------
375482-- Functions
376483--------------------------------------------------------------------------------
377484
485+flattenDec :: [Q [Dec]] -> Q [Dec]
486+flattenDec [] = pure []
487+flattenDec (ma:mas) = do
488+ a <- ma
489+ as <- flattenDec mas
490+ pure (a ++ as)
491+
378492-- | Create a type with a zip-like applicative.
379493--
380494-- >>> expr <- runQ (mkZipType "ZipStream" "zipApply" False)
381495-- >>> putStrLn $ pprint expr
382−-- newtype ZipStream m a = ZipStream (Stream.Stream m a)
496+-- newtype ZipStream m a
497+-- = ZipStream (Stream.Stream m a)
498+-- deriving (Semigroup, Monoid, Foldable)
383499-- mkZipStream :: Stream.Stream m a -> ZipStream m a
384500-- mkZipStream = ZipStream
385501-- unZipStream :: ZipStream m a -> Stream.Stream m a
386502-- unZipStream (ZipStream strm) = strm
503+-- deriving instance IsList (ZipStream Identity a)
504+-- deriving instance a ~
505+-- GHC.Types.Char => IsString (ZipStream Identity a)
506+-- deriving instance GHC.Classes.Eq a => Eq (ZipStream Identity a)
507+-- deriving instance GHC.Classes.Ord a => Ord (ZipStream Identity a)
508+-- deriving instance Traversable (ZipStream Identity a)
509+-- instance Show a => Show (ZipStream Identity a)
510+-- where {-# INLINE show #-}
511+-- show (ZipStream strm) = show strm
512+-- instance Read a => Read (ZipStream Identity a)
513+-- where {-# INLINE read #-}
514+-- read = (.) ZipStream read
387515-- instance Monad m => Functor (ZipStream m)
388516-- where {-# INLINE fmap #-}
389517-- fmap f (ZipStream strm) = ZipStream (fmap f strm)
@@ -392,41 +520,41 @@ mkSimpleStreamInstances dtNameStr = do
392520-- pure = ZipStream . Stream.repeat
393521-- {-# INLINE (<*>) #-}
394522-- (<*>) (ZipStream strm1) (ZipStream strm2) = ZipStream (zipApply strm1 strm2)
395−-- instance MonadTrans ZipStream
396−-- where {-# INLINE lift #-}
397−-- lift = ZipStream . lift
398−-- instance (Monad (ZipStream m), MonadIO m) => MonadIO (ZipStream m)
399−-- where {-# INLINE liftIO #-}
400−-- liftIO = ZipStream . (lift . liftIO)
401−-- instance (Monad (ZipStream m),
402−-- MonadThrow m) => MonadThrow (ZipStream m)
403−-- where {-# INLINE throwM #-}
404−-- throwM = ZipStream . (lift . throwM)
405−-- instance (Monad (ZipStream m), MonadReader r m) => MonadReader r
406−-- (ZipStream m)
407−-- where {-# INLINE ask #-}
408−-- ask = lift ask
409−-- {-# INLINE local #-}
410−-- local f (ZipStream strm) = ZipStream (local f strm)
411523mkZipType
412524 :: String -- ^ Name of the type
413525 -> String -- ^ Function to use for (\<*\>)
414526 -> Bool -- ^ 'True' if (\<*\>) requires MonadAsync constraint (concurrent)
415527 -> Q [Dec]
416−mkZipType dtNameStr apOpStr isConcurrent = do
417− typeDec <- makeTypeDec dtNameStr
418− functorI <- makeStreamFunctor dtNameStr
419− applicativeI <-
420− mkStreamApplicative
421− dtNameStr
422− classConstraints
423− "Stream.repeat"
424− apOpStr
425− simpleInstances <- mkSimpleStreamInstances dtNameStr
426− return $ typeDec ++ [functorI, applicativeI] ++ simpleInstances
528+mkZipType dtNameStr apOpStr isConcurrent =
529+ flattenDec
530+ [ typeDec dtNameStr
531+ $ if (not isConcurrent)
532+ then [_Semigroup, _Monoid, _Foldable]
533+ else []
534+ , sequence
535+ $ if (not isConcurrent)
536+ then [ derivIsListIdent _Type
537+ , derivIsStringIdent _Type
538+ , derivEqIdent _Type
539+ , derivOrdIdent _Type
540+ , derivTraversableIdent _Type
541+ , showInstance _Type
542+ , readInstance _Type
543+ ]
544+ else []
545+ , sequence
546+ [ functorInstance _Type
547+ , mkStreamApplicative
548+ dtNameStr
549+ classConstraints
550+ "Stream.repeat"
551+ apOpStr
552+ ]
553+ ]
427554
428555 where
429556
557+ _Type = mkName dtNameStr
430558 classConstraints =
431559 if isConcurrent
432560 then ["Stream.MonadAsync"]
@@ -474,21 +602,41 @@ mkCrossType
474602 -> String -- ^ Function to use for (>>=)
475603 -> Bool -- ^ 'True' if (>>=) requires MonadAsync constraint (concurrent)
476604 -> Q [Dec]
477−mkCrossType dtNameStr bindOpStr isConcurrent = do
478− typeDec <- makeTypeDec dtNameStr
479− functorI <- makeStreamFunctor dtNameStr
480− monadI <- mkStreamMonad dtNameStr classConstraints bindOpStr
481− applicativeI <-
482− mkStreamApplicative
483− dtNameStr
484− classConstraints
485− "Stream.fromPure"
486− "ap"
487− simpleInstances <- mkSimpleStreamInstances dtNameStr
488− return $ typeDec ++ [functorI, monadI, applicativeI] ++ simpleInstances
605+mkCrossType dtNameStr bindOpStr isConcurrent =
606+ flattenDec
607+ [ typeDec dtNameStr
608+ $ if (not isConcurrent)
609+ then [_Semigroup, _Monoid, _Foldable]
610+ else []
611+ , sequence
612+ $ if (not isConcurrent)
613+ then [ derivIsListIdent _Type
614+ , derivIsStringIdent _Type
615+ , derivEqIdent _Type
616+ , derivOrdIdent _Type
617+ , derivTraversableIdent _Type
618+ , showInstance _Type
619+ , readInstance _Type
620+ ]
621+ else []
622+ , sequence
623+ [ functorInstance _Type
624+ , mkStreamMonad dtNameStr classConstraints bindOpStr
625+ , mkStreamApplicative
626+ dtNameStr
627+ classConstraints
628+ "Stream.fromPure"
629+ "ap"
630+ , monadtransInstance _Type
631+ , monadioInstance _Type
632+ , monadthrowInstance _Type
633+ , monadreaderInstance _Type
634+ ]
635+ ]
489636
490637 where
491638
639+ _Type = mkName dtNameStr
492640 classConstraints =
493641 if isConcurrent
494642 then ["Stream.MonadAsync"]