{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

{-|
Description : Generic implementation of the Has pattern
Stability   : experimental

This module defines a class 'Has' intended to be used with the 'MonadReader' class
or 'Reader' / 'ReaderT' types.

= The problem

Assume there are two types representing the 'MonadReader' environments
for different parts of an application:

@
data DbConfig = DbConfig { .. }
data WebConfig = WebConfig { .. }
@

as well as a single type containing both of those:

@
data AppEnv = AppEnv
  { dbConfig :: DbConfig
  , webConfig :: WebConfig
  }
@

What should be the @MonadReader@ constraint of the DB module and web module respectively?

1. It could be @MonadReader AppEnv m@ for both, introducing unnecessary coupling.

2. Or it could be @MonadReader DbConfig m@ for the DB module and
   @MonadReader WebConfig m@ for the web module respectively, but combining them becomes a pain.

Or, it could be @MonadReader r m, Has DbConfig r@ for the DB module (and similarly for the web module),
where some appropriately defined @Has part record@ class allows projecting @part@ out of some @record@.
This approach keeps both modules decoupled, while allowing using them in the same monad stack.

The only downside is that now one has to define the @Has@ class and write tediuos instances for the @AppEnv@ type
(and potentially other types in case of, for example, tests).

But why bother doing the work that the machine will happily do for you?

= The solution

This module defines the generic 'Has' class as well as hides all the boilerplate behind "GHC.Generics",
so all you have to do is to add the corresponding @deriving@-clause:

@
data AppEnv = AppEnv
  { dbConfig :: DbConfig
  , webConfig :: WebConfig
  } deriving (Generic, Has DbConfig, Has WebConfig)
@

and use @ask extract@ instead of @ask@ (but this is something you'd have to do anyway).

= Type safety

What should happen if @record@ does not have any field of type @part@ at all?
Of course, this means that we cannot project @part@ out of @record@, and no 'Has' instance can be derived at all.
Indeed, this library will refuse to generate an instance in this case.

On the other hand, what should happen if @record@ contains multiple values of type @part@,
perhaps on different levels of nesting? While technically we could make an arbitrary choice, like taking
the first one in breadth-first or depth-first order, we instead decide that such a choice is inherently ambiguous,
so this library will refuse to generate an instance in this case as well.

= Updating the records, or poor man's lenses, and State

One we know that a value of type @part@ is contained in @record@,
we might easily update a @record@ having a function that updates the @part@.
This is done in the obvious way: we just locate the @part@ in the @record@ and 'update' it!

'Has' has a method for this, called (unsurprisingly) 'update'.

Note that this might be used for more composable functions living in 'Control.Monad.State':
now instead of @MonadState StateType m@ we write @(MonadState s m, Has StateType s)@
and use 'update' and 'extract' where necessary
(likely in combination with 'Control.Monad.State.modify' and 'Control.Monad.State.gets').

= Exports

This module also reexports 'Control.Monad.Reader' along with some functions like 'ask' or 'reader'
with types adjusted for the intended usage of the 'Has' class.

-}

module Control.Monad.Reader.Has
( Has(..)
, SuccessfulSearch

, module X
, ask
, asks
, reader
) where

import qualified Control.Monad.Reader as M
import Control.Monad.Reader as X hiding(ask, asks, reader)
import Data.Kind
import Data.Proxy
import GHC.Generics

import Data.Path

type family Search part (g :: k -> Type) :: MaybePath where
  Search part (K1 _ part) = 'Found 'Here
  Search part (K1 _ other) = 'NotFound
  Search part (M1 _ _ x) = Search part x
  Search part (f :*: g) = Combine (Search part f) (Search part g)
  Search _ _ = 'NotFound

class GHas (path :: Path) part grecord where
  gextract :: Proxy path -> grecord p -> part
  gupdate :: Proxy path -> (part -> part) -> grecord p -> grecord p

instance GHas 'Here rec (K1 i rec) where
  gextract :: forall (p :: k). Proxy 'Here -> K1 i rec p -> rec
gextract Proxy 'Here
_ (K1 rec
x) = rec
x
  gupdate :: forall (p :: k).
Proxy 'Here -> (rec -> rec) -> K1 i rec p -> K1 i rec p
gupdate Proxy 'Here
_ rec -> rec
f (K1 rec
x) = forall k i c (p :: k). c -> K1 i c p
K1 forall a b. (a -> b) -> a -> b
$ rec -> rec
f rec
x

instance GHas path part record => GHas path part (M1 i t record) where
  gextract :: forall (p :: k). Proxy path -> M1 i t record p -> part
gextract Proxy path
proxy (M1 record p
x) = forall {k} (path :: Path) part (grecord :: k -> *) (p :: k).
GHas path part grecord =>
Proxy path -> grecord p -> part
gextract Proxy path
proxy record p
x
  gupdate :: forall (p :: k).
Proxy path -> (part -> part) -> M1 i t record p -> M1 i t record p
gupdate Proxy path
proxy part -> part
f (M1 record p
x) = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (forall {k} (path :: Path) part (grecord :: k -> *) (p :: k).
GHas path part grecord =>
Proxy path -> (part -> part) -> grecord p -> grecord p
gupdate Proxy path
proxy part -> part
f record p
x)

instance GHas path part l => GHas ('L path) part (l :*: r) where
  gextract :: forall (p :: k). Proxy ('L path) -> (:*:) l r p -> part
gextract Proxy ('L path)
_ (l p
l :*: r p
_) = forall {k} (path :: Path) part (grecord :: k -> *) (p :: k).
GHas path part grecord =>
Proxy path -> grecord p -> part
gextract (forall {k} (t :: k). Proxy t
Proxy :: Proxy path) l p
l
  gupdate :: forall (p :: k).
Proxy ('L path) -> (part -> part) -> (:*:) l r p -> (:*:) l r p
gupdate Proxy ('L path)
_ part -> part
f (l p
l :*: r p
r) = forall {k} (path :: Path) part (grecord :: k -> *) (p :: k).
GHas path part grecord =>
Proxy path -> (part -> part) -> grecord p -> grecord p
gupdate (forall {k} (t :: k). Proxy t
Proxy :: Proxy path) part -> part
f l p
l forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: r p
r

instance GHas path part r => GHas ('R path) part (l :*: r) where
  gextract :: forall (p :: k). Proxy ('R path) -> (:*:) l r p -> part
gextract Proxy ('R path)
_ (l p
_ :*: r p
r) = forall {k} (path :: Path) part (grecord :: k -> *) (p :: k).
GHas path part grecord =>
Proxy path -> grecord p -> part
gextract (forall {k} (t :: k). Proxy t
Proxy :: Proxy path) r p
r
  gupdate :: forall (p :: k).
Proxy ('R path) -> (part -> part) -> (:*:) l r p -> (:*:) l r p
gupdate Proxy ('R path)
_ part -> part
f (l p
l :*: r p
r) = l p
l forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: forall {k} (path :: Path) part (grecord :: k -> *) (p :: k).
GHas path part grecord =>
Proxy path -> (part -> part) -> grecord p -> grecord p
gupdate (forall {k} (t :: k). Proxy t
Proxy :: Proxy path) part -> part
f r p
r

-- | Type alias representing that the search of @part@ in @record@ has been successful.
--
-- The @path@ is used to guide the default generic implementation of 'Has'.
type SuccessfulSearch part record path = (Search part (Rep record) ~ 'Found path, GHas path part (Rep record))

-- | The @Has part record@ class is used for records of type @record@ supporting
-- projecting out a value of type @part@.
class Has part record where
  -- | Extract a subvalue of type @part@ from the @record@.
  --
  -- The default implementation searches for some value of the type @part@ in @record@
  -- and returns that value.
  -- The default implementation typechecks iff there is a single subvalue of type @part@ in @record@.
  extract :: record -> part

  default extract :: forall path. (Generic record, SuccessfulSearch part record path) => record -> part
  extract = forall {k} (path :: Path) part (grecord :: k -> *) (p :: k).
GHas path part grecord =>
Proxy path -> grecord p -> part
gextract (forall {k} (t :: k). Proxy t
Proxy :: Proxy path) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from

  -- | Update the @record@ given an update function for the @part@.
  --
  -- The default implementation searches for some value of the type @part@ in @record@
  -- and updates that value using the supplied function.
  -- The default implementation typechecks iff there is a single subvalue of type @part@ in @record@.
  update :: (part -> part) -> record -> record

  default update :: forall path. (Generic record, SuccessfulSearch part record path) => (part -> part) -> record -> record
  update part -> part
f = forall a x. Generic a => Rep a x -> a
to forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (path :: Path) part (grecord :: k -> *) (p :: k).
GHas path part grecord =>
Proxy path -> (part -> part) -> grecord p -> grecord p
gupdate (forall {k} (t :: k). Proxy t
Proxy :: Proxy path) part -> part
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from

-- | Each type allows projecting itself (and that is an 'id' projection).
instance Has record record where
  extract :: record -> record
extract = forall record. record -> record
id
  update :: (record -> record) -> record -> record
update = forall record. record -> record
id

instance SuccessfulSearch a (a0, a1) path => Has a (a0, a1)
instance SuccessfulSearch a (a0, a1, a2) path => Has a (a0, a1, a2)
instance SuccessfulSearch a (a0, a1, a2, a3) path => Has a (a0, a1, a2, a3)
instance SuccessfulSearch a (a0, a1, a2, a3, a4) path => Has a (a0, a1, a2, a3, a4)
instance SuccessfulSearch a (a0, a1, a2, a3, a4, a5) path => Has a (a0, a1, a2, a3, a4, a5)

-- | Retrieves the @part@ of the monad environment.
--
-- This is "Control.Monad.Reader"'s 'Control.Monad.Reader.ask'
-- with the type adjusted for better compatibility with 'Has'.
ask :: (MonadReader record m, Has part record) => m part
ask :: forall record (m :: * -> *) part.
(MonadReader record m, Has part record) =>
m part
ask = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
M.asks forall part record. Has part record => record -> part
extract

-- | Retrieves a function of the @part@ of the current environment.
--
-- This is "Control.Monad.Reader"'s 'Control.Monad.Reader.asks'
-- with the type adjusted for better compatibility with 'Has'.
asks :: (MonadReader record m, Has part record) => (part -> a) -> m a
asks :: forall record (m :: * -> *) part a.
(MonadReader record m, Has part record) =>
(part -> a) -> m a
asks part -> a
f = part -> a
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall record (m :: * -> *) part.
(MonadReader record m, Has part record) =>
m part
ask

-- | Retrieves a function of the @part@ of the current environment.
--
-- This is "Control.Monad.Reader"'s 'Control.Monad.Reader.reader'
-- with the type adjusted for better compatibility with 'Has'.
reader :: (MonadReader record m, Has part record) => (part -> a) -> m a
reader :: forall record (m :: * -> *) part a.
(MonadReader record m, Has part record) =>
(part -> a) -> m a
reader = forall record (m :: * -> *) part a.
(MonadReader record m, Has part record) =>
(part -> a) -> m a
asks