{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
module Knit.Effect.Docs
(
Docs
, newDoc
, toDocList
, toDocListWith
, toDocListWithM
, DocWithInfo(..)
, mapDocs
, mapDocsM
)
where
import qualified Polysemy as P
import Polysemy.Internal ( send )
import qualified Polysemy.Writer as P
import Control.Monad (sequence, join)
data Docs i a m r where
NewDoc :: i -> a -> Docs i a m ()
newDoc :: P.Member (Docs i a) effs => i -> a -> P.Sem effs ()
newDoc info doc = send $ NewDoc info doc
data DocWithInfo i a = DocWithInfo { dwiInfo :: i, dwiDoc :: a }
deriving instance Functor (DocWithInfo i)
deriving instance Foldable (DocWithInfo i)
deriving instance Traversable (DocWithInfo i)
toWriter
:: P.Sem (Docs i a ': effs) () -> P.Sem (P.Writer [DocWithInfo i a] ': effs) ()
toWriter = P.reinterpret f
where
f :: Docs i a m x -> P.Sem (P.Writer [DocWithInfo i a] ': effs) x
f (NewDoc i d) = P.tell [DocWithInfo i d]
toDocList :: P.Sem (Docs i a ': effs) () -> P.Sem effs [DocWithInfo i a]
toDocList = fmap fst . P.runWriter . toWriter
mapDocs :: Monad m => (i -> a -> b) -> m [DocWithInfo i a] -> m [DocWithInfo i b]
mapDocs f = fmap (fmap (\(DocWithInfo i a) -> DocWithInfo i (f i a)))
mapDocsM :: Monad m => (i -> a -> m b) -> m [DocWithInfo i a] -> m [DocWithInfo i b]
mapDocsM f = join . fmap (sequence . fmap (traverse id)) . mapDocs f
toDocListWith
:: (i -> a -> b) -> P.Sem (Docs i a ': effs) () -> P.Sem effs [DocWithInfo i b]
toDocListWith f = mapDocs f . toDocList
toDocListWithM
:: (i -> a -> P.Sem effs b) -> P.Sem (Docs i a ': effs) () -> P.Sem effs [DocWithInfo i b]
toDocListWithM f = mapDocsM f . toDocList