bd98981 · streamly · git.iko.soy

git.iko.soy/streamly

on master help sign in

Fix MkType module

bd98981Harendra Kumar4 years ago

src/Streamly/Data/Stream/MkType.hs+24−13

compare with master

unifiedsplit

@@ -9,43 +9,46 @@

9-- Template Haskell macros to create custom newtype wrappers for the 'Stream'

10-- type, deriving all the usual instances.

11--

12−-- To use this module, "Streamly.Data.Stream" or "Streamly.Data.Stream.Prelude"

12+-- To use this module, the following extensions must be enabled:

13−-- must be imported @as Stream@. Also, it is recommended to import this module

14−-- unqualified to bring everything needed in scope without having to import

15−-- several other modules.

16--

13--

14+-- >>> :set -XStandaloneDeriving

17-- >>> :set -XTemplateHaskell

15-- >>> :set -XTemplateHaskell

16+-- >>> :set -XTypeFamilies

18-- >>> :set -XUndecidableInstances

17-- >>> :set -XUndecidableInstances

19--

18--

19+-- Import this module unqualified to bring everything needed in scope without

20+-- having to import several other modules. Also, "Streamly.Data.Stream" or

20−-- >>> import qualified Streamly.Data.Stream.Prelude as Stream

21+-- "Streamly.Data.Stream.Prelude" must be imported @as Stream@.

22+--

21-- >>> import Streamly.Data.Stream.MkType

23-- >>> import Streamly.Data.Stream.MkType

24+-- >>> import qualified Streamly.Data.Stream.Prelude as Stream

22--

25--

23-- Example, create an applicative type with zipping apply:

26-- Example, create an applicative type with zipping apply:

24--

27--

25-- >>> :{

28-- >>> :{

26−-- zipApply = Stream.zipWith ($)

29+-- zipApply = Stream.zipWith ($)

27−-- $(mkZipType "ZipStream" "zipApply" False)

30+-- $(mkZipType "ZipStream" "zipApply" False)

28-- :}

31-- :}

29--

32--

30-- Example, create an applicative type with concurrent zipping apply:

33-- Example, create an applicative type with concurrent zipping apply:

31--

34--

32-- >>> :{

35-- >>> :{

33−-- parApply = Stream.parApply id

36+-- parApply = Stream.parApply id

34−-- $(mkZipType "ParZipStream" "parApply" True)

37+-- $(mkZipType "ParZipStream" "parApply" True)

35-- :}

38-- :}

36--

39--

37-- Example, create a monad type with an interleaving cross product bind:

40-- Example, create a monad type with an interleaving cross product bind:

38--

41--

39-- >>> :{

42-- >>> :{

40−-- interleaveBind = flip (Stream.concatMapWith Stream.interleave)

43+-- interleaveBind = flip (Stream.concatMapWith Stream.interleave)

41−-- $(mkCrossType "InterleaveStream" "interleaveBind" False)

44+-- $(mkCrossType "InterleaveStream" "interleaveBind" False)

42-- :}

45-- :}

43--

46--

44-- Example, create a monad type with an eager concurrent cross product bind:

47-- Example, create a monad type with an eager concurrent cross product bind:

45--

48--

46-- >>> :{

49-- >>> :{

47−-- parBind = flip (Stream.parConcatMap (Stream.eager True))

50+-- parBind = flip (Stream.parConcatMap (Stream.eager True))

48−-- $(mkCrossType "ParEagerStream" "parBind" True)

51+-- $(mkCrossType "ParEagerStream" "parBind" True)

49-- :}

52-- :}

50--

53--

51-- Instead of using these macros directly you could use the generated code as

54-- Instead of using these macros directly you could use the generated code as

@@ -63,14 +66,22 @@ module Streamly.Data.Stream.MkType

63 , mkCrossType

66 , mkCrossType

65 -- * Re-exports

68 -- * Re-exports

69+ , Read(..)

66 , MonadIO(..)

70 , MonadIO(..)

67 , MonadThrow(..)

71 , MonadThrow(..)

68 , MonadReader(..)

72 , MonadReader(..)

69 , MonadTrans(..)

73 , MonadTrans(..)

74+ , Identity

75+ , IsList

76+ , IsString

70 , ap

77 , ap

71 )

78 )

72where

79where

81+import Data.Functor.Identity (Identity)

82+import GHC.Exts (IsList, IsString)

83+import Text.Read (Read(..))

84+

74import Streamly.Internal.Data.Stream.MkType

85import Streamly.Internal.Data.Stream.MkType

76-- $setup

87-- $setup

src/Streamly/Internal/Data/Stream/MkType.hs+55−51

@@ -38,7 +38,6 @@ import Control.Monad.Catch (MonadThrow(..))

38import Control.Monad.IO.Class (MonadIO(..))

39import Control.Monad.Reader.Class (MonadReader(..))

40import Control.Monad.Trans.Class (MonadTrans(..))

41−import Data.List (singleton)

42import Prelude hiding (repeat)

41import Prelude hiding (repeat)

44-- $setup

43-- $setup

@@ -51,6 +50,10 @@ import Prelude hiding (repeat)

51-- Helpers

50-- Helpers

52--------------------------------------------------------------------------------

51--------------------------------------------------------------------------------

53+{-# INLINE singleton #-}

54+singleton :: a -> [a]

55+singleton x = [x]

56+

54toTypeStr :: String -> String

57toTypeStr :: String -> String

55toTypeStr typ = "mk" ++ typ

58toTypeStr typ = "mk" ++ typ

@@ -169,8 +172,8 @@ _Show = mkName "Show"

169_show :: Name

172_show :: Name

170_show = mkName "show"

173_show = mkName "show"

171

174

172−_read :: Name

175+_readPrec :: Name

173−_read = mkName "read"

176+_readPrec = mkName "readPrec"

174

177

175_Semigroup :: Name

178_Semigroup :: Name

176_Semigroup = mkName "Semigroup"

179_Semigroup = mkName "Semigroup"

@@ -185,6 +188,7 @@ _Foldable = mkName "Foldable"

185-- Simple derivations

188-- Simple derivations

186--------------------------------------------------------------------------------

189--------------------------------------------------------------------------------

187

190

191+-- Requires TypeFamilies and UndecidableInstances

188derivIsListIdent :: Name -> Q Dec

192derivIsListIdent :: Name -> Q Dec

189derivIsListIdent _Type =

193derivIsListIdent _Type =

190 standaloneDerivD

194 standaloneDerivD

@@ -217,7 +221,7 @@ derivTraversableIdent _Type =

217 (pure [])

221 (pure [])

218 (appT

222 (appT

219 (conT _Traversable)

223 (conT _Traversable)

220− (foldl1 appT [conT _Type, conT _Identity, varT _a]))

224+ (foldl1 appT [conT _Type, conT _Identity]))

221

225

222showInstance :: Name -> Q Dec

226showInstance :: Name -> Q Dec

223showInstance _Type =

227showInstance _Type =

@@ -239,12 +243,14 @@ readInstance _Type =

239 instanceD

243 instanceD

240 (singleton <$> appT (conT _Read) (varT _a))

244 (singleton <$> appT (conT _Read) (varT _a))

241 (appT (conT _Read) (foldl1 appT [conT _Type, conT _Identity, varT _a]))

245 (appT (conT _Read) (foldl1 appT [conT _Type, conT _Identity, varT _a]))

242− [ pragInlD _read Inline FunLike AllPhases

246+ [ pragInlD _readPrec Inline FunLike AllPhases

243 , funD

247 , funD

244− _read

248+ _readPrec

245 [ clause

249 [ clause

246 []

250 []

251+ (normalB

247− (normalB (foldl1 appE [varE _dotOp, conE _Type, varE _read]))

252+ (foldl1 appE [varE _fmap, conE _Type, varE _readPrec])

253+ )

248 []

254 []

249 ]

255 ]

250 ]

256 ]

@@ -281,7 +287,7 @@ monadtransInstance _Type =

281 (infixE

287 (infixE

282 (Just (conE _Type))

288 (Just (conE _Type))

283 (varE _dotOp)

289 (varE _dotOp)

284− (Just (varE _lift))))

290+ (Just (varE (mkName "Stream.fromEffect")))))

285 []

291 []

286 ]

292 ]

287 ]

293 ]

@@ -305,7 +311,7 @@ monadioInstance _Type =

305 (varE _dotOp)

311 (varE _dotOp)

306 (Just

312 (Just

307 (infixE

313 (infixE

308− (Just (varE _lift))

314+ (Just (varE (mkName "Stream.fromEffect")))

309 (varE _dotOp)

315 (varE _dotOp)

310 (Just (varE _liftIO))))))

316 (Just (varE _liftIO))))))

311 []

317 []

@@ -326,18 +332,15 @@ monadthrowInstance _Type =

326 [ clause

332 [ clause

327 []

333 []

328 (normalB

334 (normalB

329− (infixE

335+ (infixE

330− (Just (conE _Type))

331− (varE _dotOp)

332− (Just

333− (infixE

334− (Just (varE _lift))

336+ (Just (varE _lift))

335− (varE _dotOp)

337+ (varE _dotOp)

336− (Just (varE _throwM))))))

338+ (Just (varE _throwM))))

337 []

339 []

338 ]

340 ]

339 ]

341 ]

340

342

343+{-

341monadreaderInstance :: Name -> Q Dec

344monadreaderInstance :: Name -> Q Dec

342monadreaderInstance _Type =

345monadreaderInstance _Type =

343 instanceD

346 instanceD

@@ -360,7 +363,7 @@ monadreaderInstance _Type =

360 []

363 []

361 ]

364 ]

362 ]

365 ]

363−

366+-}

364

367

365--------------------------------------------------------------------------------

368--------------------------------------------------------------------------------

366-- Type declaration

369-- Type declaration

@@ -380,7 +383,7 @@ typeDec dtNameStr toDerive = do

380 (bang noSourceUnpackedness noSourceStrictness)

383 (bang noSourceUnpackedness noSourceStrictness)

381 (appT (appT (conT _Stream) (varT _m)) (varT _a))

384 (appT (appT (conT _Stream) (varT _m)) (varT _a))

382 ])

385 ])

383− [derivClause Nothing (conT <$> toDerive)]

386+ [derivClause Nothing (conT <$> toDerive) | not (null toDerive)]

384 let streamType = appT (appT (conT _Stream) (varT _m)) (varT _a)

387 let streamType = appT (appT (conT _Stream) (varT _m)) (varT _a)

385 nameType = appT (appT (conT _Type) (varT _m)) (varT _a)

388 nameType = appT (appT (conT _Type) (varT _m)) (varT _a)

386 mkTypSig <- sigD _toType (appT (appT arrowT streamType) nameType)

389 mkTypSig <- sigD _toType (appT (appT arrowT streamType) nameType)

@@ -402,8 +405,8 @@ typeDec dtNameStr toDerive = do

402-- Main deivations

405-- Main deivations

403--------------------------------------------------------------------------------

406--------------------------------------------------------------------------------

404

407

405−mkStreamApplicative :: String -> [String] -> String -> String -> Q Dec

408+mkStreamApplicative :: Bool -> String -> [String] -> String -> String -> Q Dec

406−mkStreamApplicative dtNameStr ctxM pureDefStr apDefStr =

409+mkStreamApplicative isMonad dtNameStr ctxM pureDefStr apDefStr =

407 instanceD

410 instanceD

408 (Prelude.mapM (\c -> appT (conT (mkName c)) (varT _m)) ctxM)

411 (Prelude.mapM (\c -> appT (conT (mkName c)) (varT _m)) ctxM)

409 (appT (conT _Applicative) (appT (conT _Type) (varT _m)))

412 (appT (conT _Applicative) (appT (conT _Type) (varT _m)))

@@ -422,15 +425,9 @@ mkStreamApplicative dtNameStr ctxM pureDefStr apDefStr =

422 , pragInlD _apOp Inline FunLike AllPhases

425 , pragInlD _apOp Inline FunLike AllPhases

423 , funD

426 , funD

424 _apOp

427 _apOp

425− [ clause

428+ [ if isMonad

426− [conP _Type [varP _strm1], conP _Type [varP _strm2]]

429+ then apClauseMonad

427− (normalB

430+ else apClauseApplicative

428− (appE

429− (conE _Type)

430− (appE

431− (appE (varE _apDef) (varE _strm1))

432− (varE _strm2))))

433− []

434 ]

431 ]

435 ]

432 ]

436

433

@@ -439,6 +436,17 @@ mkStreamApplicative dtNameStr ctxM pureDefStr apDefStr =

439 _Type = mkName dtNameStr

436 _Type = mkName dtNameStr

440 _pureDef = mkName pureDefStr

437 _pureDef = mkName pureDefStr

441 _apDef = mkName apDefStr

438 _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+ []

442

450

443mkStreamMonad :: String -> [String] -> String -> Q Dec

451mkStreamMonad :: String -> [String] -> String -> Q Dec

444mkStreamMonad dtNameStr ctxM bindDefStr =

452mkStreamMonad dtNameStr ctxM bindDefStr =

@@ -505,13 +513,13 @@ flattenDec (ma:mas) = do

505-- GHC.Types.Char => IsString (ZipStream Identity a)

513-- GHC.Types.Char => IsString (ZipStream Identity a)

506-- deriving instance GHC.Classes.Eq a => Eq (ZipStream Identity a)

514-- deriving instance GHC.Classes.Eq a => Eq (ZipStream Identity a)

507-- deriving instance GHC.Classes.Ord a => Ord (ZipStream Identity a)

515-- deriving instance GHC.Classes.Ord a => Ord (ZipStream Identity a)

508−-- deriving instance Traversable (ZipStream Identity a)

516+-- deriving instance Traversable (ZipStream Identity)

509-- instance Show a => Show (ZipStream Identity a)

517-- instance Show a => Show (ZipStream Identity a)

510-- where {-# INLINE show #-}

518-- where {-# INLINE show #-}

511-- show (ZipStream strm) = show strm

519-- show (ZipStream strm) = show strm

512-- instance Read a => Read (ZipStream Identity a)

520-- instance Read a => Read (ZipStream Identity a)

513−-- where {-# INLINE read #-}

521+-- where {-# INLINE readPrec #-}

514−-- read = (.) ZipStream read

522+-- readPrec = fmap ZipStream readPrec

515-- instance Monad m => Functor (ZipStream m)

523-- instance Monad m => Functor (ZipStream m)

516-- where {-# INLINE fmap #-}

524-- where {-# INLINE fmap #-}

517-- fmap f (ZipStream strm) = ZipStream (fmap f strm)

525-- fmap f (ZipStream strm) = ZipStream (fmap f strm)

@@ -528,11 +536,11 @@ mkZipType

528mkZipType dtNameStr apOpStr isConcurrent =

536mkZipType dtNameStr apOpStr isConcurrent =

529 flattenDec

537 flattenDec

530 [ typeDec dtNameStr

538 [ typeDec dtNameStr

531− $ if (not isConcurrent)

539+ $ if not isConcurrent

532 then [_Semigroup, _Monoid, _Foldable]

540 then [_Semigroup, _Monoid, _Foldable]

533 else []

541 else []

534 , sequence

542 , sequence

535− $ if (not isConcurrent)

543+ $ if not isConcurrent

536 then [ derivIsListIdent _Type

544 then [ derivIsListIdent _Type

537 , derivIsStringIdent _Type

545 , derivIsStringIdent _Type

538 , derivEqIdent _Type

546 , derivEqIdent _Type

@@ -545,6 +553,7 @@ mkZipType dtNameStr apOpStr isConcurrent =

545 , sequence

553 , sequence

546 [ functorInstance _Type

554 [ functorInstance _Type

547 , mkStreamApplicative

555 , mkStreamApplicative

556+ False

548 dtNameStr

557 dtNameStr

549 classConstraints

558 classConstraints

550 "Stream.repeat"

559 "Stream.repeat"

@@ -580,23 +589,17 @@ mkZipType dtNameStr apOpStr isConcurrent =

580-- where {-# INLINE pure #-}

589-- where {-# INLINE pure #-}

581-- pure = Parallel . Stream.fromPure

590-- pure = Parallel . Stream.fromPure

582-- {-# INLINE (<*>) #-}

591-- {-# INLINE (<*>) #-}

583−-- (<*>) (Parallel strm1) (Parallel strm2) = Parallel (ap strm1 strm2)

592+-- (<*>) = ap

584−-- instance MonadTrans Parallel

585−-- where {-# INLINE lift #-}

586−-- lift = Parallel . lift

587-- instance (Monad (Parallel m), MonadIO m) => MonadIO (Parallel m)

593-- instance (Monad (Parallel m), MonadIO m) => MonadIO (Parallel m)

588-- where {-# INLINE liftIO #-}

594-- 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

590-- instance (Monad (Parallel m),

599-- instance (Monad (Parallel m),

591-- MonadThrow m) => MonadThrow (Parallel m)

600-- MonadThrow m) => MonadThrow (Parallel m)

592-- where {-# INLINE throwM #-}

601-- where {-# INLINE throwM #-}

593−-- throwM = Parallel . (lift . throwM)

602+-- throwM = 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)

600mkCrossType

603mkCrossType

601 :: String -- ^ Name of the type

604 :: String -- ^ Name of the type

602 -> String -- ^ Function to use for (>>=)

605 -> String -- ^ Function to use for (>>=)

@@ -605,11 +608,11 @@ mkCrossType

605mkCrossType dtNameStr bindOpStr isConcurrent =

608mkCrossType dtNameStr bindOpStr isConcurrent =

606 flattenDec

609 flattenDec

607 [ typeDec dtNameStr

610 [ typeDec dtNameStr

608− $ if (not isConcurrent)

611+ $ if not isConcurrent

609 then [_Semigroup, _Monoid, _Foldable]

612 then [_Semigroup, _Monoid, _Foldable]

610 else []

613 else []

611 , sequence

614 , sequence

612− $ if (not isConcurrent)

615+ $ if not isConcurrent

613 then [ derivIsListIdent _Type

616 then [ derivIsListIdent _Type

614 , derivIsStringIdent _Type

617 , derivIsStringIdent _Type

615 , derivEqIdent _Type

618 , derivEqIdent _Type

@@ -623,14 +626,15 @@ mkCrossType dtNameStr bindOpStr isConcurrent =

623 [ functorInstance _Type

626 [ functorInstance _Type

624 , mkStreamMonad dtNameStr classConstraints bindOpStr

627 , mkStreamMonad dtNameStr classConstraints bindOpStr

625 , mkStreamApplicative

628 , mkStreamApplicative

629+ True

626 dtNameStr

630 dtNameStr

627 classConstraints

631 classConstraints

628 "Stream.fromPure"

632 "Stream.fromPure"

629 "ap"

633 "ap"

630− , monadtransInstance _Type

631 , monadioInstance _Type

634 , monadioInstance _Type

635+ , monadtransInstance _Type

632 , monadthrowInstance _Type

636 , monadthrowInstance _Type

633− , monadreaderInstance _Type

637+ -- , monadreaderInstance _Type

634 ]

638 ]

635 ]

639 ]

636

640