3a7b982 · streamly · git.iko.soy

git.iko.soy/streamly

on master help sign in

Add necessary instances to MkType

3a7b982Adithya Kumar4 years ago

src/Streamly/Internal/Data/Stream/MkType.hs+312−164

compare with master

unifiedsplit

@@ -1,3 +1,6 @@

1+{-# LANGUAGE TemplateHaskell #-}

2+{-# LANGUAGE QuasiQuotes #-}

1-- |

4-- |

2-- Module : Streamly.Internal.Data.Stream.MkType

5-- Module : Streamly.Internal.Data.Stream.MkType

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

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

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

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

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

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

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

41+import Data.List (singleton)

38import Prelude hiding (repeat)

42import Prelude hiding (repeat)

40-- $setup

44-- $setup

@@ -138,12 +142,232 @@ _apOp = mkName "<*>"

138_bindOp :: Name

142_bindOp :: Name

139_bindOp = mkName ">>="

143_bindOp = mkName ">>="

140

144

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+

141--------------------------------------------------------------------------------

184--------------------------------------------------------------------------------

142−-- TH helpers

185+-- Simple derivations

143--------------------------------------------------------------------------------

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

144

187

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+

145−makeTypeDec :: String -> Q [Dec]

369+typeDec :: String -> [Name] -> Q [Dec]

146−makeTypeDec dtNameStr = do

370+typeDec dtNameStr toDerive = do

147 typ <-

371 typ <-

148 newtypeD

372 newtypeD

149 (return [])

373 (return [])

@@ -156,7 +380,7 @@ makeTypeDec dtNameStr = do

156 (bang noSourceUnpackedness noSourceStrictness)

380 (bang noSourceUnpackedness noSourceStrictness)

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

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

158 ])

382 ])

159− []

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

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

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

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

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

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

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

@@ -174,27 +398,9 @@ makeTypeDec dtNameStr = do

174 _toType = mkName (toTypeStr dtNameStr)

398 _toType = mkName (toTypeStr dtNameStr)

175 _unType = mkName (unTypeStr dtNameStr)

399 _unType = mkName (unTypeStr dtNameStr)

176

400

177−makeStreamFunctor :: String -> Q Dec

401+--------------------------------------------------------------------------------

178−makeStreamFunctor dtNameStr = do

402+-- Main deivations

179− instanceD

403+--------------------------------------------------------------------------------

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

198

404

199mkStreamApplicative :: String -> [String] -> String -> String -> Q Dec

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

200mkStreamApplicative dtNameStr ctxM pureDefStr apDefStr =

406mkStreamApplicative dtNameStr ctxM pureDefStr apDefStr =

@@ -272,118 +478,40 @@ mkStreamMonad dtNameStr ctxM bindDefStr =

272 _unType = mkName (unTypeStr dtNameStr)

478 _unType = mkName (unTypeStr dtNameStr)

273 _bindDef = mkName bindDefStr

479 _bindDef = mkName bindDefStr

274

480

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−

374--------------------------------------------------------------------------------

481--------------------------------------------------------------------------------

375-- Functions

482-- Functions

376--------------------------------------------------------------------------------

483--------------------------------------------------------------------------------

377

484

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+

378-- | Create a type with a zip-like applicative.

492-- | Create a type with a zip-like applicative.

379--

493--

380-- >>> expr <- runQ (mkZipType "ZipStream" "zipApply" False)

494-- >>> expr <- runQ (mkZipType "ZipStream" "zipApply" False)

381-- >>> putStrLn $ pprint expr

495-- >>> putStrLn $ pprint expr

496+-- newtype ZipStream m a

382−-- newtype ZipStream m a = ZipStream (Stream.Stream m a)

497+-- = ZipStream (Stream.Stream m a)

498+-- deriving (Semigroup, Monoid, Foldable)

383-- mkZipStream :: Stream.Stream m a -> ZipStream m a

499-- mkZipStream :: Stream.Stream m a -> ZipStream m a

384-- mkZipStream = ZipStream

500-- mkZipStream = ZipStream

385-- unZipStream :: ZipStream m a -> Stream.Stream m a

501-- unZipStream :: ZipStream m a -> Stream.Stream m a

386-- unZipStream (ZipStream strm) = strm

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

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

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

388-- where {-# INLINE fmap #-}

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

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

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

@@ -392,41 +520,41 @@ mkSimpleStreamInstances dtNameStr = do

392-- pure = ZipStream . Stream.repeat

520-- pure = ZipStream . Stream.repeat

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

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

394-- (<*>) (ZipStream strm1) (ZipStream strm2) = ZipStream (zipApply strm1 strm2)

522-- (<*>) (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)

411mkZipType

523mkZipType

412 :: String -- ^ Name of the type

524 :: String -- ^ Name of the type

413 -> String -- ^ Function to use for (\<*\>)

525 -> String -- ^ Function to use for (\<*\>)

414 -> Bool -- ^ 'True' if (\<*\>) requires MonadAsync constraint (concurrent)

526 -> Bool -- ^ 'True' if (\<*\>) requires MonadAsync constraint (concurrent)

415 -> Q [Dec]

527 -> Q [Dec]

416−mkZipType dtNameStr apOpStr isConcurrent = do

528+mkZipType dtNameStr apOpStr isConcurrent =

417− typeDec <- makeTypeDec dtNameStr

529+ flattenDec

418− functorI <- makeStreamFunctor dtNameStr

530+ [ typeDec dtNameStr

419− applicativeI <-

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

420− mkStreamApplicative

547+ , mkStreamApplicative

421− dtNameStr

548+ dtNameStr

422− classConstraints

549+ classConstraints

423− "Stream.repeat"

550+ "Stream.repeat"

424− apOpStr

551+ apOpStr

425− simpleInstances <- mkSimpleStreamInstances dtNameStr

552+ ]

426− return $ typeDec ++ [functorI, applicativeI] ++ simpleInstances

553+ ]

427

554

428 where

555 where

429

556

557+ _Type = mkName dtNameStr

430 classConstraints =

558 classConstraints =

431 if isConcurrent

559 if isConcurrent

432 then ["Stream.MonadAsync"]

560 then ["Stream.MonadAsync"]

@@ -474,21 +602,41 @@ mkCrossType

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

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

475 -> Bool -- ^ 'True' if (>>=) requires MonadAsync constraint (concurrent)

603 -> Bool -- ^ 'True' if (>>=) requires MonadAsync constraint (concurrent)

476 -> Q [Dec]

604 -> Q [Dec]

477−mkCrossType dtNameStr bindOpStr isConcurrent = do

605+mkCrossType dtNameStr bindOpStr isConcurrent =

478− typeDec <- makeTypeDec dtNameStr

606+ flattenDec

479− functorI <- makeStreamFunctor dtNameStr

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

480− monadI <- mkStreamMonad dtNameStr classConstraints bindOpStr

624+ , mkStreamMonad dtNameStr classConstraints bindOpStr

481− applicativeI <-

482− mkStreamApplicative

625+ , mkStreamApplicative

483− dtNameStr

626+ dtNameStr

484− classConstraints

627+ classConstraints

485− "Stream.fromPure"

628+ "Stream.fromPure"

486− "ap"

629+ "ap"

487− simpleInstances <- mkSimpleStreamInstances dtNameStr

630+ , monadtransInstance _Type

488− return $ typeDec ++ [functorI, monadI, applicativeI] ++ simpleInstances

631+ , monadioInstance _Type

632+ , monadthrowInstance _Type

633+ , monadreaderInstance _Type

634+ ]

635+ ]

489

636

490 where

637 where

491

638

639+ _Type = mkName dtNameStr

492 classConstraints =

640 classConstraints =

493 if isConcurrent

641 if isConcurrent

494 then ["Stream.MonadAsync"]

642 then ["Stream.MonadAsync"]