@@ -38,7 +38,6 @@ import Control.Monad.Catch (MonadThrow(..))
3838import Control.Monad.IO.Class (MonadIO(..))
3939import Control.Monad.Reader.Class (MonadReader(..))
4040import Control.Monad.Trans.Class (MonadTrans(..))
41−import Data.List (singleton)
4241import Prelude hiding (repeat)
4342
4443-- $setup
@@ -51,6 +50,10 @@ import Prelude hiding (repeat)
5150-- Helpers
5251--------------------------------------------------------------------------------
5352
53+{-# INLINE singleton #-}
54+singleton :: a -> [a]
55+singleton x = [x]
56+
5457toTypeStr :: String -> String
5558toTypeStr typ = "mk" ++ typ
5659
@@ -169,8 +172,8 @@ _Show = mkName "Show"
169172_show :: Name
170173_show = mkName "show"
171174
172−_read :: Name
173−_read = mkName "read"
175+_readPrec :: Name
176+_readPrec = mkName "readPrec"
174177
175178_Semigroup :: Name
176179_Semigroup = mkName "Semigroup"
@@ -185,6 +188,7 @@ _Foldable = mkName "Foldable"
185188-- Simple derivations
186189--------------------------------------------------------------------------------
187190
191+-- Requires TypeFamilies and UndecidableInstances
188192derivIsListIdent :: Name -> Q Dec
189193derivIsListIdent _Type =
190194 standaloneDerivD
@@ -217,7 +221,7 @@ derivTraversableIdent _Type =
217221 (pure [])
218222 (appT
219223 (conT _Traversable)
220− (foldl1 appT [conT _Type, conT _Identity, varT _a]))
224+ (foldl1 appT [conT _Type, conT _Identity]))
221225
222226showInstance :: Name -> Q Dec
223227showInstance _Type =
@@ -239,12 +243,14 @@ readInstance _Type =
239243 instanceD
240244 (singleton <$> appT (conT _Read) (varT _a))
241245 (appT (conT _Read) (foldl1 appT [conT _Type, conT _Identity, varT _a]))
242− [ pragInlD _read Inline FunLike AllPhases
246+ [ pragInlD _readPrec Inline FunLike AllPhases
243247 , funD
244− _read
248+ _readPrec
245249 [ clause
246250 []
247− (normalB (foldl1 appE [varE _dotOp, conE _Type, varE _read]))
251+ (normalB
252+ (foldl1 appE [varE _fmap, conE _Type, varE _readPrec])
253+ )
248254 []
249255 ]
250256 ]
@@ -281,7 +287,7 @@ monadtransInstance _Type =
281287 (infixE
282288 (Just (conE _Type))
283289 (varE _dotOp)
284− (Just (varE _lift))))
290+ (Just (varE (mkName "Stream.fromEffect")))))
285291 []
286292 ]
287293 ]
@@ -305,7 +311,7 @@ monadioInstance _Type =
305311 (varE _dotOp)
306312 (Just
307313 (infixE
308− (Just (varE _lift))
314+ (Just (varE (mkName "Stream.fromEffect")))
309315 (varE _dotOp)
310316 (Just (varE _liftIO))))))
311317 []
@@ -326,18 +332,15 @@ monadthrowInstance _Type =
326332 [ clause
327333 []
328334 (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))))))
335+ (infixE
336+ (Just (varE _lift))
337+ (varE _dotOp)
338+ (Just (varE _throwM))))
337339 []
338340 ]
339341 ]
340342
343+{-
341344monadreaderInstance :: Name -> Q Dec
342345monadreaderInstance _Type =
343346 instanceD
@@ -360,7 +363,7 @@ monadreaderInstance _Type =
360363 []
361364 ]
362365 ]
363−
366+-}
364367
365368--------------------------------------------------------------------------------
366369-- Type declaration
@@ -380,7 +383,7 @@ typeDec dtNameStr toDerive = do
380383 (bang noSourceUnpackedness noSourceStrictness)
381384 (appT (appT (conT _Stream) (varT _m)) (varT _a))
382385 ])
383− [derivClause Nothing (conT <$> toDerive)]
386+ [derivClause Nothing (conT <$> toDerive) | not (null toDerive)]
384387 let streamType = appT (appT (conT _Stream) (varT _m)) (varT _a)
385388 nameType = appT (appT (conT _Type) (varT _m)) (varT _a)
386389 mkTypSig <- sigD _toType (appT (appT arrowT streamType) nameType)
@@ -402,8 +405,8 @@ typeDec dtNameStr toDerive = do
402405-- Main deivations
403406--------------------------------------------------------------------------------
404407
405−mkStreamApplicative :: String -> [String] -> String -> String -> Q Dec
406−mkStreamApplicative dtNameStr ctxM pureDefStr apDefStr =
408+mkStreamApplicative :: Bool -> String -> [String] -> String -> String -> Q Dec
409+mkStreamApplicative isMonad dtNameStr ctxM pureDefStr apDefStr =
407410 instanceD
408411 (Prelude.mapM (\c -> appT (conT (mkName c)) (varT _m)) ctxM)
409412 (appT (conT _Applicative) (appT (conT _Type) (varT _m)))
@@ -422,15 +425,9 @@ mkStreamApplicative dtNameStr ctxM pureDefStr apDefStr =
422425 , pragInlD _apOp Inline FunLike AllPhases
423426 , funD
424427 _apOp
425− [ clause
426− [conP _Type [varP _strm1], conP _Type [varP _strm2]]
427− (normalB
428− (appE
429− (conE _Type)
430− (appE
431− (appE (varE _apDef) (varE _strm1))
432− (varE _strm2))))
433− []
428+ [ if isMonad
429+ then apClauseMonad
430+ else apClauseApplicative
434431 ]
435432 ]
436433
@@ -439,6 +436,17 @@ mkStreamApplicative dtNameStr ctxM pureDefStr apDefStr =
439436 _Type = mkName dtNameStr
440437 _pureDef = mkName pureDefStr
441438 _apDef = mkName apDefStr
439+ apClauseMonad = clause [] (normalB (varE _apDef)) []
440+ apClauseApplicative =
441+ clause
442+ [conP _Type [varP _strm1], conP _Type [varP _strm2]]
443+ (normalB
444+ (appE
445+ (conE _Type)
446+ (appE
447+ (appE (varE _apDef) (varE _strm1))
448+ (varE _strm2))))
449+ []
442450
443451mkStreamMonad :: String -> [String] -> String -> Q Dec
444452mkStreamMonad dtNameStr ctxM bindDefStr =
@@ -505,13 +513,13 @@ flattenDec (ma:mas) = do
505513-- GHC.Types.Char => IsString (ZipStream Identity a)
506514-- deriving instance GHC.Classes.Eq a => Eq (ZipStream Identity a)
507515-- deriving instance GHC.Classes.Ord a => Ord (ZipStream Identity a)
508−-- deriving instance Traversable (ZipStream Identity a)
516+-- deriving instance Traversable (ZipStream Identity)
509517-- instance Show a => Show (ZipStream Identity a)
510518-- where {-# INLINE show #-}
511519-- show (ZipStream strm) = show strm
512520-- instance Read a => Read (ZipStream Identity a)
513−-- where {-# INLINE read #-}
514−-- read = (.) ZipStream read
521+-- where {-# INLINE readPrec #-}
522+-- readPrec = fmap ZipStream readPrec
515523-- instance Monad m => Functor (ZipStream m)
516524-- where {-# INLINE fmap #-}
517525-- fmap f (ZipStream strm) = ZipStream (fmap f strm)
@@ -528,11 +536,11 @@ mkZipType
528536mkZipType dtNameStr apOpStr isConcurrent =
529537 flattenDec
530538 [ typeDec dtNameStr
531− $ if (not isConcurrent)
539+ $ if not isConcurrent
532540 then [_Semigroup, _Monoid, _Foldable]
533541 else []
534542 , sequence
535− $ if (not isConcurrent)
543+ $ if not isConcurrent
536544 then [ derivIsListIdent _Type
537545 , derivIsStringIdent _Type
538546 , derivEqIdent _Type
@@ -545,6 +553,7 @@ mkZipType dtNameStr apOpStr isConcurrent =
545553 , sequence
546554 [ functorInstance _Type
547555 , mkStreamApplicative
556+ False
548557 dtNameStr
549558 classConstraints
550559 "Stream.repeat"
@@ -580,23 +589,17 @@ mkZipType dtNameStr apOpStr isConcurrent =
580589-- where {-# INLINE pure #-}
581590-- pure = Parallel . Stream.fromPure
582591-- {-# INLINE (<*>) #-}
583−-- (<*>) (Parallel strm1) (Parallel strm2) = Parallel (ap strm1 strm2)
584−-- instance MonadTrans Parallel
585−-- where {-# INLINE lift #-}
586−-- lift = Parallel . lift
592+-- (<*>) = ap
587593-- instance (Monad (Parallel m), MonadIO m) => MonadIO (Parallel m)
588594-- where {-# INLINE liftIO #-}
589−-- liftIO = Parallel . (lift . liftIO)
595+-- liftIO = Parallel . (Stream.fromEffect . liftIO)
596+-- instance MonadTrans Parallel
597+-- where {-# INLINE lift #-}
598+-- lift = Parallel . Stream.fromEffect
590599-- instance (Monad (Parallel m),
591600-- MonadThrow m) => MonadThrow (Parallel m)
592601-- where {-# INLINE throwM #-}
593−-- throwM = Parallel . (lift . throwM)
594−-- instance (Monad (Parallel m), MonadReader r m) => MonadReader r
595−-- (Parallel m)
596−-- where {-# INLINE ask #-}
597−-- ask = lift ask
598−-- {-# INLINE local #-}
599−-- local f (Parallel strm) = Parallel (local f strm)
602+-- throwM = lift . throwM
600603mkCrossType
601604 :: String -- ^ Name of the type
602605 -> String -- ^ Function to use for (>>=)
@@ -605,11 +608,11 @@ mkCrossType
605608mkCrossType dtNameStr bindOpStr isConcurrent =
606609 flattenDec
607610 [ typeDec dtNameStr
608− $ if (not isConcurrent)
611+ $ if not isConcurrent
609612 then [_Semigroup, _Monoid, _Foldable]
610613 else []
611614 , sequence
612− $ if (not isConcurrent)
615+ $ if not isConcurrent
613616 then [ derivIsListIdent _Type
614617 , derivIsStringIdent _Type
615618 , derivEqIdent _Type
@@ -623,14 +626,15 @@ mkCrossType dtNameStr bindOpStr isConcurrent =
623626 [ functorInstance _Type
624627 , mkStreamMonad dtNameStr classConstraints bindOpStr
625628 , mkStreamApplicative
629+ True
626630 dtNameStr
627631 classConstraints
628632 "Stream.fromPure"
629633 "ap"
630− , monadtransInstance _Type
631634 , monadioInstance _Type
635+ , monadtransInstance _Type
632636 , monadthrowInstance _Type
633− , monadreaderInstance _Type
637+ -- , monadreaderInstance _Type
634638 ]
635639 ]
636640