{-# 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
Description : Polysemy effect for creating a list of named documents
Copyright   : (c) Adam Conner-Sax 2019
License     : BSD-3-Clause
Maintainer  : adam_conner_sax@yahoo.com
Stability   : experimental

<https://github.com/isovector/polysemy#readme Polysemy> effect used by knit-haskell when one code-base is used to create multiple docs.
Each can be created and then stored in the
list maintained by this effect.  Then, when the effects are "run", this list can be processed to produce the required
output.
-}
module Knit.Effect.Docs
  (
    -- * Effect
    Docs

    -- * Actions
  , newDoc

    -- * Interpretations
  , toDocList
  , toDocListWith
  , toDocListWithM

    -- * Helper Types
  , DocWithInfo(..)

    -- * Helper Functions
  , mapDocs
  , mapDocsM
  )
where

import qualified Polysemy                      as P
import           Polysemy.Internal              ( send )
import qualified Polysemy.Writer               as P

import           Control.Monad                  ( join )

-- | GADT to represent storing a document and some info for processing it.
data Docs i a m r where
  NewDoc ::i -> a -> Docs i a m ()

-- | Action of the 'Docs' Effect.  Store a document.
newDoc :: P.Member (Docs i a) effs => i -> a -> P.Sem effs ()
newDoc :: i -> a -> Sem effs ()
newDoc info :: i
info doc :: a
doc = Docs i a (Sem effs) () -> Sem effs ()
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Member e r =>
e (Sem r) a -> Sem r a
send (Docs i a (Sem effs) () -> Sem effs ())
-> Docs i a (Sem effs) () -> Sem effs ()
forall a b. (a -> b) -> a -> b
$ i -> a -> Docs i a (Sem effs) ()
forall k i a (m :: k). i -> a -> Docs i a m ()
NewDoc i
info a
doc

-- | Data type to hold one document with info of type @i@ and doc of type @a@. 
data DocWithInfo i a = DocWithInfo { DocWithInfo i a -> i
dwiInfo :: i, DocWithInfo i a -> a
dwiDoc :: a }
deriving instance Functor (DocWithInfo i)
deriving instance Foldable (DocWithInfo i)
deriving instance Traversable (DocWithInfo i)

-- | Intepret 'Docs' in @Polysemy.Writer [DocWithInfo i a]'
toWriter
  :: P.Sem (Docs i a ': effs) ()
  -> P.Sem (P.Writer [DocWithInfo i a] ': effs) ()
toWriter :: Sem (Docs i a : effs) ()
-> Sem (Writer [DocWithInfo i a] : effs) ()
toWriter = (forall (m :: * -> *) x.
 Docs i a m x -> Sem (Writer [DocWithInfo i a] : effs) x)
-> Sem (Docs i a : effs) ()
-> Sem (Writer [DocWithInfo i a] : effs) ()
forall (e1 :: (* -> *) -> * -> *) (e2 :: (* -> *) -> * -> *)
       (r :: [(* -> *) -> * -> *]) a.
FirstOrder e1 "reinterpret" =>
(forall (m :: * -> *) x. e1 m x -> Sem (e2 : r) x)
-> Sem (e1 : r) a -> Sem (e2 : r) a
P.reinterpret forall k i a (m :: k) x (effs :: [(* -> *) -> * -> *]).
Docs i a m x -> Sem (Writer [DocWithInfo i a] : effs) x
forall (m :: * -> *) x.
Docs i a m x -> Sem (Writer [DocWithInfo i a] : effs) x
f
 where
  f :: Docs i a m x -> P.Sem (P.Writer [DocWithInfo i a] ': effs) x
  f :: Docs i a m x -> Sem (Writer [DocWithInfo i a] : effs) x
f (NewDoc i :: i
i d :: a
d) = [DocWithInfo i a] -> Sem (Writer [DocWithInfo i a] : effs) ()
forall o (r :: [(* -> *) -> * -> *]).
MemberWithError (Writer o) r =>
o -> Sem r ()
P.tell [i -> a -> DocWithInfo i a
forall i a. i -> a -> DocWithInfo i a
DocWithInfo i
i a
d]

-- | Interpret 'Docs' (via 'Polysemy.Writer'), producing a list of @DocWithInfo i a@
toDocList :: P.Sem (Docs i a ': effs) () -> P.Sem effs [DocWithInfo i a]
toDocList :: Sem (Docs i a : effs) () -> Sem effs [DocWithInfo i a]
toDocList = (([DocWithInfo i a], ()) -> [DocWithInfo i a])
-> Sem effs ([DocWithInfo i a], ()) -> Sem effs [DocWithInfo i a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([DocWithInfo i a], ()) -> [DocWithInfo i a]
forall a b. (a, b) -> a
fst (Sem effs ([DocWithInfo i a], ()) -> Sem effs [DocWithInfo i a])
-> (Sem (Docs i a : effs) () -> Sem effs ([DocWithInfo i a], ()))
-> Sem (Docs i a : effs) ()
-> Sem effs [DocWithInfo i a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Writer [DocWithInfo i a] : effs) ()
-> Sem effs ([DocWithInfo i a], ())
forall o (r :: [(* -> *) -> * -> *]) a.
Monoid o =>
Sem (Writer o : r) a -> Sem r (o, a)
P.runWriter (Sem (Writer [DocWithInfo i a] : effs) ()
 -> Sem effs ([DocWithInfo i a], ()))
-> (Sem (Docs i a : effs) ()
    -> Sem (Writer [DocWithInfo i a] : effs) ())
-> Sem (Docs i a : effs) ()
-> Sem effs ([DocWithInfo i a], ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Docs i a : effs) ()
-> Sem (Writer [DocWithInfo i a] : effs) ()
forall i a (effs :: [(* -> *) -> * -> *]).
Sem (Docs i a : effs) ()
-> Sem (Writer [DocWithInfo i a] : effs) ()
toWriter

-- | Map over the doc part of @Functor m => m [DocWithInfo i a]@ with an @a->b@ resulting in @m [DocWithInfo i b]@
mapDocs
  :: Monad m => (i -> a -> b) -> m [DocWithInfo i a] -> m [DocWithInfo i b]
mapDocs :: (i -> a -> b) -> m [DocWithInfo i a] -> m [DocWithInfo i b]
mapDocs f :: i -> a -> b
f = ([DocWithInfo i a] -> [DocWithInfo i b])
-> m [DocWithInfo i a] -> m [DocWithInfo i b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((DocWithInfo i a -> DocWithInfo i b)
-> [DocWithInfo i a] -> [DocWithInfo i b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(DocWithInfo i :: i
i a :: a
a) -> i -> b -> DocWithInfo i b
forall i a. i -> a -> DocWithInfo i a
DocWithInfo i
i (i -> a -> b
f i
i a
a)))

-- | Map over the doc part of @Monad m => m [DocWithInfo i a]@ with @a -> m b@ resulting in @m [DocWithInfo i b]@
mapDocsM
  :: Monad m => (i -> a -> m b) -> m [DocWithInfo i a] -> m [DocWithInfo i b]
mapDocsM :: (i -> a -> m b) -> m [DocWithInfo i a] -> m [DocWithInfo i b]
mapDocsM f :: i -> a -> m b
f = m (m [DocWithInfo i b]) -> m [DocWithInfo i b]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m [DocWithInfo i b]) -> m [DocWithInfo i b])
-> (m [DocWithInfo i a] -> m (m [DocWithInfo i b]))
-> m [DocWithInfo i a]
-> m [DocWithInfo i b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([DocWithInfo i (m b)] -> m [DocWithInfo i b])
-> m [DocWithInfo i (m b)] -> m (m [DocWithInfo i b])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([m (DocWithInfo i b)] -> m [DocWithInfo i b]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([m (DocWithInfo i b)] -> m [DocWithInfo i b])
-> ([DocWithInfo i (m b)] -> [m (DocWithInfo i b)])
-> [DocWithInfo i (m b)]
-> m [DocWithInfo i b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DocWithInfo i (m b) -> m (DocWithInfo i b))
-> [DocWithInfo i (m b)] -> [m (DocWithInfo i b)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((m b -> m b) -> DocWithInfo i (m b) -> m (DocWithInfo i b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse m b -> m b
forall a. a -> a
id)) (m [DocWithInfo i (m b)] -> m (m [DocWithInfo i b]))
-> (m [DocWithInfo i a] -> m [DocWithInfo i (m b)])
-> m [DocWithInfo i a]
-> m (m [DocWithInfo i b])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (i -> a -> m b) -> m [DocWithInfo i a] -> m [DocWithInfo i (m b)]
forall (m :: * -> *) i a b.
Monad m =>
(i -> a -> b) -> m [DocWithInfo i a] -> m [DocWithInfo i b]
mapDocs i -> a -> m b
f --(traverse (traverse f) =<<)

-- | Combine the interpretation and mapping step.
-- Commonly used to "run" the effect and map the results to your desired output format.
toDocListWith
  :: (i -> a -> b)
  -> P.Sem (Docs i a ': effs) ()
  -> P.Sem effs [DocWithInfo i b]
toDocListWith :: (i -> a -> b)
-> Sem (Docs i a : effs) () -> Sem effs [DocWithInfo i b]
toDocListWith f :: i -> a -> b
f = (i -> a -> b)
-> Sem effs [DocWithInfo i a] -> Sem effs [DocWithInfo i b]
forall (m :: * -> *) i a b.
Monad m =>
(i -> a -> b) -> m [DocWithInfo i a] -> m [DocWithInfo i b]
mapDocs i -> a -> b
f (Sem effs [DocWithInfo i a] -> Sem effs [DocWithInfo i b])
-> (Sem (Docs i a : effs) () -> Sem effs [DocWithInfo i a])
-> Sem (Docs i a : effs) ()
-> Sem effs [DocWithInfo i b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Docs i a : effs) () -> Sem effs [DocWithInfo i a]
forall i a (effs :: [(* -> *) -> * -> *]).
Sem (Docs i a : effs) () -> Sem effs [DocWithInfo i a]
toDocList

-- | Combine the interpretation and effectful mapping step.
-- Commonly used to "run" the effect and map the results to your deisred output format.
toDocListWithM
  :: (i -> a -> P.Sem effs b)
  -> P.Sem (Docs i a ': effs) ()
  -> P.Sem effs [DocWithInfo i b]
toDocListWithM :: (i -> a -> Sem effs b)
-> Sem (Docs i a : effs) () -> Sem effs [DocWithInfo i b]
toDocListWithM f :: i -> a -> Sem effs b
f = (i -> a -> Sem effs b)
-> Sem effs [DocWithInfo i a] -> Sem effs [DocWithInfo i b]
forall (m :: * -> *) i a b.
Monad m =>
(i -> a -> m b) -> m [DocWithInfo i a] -> m [DocWithInfo i b]
mapDocsM i -> a -> Sem effs b
f (Sem effs [DocWithInfo i a] -> Sem effs [DocWithInfo i b])
-> (Sem (Docs i a : effs) () -> Sem effs [DocWithInfo i a])
-> Sem (Docs i a : effs) ()
-> Sem effs [DocWithInfo i b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Docs i a : effs) () -> Sem effs [DocWithInfo i a]
forall i a (effs :: [(* -> *) -> * -> *]).
Sem (Docs i a : effs) () -> Sem effs [DocWithInfo i a]
toDocList