{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTSyntax #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE BlockArguments #-}

-- |
--    This module provides the 'Advice' datatype, along for functions for creating,
--    manipulating, composing and applying values of that type.
--
--    'Advice's are type-preserving transformations on 'ReaderT'-effectful functions of
--    any number of arguments.
--
-- >>> :{
--    foo0 :: ReaderT () IO (Sum Int)
--    foo0 = pure (Sum 5)
--    foo1 :: Bool -> ReaderT () IO (Sum Int)
--    foo1 _ = foo0
--    foo2 :: Char -> Bool -> ReaderT () IO (Sum Int)
--    foo2 _ = foo1
-- :}
--
-- They work for @ReaderT@-actions of zero arguments:
--
-- >>> advise (printArgs stdout "foo0") foo0 `runReaderT` ()
-- foo0:
-- <BLANKLINE>
-- Sum {getSum = 5}
--
-- And for functions of one or more arguments, provided they end on a @ReaderT@-action:
--
-- >>> advise (printArgs stdout "foo1") foo1 False `runReaderT` ()
-- foo1: False
-- <BLANKLINE>
-- Sum {getSum = 5}
--
-- >>> advise (printArgs stdout "foo2") foo2 'd' False `runReaderT` ()
-- foo2: 'd' False
-- <BLANKLINE>
-- Sum {getSum = 5}
--
-- 'Advice's can also tweak the result value of functions:
--
-- >>> advise (returnMempty @Top) foo2 'd' False `runReaderT` ()
-- Sum {getSum = 0}
--
-- And they can be combined using @Advice@'s 'Monoid' instance before being
-- applied:
--
-- >>> advise (printArgs stdout "foo2" <> returnMempty) foo2 'd' False `runReaderT` ()
-- foo2: 'd' False
-- <BLANKLINE>
-- Sum {getSum = 0}
--
-- Although sometimes composition might require harmonizing the constraints
-- each 'Advice' places on the arguments, if they differ.
module Dep.ReaderAdvice
  ( -- * The Advice type
    Advice,

    -- * Creating Advice values
    makeAdvice,
    makeArgsAdvice,
    makeExecutionAdvice,

    -- * Applying Advices
    advise,

    -- * Harmonizing Advice argument constraints
    -- $restrict
    restrictArgs,

    -- * Advising and deceiving entire records
    -- $records
    adviseRecord,

    -- * "sop-core" re-exports
    -- $sop
    Top,
    And,
    All,
    NP (..),
    I (..),
    cfoldMap_NP,
    Dict (..)
  )
where

import Dep.Has
import Dep.Env
import Control.Monad.Trans.Reader (ReaderT (..), withReaderT)
import Data.Functor.Identity
import Data.Kind
import Data.List.NonEmpty qualified as N
import Data.List.NonEmpty (NonEmpty)
import Data.SOP
import Data.SOP.Dict
import Data.SOP.NP
import Data.Typeable
import GHC.Generics qualified as G
import GHC.TypeLits
import Data.Coerce
import Data.Bifunctor (first)

-- $setup
--
-- >>> :set -XTypeApplications
-- >>> :set -XStandaloneKindSignatures
-- >>> :set -XMultiParamTypeClasses
-- >>> :set -XFunctionalDependencies
-- >>> :set -XRankNTypes
-- >>> :set -XTypeOperators
-- >>> :set -XConstraintKinds
-- >>> :set -XNamedFieldPuns
-- >>> :set -XFlexibleContexts
-- >>> :set -XDerivingStrategies
-- >>> :set -XGeneralizedNewtypeDeriving
-- >>> :set -XDataKinds
-- >>> :set -XScopedTypeVariables
-- >>> :set -XDeriveGeneric
-- >>> :set -XImportQualifiedPost
-- >>> import Dep.ReaderAdvice
-- >>> import Dep.ReaderAdvice.Basic (printArgs,returnMempty)
-- >>> import Control.Monad
-- >>> import Control.Monad.Reader
-- >>> import Control.Monad.Writer
-- >>> import Data.Kind
-- >>> import Data.SOP
-- >>> import Data.SOP.NP
-- >>> import Data.Monoid
-- >>> import System.IO
-- >>> import Data.IORef
-- >>> import Data.Function ((&))
-- >>> import GHC.Generics (Generic)
-- >>> import GHC.Generics qualified


-- | A generic transformation of 'ReaderT'-effectful functions with environment
-- @e@, base monad @m@ and return type @r@,
-- provided the functions satisfy certain constraint @ca@
-- on all of their arguments.
--
-- 'Advice's that don't care about the @ca@ constraint (because they don't
-- touch function arguments) can leave it polymorphic, and this facilitates
-- 'Advice' composition, but then the constraint must be given the catch-all
-- `Top` value (using a type application) at the moment of calling 'advise'.
--
-- See "Dep.ReaderAdvice.Basic" for examples.
type Advice ::
  (Type -> Constraint) ->
  Type ->
  (Type -> Type) ->
  Type ->
  Type
data Advice (ca :: Type -> Constraint) e m r where
  Advice ::
    forall ca e m r.
    ( forall as.
      All ca as =>
      NP I as ->
      ReaderT e m (ReaderT e m r -> ReaderT e m r, NP I as)
    ) ->
    Advice ca e m r

-- |
--    'Advice's compose \"sequentially\" when tweaking the arguments, and
--    \"concentrically\" when tweaking the final 'ReaderT' action.
--
--    The first 'Advice' is the \"outer\" one. It tweaks the function arguments
--    first, and wraps around the execution of the second, \"inner\" 'Advice'.
instance Monad m => Semigroup (Advice ca e m r) where
  Advice forall (as :: [*]).
All ca as =>
NP I as -> ReaderT e m (ReaderT e m r -> ReaderT e m r, NP I as)
outer <> :: Advice ca e m r -> Advice ca e m r -> Advice ca e m r
<> Advice forall (as :: [*]).
All ca as =>
NP I as -> ReaderT e m (ReaderT e m r -> ReaderT e m r, NP I as)
inner = forall (ca :: * -> Constraint) e (m :: * -> *) r.
(forall (as :: [*]).
 All ca as =>
 NP I as -> ReaderT e m (ReaderT e m r -> ReaderT e m r, NP I as))
-> Advice ca e m r
Advice \NP I as
args -> do
    (ReaderT e m r -> ReaderT e m r
tweakOuter, NP I as
argsOuter) <- forall (as :: [*]).
All ca as =>
NP I as -> ReaderT e m (ReaderT e m r -> ReaderT e m r, NP I as)
outer NP I as
args
    (ReaderT e m r -> ReaderT e m r
tweakInner, NP I as
argsInner) <- forall (as :: [*]).
All ca as =>
NP I as -> ReaderT e m (ReaderT e m r -> ReaderT e m r, NP I as)
inner NP I as
argsOuter
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReaderT e m r -> ReaderT e m r
tweakOuter forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT e m r -> ReaderT e m r
tweakInner, NP I as
argsInner)

instance Monad m => Monoid (Advice ca e m r) where
  mappend :: Advice ca e m r -> Advice ca e m r -> Advice ca e m r
mappend = forall a. Semigroup a => a -> a -> a
(<>)
  mempty :: Advice ca e m r
mempty = forall (ca :: * -> Constraint) e (m :: * -> *) r.
(forall (as :: [*]).
 All ca as =>
 NP I as -> ReaderT e m (ReaderT e m r -> ReaderT e m r, NP I as))
-> Advice ca e m r
Advice \NP I as
args -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> a
id, NP I as
args)

-- |
--    The most general way of constructing 'Advice's.
--
--    An 'Advice' is a function that transforms other functions in an 
--    arity-polymorphic way. It receives the arguments of the advised
--    function packed into an n-ary product 'NP', performs some 
--    effects based on them, and returns a potentially modified version of the 
--    arguments, along with a function for tweaking the execution of the
--    advised function.
--
-- >>> :{
--  doesNothing :: forall ca e m r. Monad m => Advice ca e m r
--  doesNothing = makeAdvice (\args -> pure (id,  args)) 
-- :}
--
--
makeAdvice ::
  forall ca e m r.
  -- | The function that tweaks the arguments and the execution.
  ( forall as.
    All ca as =>
    NP I as ->
    ReaderT e m (ReaderT e m r -> ReaderT e m r, NP I as)
  ) ->
  Advice ca e m r
makeAdvice :: forall (ca :: * -> Constraint) e (m :: * -> *) r.
(forall (as :: [*]).
 All ca as =>
 NP I as -> ReaderT e m (ReaderT e m r -> ReaderT e m r, NP I as))
-> Advice ca e m r
makeAdvice = forall (ca :: * -> Constraint) e (m :: * -> *) r.
(forall (as :: [*]).
 All ca as =>
 NP I as -> ReaderT e m (ReaderT e m r -> ReaderT e m r, NP I as))
-> Advice ca e m r
Advice

-- |
--    Create an advice which only tweaks and/or analyzes the function arguments.
--
-- >>> :{
--  doesNothing :: forall ca e m r. Monad m => Advice ca e m r
--  doesNothing = makeArgsAdvice pure
-- :}
makeArgsAdvice ::
  forall ca e m r.
  Monad m =>
  -- | The function that tweaks the arguments.
  ( forall as.
    All ca as =>
    NP I as ->
    ReaderT e m (NP I as)
  ) ->
  Advice ca e m r
makeArgsAdvice :: forall (ca :: * -> Constraint) e (m :: * -> *) r.
Monad m =>
(forall (as :: [*]). All ca as => NP I as -> ReaderT e m (NP I as))
-> Advice ca e m r
makeArgsAdvice forall (as :: [*]). All ca as => NP I as -> ReaderT e m (NP I as)
tweakArgs =
  forall (ca :: * -> Constraint) e (m :: * -> *) r.
(forall (as :: [*]).
 All ca as =>
 NP I as -> ReaderT e m (ReaderT e m r -> ReaderT e m r, NP I as))
-> Advice ca e m r
makeAdvice forall a b. (a -> b) -> a -> b
$ \NP I as
args -> do
    NP I as
args' <- forall (as :: [*]). All ca as => NP I as -> ReaderT e m (NP I as)
tweakArgs NP I as
args
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> a
id, NP I as
args')

-- |
--    Create an advice which only tweaks the execution of the final monadic action.
--
-- >>> :{
--  doesNothing :: forall ca e m r. Monad m => Advice ca e m r
--  doesNothing = makeExecutionAdvice id
-- :}
makeExecutionAdvice ::
  forall ca e m r.
  Applicative m =>
  -- | The function that tweaks the execution.
  ( ReaderT e m r ->
    ReaderT e m r
  ) ->
  Advice ca e m r
makeExecutionAdvice :: forall (ca :: * -> Constraint) e (m :: * -> *) r.
Applicative m =>
(ReaderT e m r -> ReaderT e m r) -> Advice ca e m r
makeExecutionAdvice ReaderT e m r -> ReaderT e m r
tweakExecution = forall (ca :: * -> Constraint) e (m :: * -> *) r.
(forall (as :: [*]).
 All ca as =>
 NP I as -> ReaderT e m (ReaderT e m r -> ReaderT e m r, NP I as))
-> Advice ca e m r
makeAdvice \NP I as
args -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReaderT e m r -> ReaderT e m r
tweakExecution, NP I as
args)

data Pair a b = Pair !a !b

-- | Apply an 'Advice' to some compatible function. The function must have its
-- effects in 'ReaderT', and all of its arguments must satisfy the @ca@ constraint.
--
-- >>> :{
--  foo :: Int -> ReaderT () IO String
--  foo _ = pure "foo"
--  advisedFoo = advise (printArgs stdout "Foo args: ") foo
-- :}
--
-- __/TYPE APPLICATION REQUIRED!/__ If the @ca@ constraint of the 'Advice' remains polymorphic,
-- it must be supplied by means of a type application:
--
-- >>> :{
--  bar :: Int -> ReaderT () IO String
--  bar _ = pure "bar"
--  advisedBar1 = advise (returnMempty @Top) bar
--  advisedBar2 = advise @Top returnMempty bar
-- :}
advise ::
  forall ca e m r as advisee.
  (Multicurryable as e m r advisee, All ca as, Monad m) =>
  -- | The advice to apply.
  Advice ca e m r ->
  -- | A function to be adviced.
  advisee ->
  advisee
advise :: forall (ca :: * -> Constraint) e (m :: * -> *) r (as :: [*])
       advisee.
(Multicurryable as e m r advisee, All ca as, Monad m) =>
Advice ca e m r -> advisee -> advisee
advise (Advice forall (as :: [*]).
All ca as =>
NP I as -> ReaderT e m (ReaderT e m r -> ReaderT e m r, NP I as)
f) advisee
advisee = do
  let uncurried :: NP I as -> ReaderT e m r
uncurried = forall (as :: [*]) e (m :: * -> *) r curried.
Multicurryable as e m r curried =>
curried -> NP I as -> ReaderT e m r
multiuncurry @as @e @m @r advisee
advisee
      uncurried' :: NP I as -> ReaderT e m r
uncurried' NP I as
args = do
        (ReaderT e m r -> ReaderT e m r
tweakExecution, NP I as
args') <- forall (as :: [*]).
All ca as =>
NP I as -> ReaderT e m (ReaderT e m r -> ReaderT e m r, NP I as)
f NP I as
args
        ReaderT e m r -> ReaderT e m r
tweakExecution (NP I as -> ReaderT e m r
uncurried NP I as
args')
   in forall (as :: [*]) e (m :: * -> *) r curried.
Multicurryable as e m r curried =>
(NP I as -> ReaderT e m r) -> curried
multicurry @as @e @m @r NP I as -> ReaderT e m r
uncurried'

type Multicurryable ::
  [Type] ->
  Type ->
  (Type -> Type) ->
  Type ->
  Type ->
  Constraint
class Multicurryable as e m r curried | curried -> as e m r where
  multiuncurry :: curried -> NP I as -> ReaderT e m r
  multicurry :: (NP I as -> ReaderT e m r) -> curried

instance Monad m => Multicurryable '[] e m r (ReaderT e m r) where
  multiuncurry :: ReaderT e m r -> NP I '[] -> ReaderT e m r
multiuncurry ReaderT e m r
action NP I '[]
Nil = ReaderT e m r
action
  multicurry :: (NP I '[] -> ReaderT e m r) -> ReaderT e m r
multicurry NP I '[] -> ReaderT e m r
f = NP I '[] -> ReaderT e m r
f forall {k} (a :: k -> *). NP a '[]
Nil

instance (Functor m, Multicurryable as e m r curried) => Multicurryable (a ': as) e m r (a -> curried) where
  multiuncurry :: (a -> curried) -> NP I (a : as) -> ReaderT e m r
multiuncurry a -> curried
f (I x
a :* NP I xs
as) = forall (as :: [*]) e (m :: * -> *) r curried.
Multicurryable as e m r curried =>
curried -> NP I as -> ReaderT e m r
multiuncurry @as @e @m @r @curried (a -> curried
f x
a) NP I xs
as
  multicurry :: (NP I (a : as) -> ReaderT e m r) -> a -> curried
multicurry NP I (a : as) -> ReaderT e m r
f a
a = forall (as :: [*]) e (m :: * -> *) r curried.
Multicurryable as e m r curried =>
(NP I as -> ReaderT e m r) -> curried
multicurry @as @e @m @r @curried (NP I (a : as) -> ReaderT e m r
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
(:*) (forall a. a -> I a
I a
a))

-- $restrict
--
--    'Advice' values can be composed using the 'Monoid' instance, but only if
--    they have the same type parameters. It's unfortunate that—unlike with
--    normal function constraints—the @ca@ constraints of an 'Advice' aren't
--    automatically "collected" during composition.
--
--    Instead, we need to harmonize the @ca@ constraints of each 'Advice' by
--    turning them into the combination of all constraints. 'restrictArgs'
--    helps with that.
--
--    'restrictArgs' takes as parameter value-level "\evidence\" that one
--    constraint implies another. But how to construct such evidence? By using
--    the 'Dict' GADT, more precisely the deceptively simple-looking term
--    @\\Dict -> Dict@. That function "absorbs" some constraint present in the
--    ambient context and re-packages it a a new constraint that is implied by
--    the former. We can't rely on type inference here; we need to provide
--    enough type information to the GADT, be it as an explicit signature:
--
-- >>> :{
--  stricterPrintArgs :: forall e m r. MonadIO m => Advice (Show `And` Eq `And` Ord) e m r
--  stricterPrintArgs = restrictArgs (\Dict -> Dict) (printArgs stdout "foo")
-- :}
--
--    or with a type application to 'restrictArgs':
--
-- >>> stricterPrintArgs = restrictArgs @(Show `And` Eq `And` Ord) (\Dict -> Dict) (printArgs stdout "foo")

-- | Makes the constraint on the arguments more restrictive.
restrictArgs ::
  forall more less e m r.
  -- | Evidence that one constraint implies the other. Every @x@ that has a @more@ instance also has a @less@ instance.
  (forall x. Dict more x -> Dict less x) ->
  -- | Advice with less restrictive constraint on the args.
  Advice less e m r ->
  -- | Advice with more restrictive constraint on the args.
  Advice more e m r
-- about the order of the type parameters... which is more useful?
-- A possible principle to follow:
-- We are likely to know the "less" constraint, because advices are likely to
-- come pre-packaged and having a type signature.
-- We arent' so sure about having a signature for a whole composed Advice,
-- because the composition might be done
-- on the fly, while constructing a record, without a top-level binding with a
-- type signature.  This seems to favor putting "more" first.
restrictArgs :: forall (more :: * -> Constraint) (less :: * -> Constraint) e
       (m :: * -> *) r.
(forall x. Dict more x -> Dict less x)
-> Advice less e m r -> Advice more e m r
restrictArgs forall x. Dict more x -> Dict less x
evidence (Advice forall (as :: [*]).
All less as =>
NP I as -> ReaderT e m (ReaderT e m r -> ReaderT e m r, NP I as)
advice) = forall (ca :: * -> Constraint) e (m :: * -> *) r.
(forall (as :: [*]).
 All ca as =>
 NP I as -> ReaderT e m (ReaderT e m r -> ReaderT e m r, NP I as))
-> Advice ca e m r
Advice \NP I as
args ->
    let advice' :: forall as. All more as => NP I as -> ReaderT e m (ReaderT e m r -> ReaderT e m r, NP I as)
        advice' :: forall (as :: [*]).
All more as =>
NP I as -> ReaderT e m (ReaderT e m r -> ReaderT e m r, NP I as)
advice' NP I as
args' =
            case forall {k} (c :: k -> Constraint) (d :: k -> Constraint)
       (xs :: [k]).
(forall (a :: k). Dict c a -> Dict d a)
-> Dict (All c) xs -> Dict (All d) xs
Data.SOP.Dict.mapAll @more @less forall x. Dict more x -> Dict less x
evidence of
               Dict (All more) as -> Dict (All less) as
f -> case Dict (All more) as -> Dict (All less) as
f (forall {k} (c :: k -> Constraint) (a :: k). c a => Dict c a
Dict @(All more) @as) of
                        Dict (All less) as
Dict -> forall (as :: [*]).
All less as =>
NP I as -> ReaderT e m (ReaderT e m r -> ReaderT e m r, NP I as)
advice NP I as
args'
     in forall (as :: [*]).
All more as =>
NP I as -> ReaderT e m (ReaderT e m r -> ReaderT e m r, NP I as)
advice' NP I as
args


data RecordComponent
  = Terminal
  | IWrapped
  | Recurse

-- advising *all* fields of a record
--
--
type AdvisedRecord :: (Type -> Constraint) -> Type -> (Type -> Type) -> (Type -> Constraint) -> ((Type -> Type) -> Type) -> Constraint
class AdvisedRecord ca e m cr advised where
  _adviseRecord :: [(TypeRep, String)] -> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e m r) -> advised (ReaderT e m) -> advised (ReaderT e m)

type AdvisedProduct :: (Type -> Constraint) -> Type -> (Type -> Type) -> (Type -> Constraint) -> (k -> Type) -> Constraint
class AdvisedProduct ca e m cr advised_ where
  _adviseProduct :: TypeRep -> [(TypeRep, String)] -> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e m r) -> advised_ k -> advised_ k

instance
  ( G.Generic (advised (ReaderT e m)),
    G.Rep (advised (ReaderT e m)) ~ G.D1 x (G.C1 y advised_),
    Typeable advised,
    AdvisedProduct ca e m cr advised_
  ) =>
  AdvisedRecord ca e m cr advised
  where
  _adviseRecord :: [(TypeRep, String)]
-> (forall r.
    cr r =>
    NonEmpty (TypeRep, String) -> Advice ca e m r)
-> advised (ReaderT e m)
-> advised (ReaderT e m)
_adviseRecord [(TypeRep, String)]
acc forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e m r
f advised (ReaderT e m)
unadvised =
    let G.M1 (G.M1 advised_ Any
unadvised_) = forall a x. Generic a => a -> Rep a x
G.from advised (ReaderT e m)
unadvised
        advised_ :: advised_ Any
advised_ = forall k (ca :: * -> Constraint) e (m :: * -> *)
       (cr :: * -> Constraint) (advised_ :: k -> *) (k :: k).
AdvisedProduct ca e m cr advised_ =>
TypeRep
-> [(TypeRep, String)]
-> (forall r.
    cr r =>
    NonEmpty (TypeRep, String) -> Advice ca e m r)
-> advised_ k
-> advised_ k
_adviseProduct @_ @ca @e @m @cr (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy @advised)) [(TypeRep, String)]
acc forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e m r
f advised_ Any
unadvised_
     in forall a x. Generic a => Rep a x -> a
G.to (forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 (forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 advised_ Any
advised_))

instance
  ( AdvisedProduct ca e m cr advised_left,
    AdvisedProduct ca e m cr advised_right
  ) =>
  AdvisedProduct ca e m cr (advised_left G.:*: advised_right)
  where
  _adviseProduct :: forall (k :: k).
TypeRep
-> [(TypeRep, String)]
-> (forall r.
    cr r =>
    NonEmpty (TypeRep, String) -> Advice ca e m r)
-> (:*:) advised_left advised_right k
-> (:*:) advised_left advised_right k
_adviseProduct TypeRep
tr [(TypeRep, String)]
acc forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e m r
f (advised_left k
unadvised_left G.:*: advised_right k
unadvised_right) = forall k (ca :: * -> Constraint) e (m :: * -> *)
       (cr :: * -> Constraint) (advised_ :: k -> *) (k :: k).
AdvisedProduct ca e m cr advised_ =>
TypeRep
-> [(TypeRep, String)]
-> (forall r.
    cr r =>
    NonEmpty (TypeRep, String) -> Advice ca e m r)
-> advised_ k
-> advised_ k
_adviseProduct @_ @ca @e @m @cr TypeRep
tr [(TypeRep, String)]
acc forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e m r
f advised_left k
unadvised_left forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
G.:*: forall k (ca :: * -> Constraint) e (m :: * -> *)
       (cr :: * -> Constraint) (advised_ :: k -> *) (k :: k).
AdvisedProduct ca e m cr advised_ =>
TypeRep
-> [(TypeRep, String)]
-> (forall r.
    cr r =>
    NonEmpty (TypeRep, String) -> Advice ca e m r)
-> advised_ k
-> advised_ k
_adviseProduct @_ @ca @e @m @cr TypeRep
tr [(TypeRep, String)]
acc forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e m r
f advised_right k
unadvised_right

type DiscriminateAdvisedComponent :: Type -> RecordComponent
type family DiscriminateAdvisedComponent c where
  DiscriminateAdvisedComponent (_ -> _) = 'Terminal
  DiscriminateAdvisedComponent (ReaderT _ _ _) = 'Terminal
  DiscriminateAdvisedComponent (Identity _) = 'IWrapped
  DiscriminateAdvisedComponent (I _) = 'IWrapped
  DiscriminateAdvisedComponent _ = 'Recurse

type AdvisedComponent :: RecordComponent -> (Type -> Constraint) -> Type -> (Type -> Type) -> (Type -> Constraint) -> Type -> Constraint
class AdvisedComponent component_type ca e m cr advised where
  _adviseComponent :: [(TypeRep, String)] -> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e m r) -> advised -> advised

instance
  ( AdvisedComponent (DiscriminateAdvisedComponent advised) ca e m cr advised,
    KnownSymbol fieldName
  ) =>
  AdvisedProduct ca e m cr (G.S1 ( 'G.MetaSel ( 'Just fieldName) su ss ds) (G.Rec0 advised))
  where
  _adviseProduct :: forall (k :: k).
TypeRep
-> [(TypeRep, String)]
-> (forall r.
    cr r =>
    NonEmpty (TypeRep, String) -> Advice ca e m r)
-> S1 ('MetaSel ('Just fieldName) su ss ds) (Rec0 advised) k
-> S1 ('MetaSel ('Just fieldName) su ss ds) (Rec0 advised) k
_adviseProduct TypeRep
tr [(TypeRep, String)]
acc forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e m r
f (G.M1 (G.K1 advised
advised)) =
    let acc' :: [(TypeRep, String)]
acc' = (TypeRep
tr, forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @fieldName)) forall a. a -> [a] -> [a]
: [(TypeRep, String)]
acc
     in forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 (forall k i c (p :: k). c -> K1 i c p
G.K1 (forall (component_type :: RecordComponent) (ca :: * -> Constraint)
       e (m :: * -> *) (cr :: * -> Constraint) advised.
AdvisedComponent component_type ca e m cr advised =>
[(TypeRep, String)]
-> (forall r.
    cr r =>
    NonEmpty (TypeRep, String) -> Advice ca e m r)
-> advised
-> advised
_adviseComponent @(DiscriminateAdvisedComponent advised) @ca @e @m @cr [(TypeRep, String)]
acc' forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e m r
f advised
advised))

instance
  (Multicurryable as e m r advised, All ca as, cr r, Monad m) =>
  AdvisedComponent 'Terminal ca e m cr advised
  where
  _adviseComponent :: [(TypeRep, String)]
-> (forall r.
    cr r =>
    NonEmpty (TypeRep, String) -> Advice ca e m r)
-> advised
-> advised
_adviseComponent [(TypeRep, String)]
acc forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e m r
f advised
advised = forall (ca :: * -> Constraint) e (m :: * -> *) r (as :: [*])
       advisee.
(Multicurryable as e m r advisee, All ca as, Monad m) =>
Advice ca e m r -> advisee -> advisee
advise @ca @e @m (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e m r
f (forall a. [a] -> NonEmpty a
N.fromList [(TypeRep, String)]
acc)) advised
advised

instance
  AdvisedComponent (DiscriminateAdvisedComponent advised) ca e m cr advised =>
  AdvisedComponent 'IWrapped ca e m cr (Identity advised)
  where
  _adviseComponent :: [(TypeRep, String)]
-> (forall r.
    cr r =>
    NonEmpty (TypeRep, String) -> Advice ca e m r)
-> Identity advised
-> Identity advised
_adviseComponent [(TypeRep, String)]
acc forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e m r
f (Identity advised
advised) = forall a. a -> Identity a
Identity (forall (component_type :: RecordComponent) (ca :: * -> Constraint)
       e (m :: * -> *) (cr :: * -> Constraint) advised.
AdvisedComponent component_type ca e m cr advised =>
[(TypeRep, String)]
-> (forall r.
    cr r =>
    NonEmpty (TypeRep, String) -> Advice ca e m r)
-> advised
-> advised
_adviseComponent @(DiscriminateAdvisedComponent advised) @ca @e @m @cr [(TypeRep, String)]
acc forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e m r
f advised
advised)

instance
  AdvisedComponent (DiscriminateAdvisedComponent advised) ca e m cr advised =>
  AdvisedComponent 'IWrapped ca e m cr (I advised)
  where
  _adviseComponent :: [(TypeRep, String)]
-> (forall r.
    cr r =>
    NonEmpty (TypeRep, String) -> Advice ca e m r)
-> I advised
-> I advised
_adviseComponent [(TypeRep, String)]
acc forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e m r
f (I advised
advised) = forall a. a -> I a
I (forall (component_type :: RecordComponent) (ca :: * -> Constraint)
       e (m :: * -> *) (cr :: * -> Constraint) advised.
AdvisedComponent component_type ca e m cr advised =>
[(TypeRep, String)]
-> (forall r.
    cr r =>
    NonEmpty (TypeRep, String) -> Advice ca e m r)
-> advised
-> advised
_adviseComponent @(DiscriminateAdvisedComponent advised) @ca @e @m @cr [(TypeRep, String)]
acc forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e m r
f advised
advised)

instance
  AdvisedRecord ca e m cr advisable =>
  AdvisedComponent 'Recurse ca e m cr (advisable (ReaderT e m))
  where
  _adviseComponent :: [(TypeRep, String)]
-> (forall r.
    cr r =>
    NonEmpty (TypeRep, String) -> Advice ca e m r)
-> advisable (ReaderT e m)
-> advisable (ReaderT e m)
_adviseComponent [(TypeRep, String)]
acc forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e m r
f advisable (ReaderT e m)
advised = forall (ca :: * -> Constraint) e (m :: * -> *)
       (cr :: * -> Constraint) (advisable :: (* -> *) -> *).
AdvisedRecord ca e m cr advisable =>
[(TypeRep, String)]
-> (forall r.
    cr r =>
    NonEmpty (TypeRep, String) -> Advice ca e m r)
-> advisable (ReaderT e m)
-> advisable (ReaderT e m)
_adviseRecord @ca @e @m @cr [(TypeRep, String)]
acc forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e m r
f advisable (ReaderT e m)
advised


-- | Gives 'Advice' to all the functions in a record-of-functions.
--
-- The function that builds the advice receives a list of tuples @(TypeRep, String)@
-- which represent the record types and fields names we have
-- traversed until arriving at the advised function. This info can be useful for
-- logging advices. It's a list instead of a single tuple because
-- 'adviseRecord' works recursively. The elements come innermost-first.
--
-- __/TYPE APPLICATION REQUIRED!/__ The @ca@ constraint on function arguments
-- and the @cr@ constraint on the result type must be supplied by means of a
-- type application. Supply 'Top' if no constraint is required.
adviseRecord ::
  forall ca cr e m advised.
  AdvisedRecord ca e m cr advised =>
  -- | The advice to apply.
  (forall r . cr r => NonEmpty (TypeRep, String) -> Advice ca e m r) ->
  -- | The record to advise recursively.
  advised (ReaderT e m) ->
  -- | The advised record.
  advised (ReaderT e m)
adviseRecord :: forall (ca :: * -> Constraint) (cr :: * -> Constraint) e
       (m :: * -> *) (advised :: (* -> *) -> *).
AdvisedRecord ca e m cr advised =>
(forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e m r)
-> advised (ReaderT e m) -> advised (ReaderT e m)
adviseRecord = forall (ca :: * -> Constraint) e (m :: * -> *)
       (cr :: * -> Constraint) (advisable :: (* -> *) -> *).
AdvisedRecord ca e m cr advisable =>
[(TypeRep, String)]
-> (forall r.
    cr r =>
    NonEmpty (TypeRep, String) -> Advice ca e m r)
-> advisable (ReaderT e m)
-> advisable (ReaderT e m)
_adviseRecord @ca @e @m @cr []

-- $records
--
-- 'adviseRecord' is a version of 'advise' that, instead of working on bare
-- functions, transforms entire records-of-functions in one go. It also works
-- with newtypes containing a single function. The records must derive 'GHC.Generics.Generic'.
--
-- Useful with the \"wrapped\" style of components facilitated by @Control.Monad.Dep.Has@.
--
-- >>> :{
--   type Logger :: (Type -> Type) -> Type
--   newtype Logger d = Logger {log :: String -> d ()} deriving Generic
--   type Repository :: (Type -> Type) -> Type
--   data Repository d = Repository
--     { select :: String -> d [Int],
--       insert :: [Int] -> d ()
--     } deriving Generic
--   type Controller :: (Type -> Type) -> Type
--   newtype Controller d = Controller {serve :: Int -> d String} deriving Generic
--   type Env :: (Type -> Type) -> Type
--   data Env m = Env
--     { logger :: Logger m,
--       repository :: Repository m,
--       controller :: Controller m
--     }
--   env :: Env (ReaderT () IO)
--   env =
--     let logger = Logger \_ -> pure ()
--         repository =
--           Repository {select = \_ -> pure [], insert = \_ -> pure ()} &
--           adviseRecord @Top @Top mempty 
--         controller =
--           Controller { serve = \_ -> pure "view" } &
--           adviseRecord @Top @Top mempty 
--      in Env {logger, repository, controller}
-- :}

-- $sop
-- Some useful definitions re-exported the from \"sop-core\" package.
--
-- 'NP' is an n-ary product used to represent the arguments of advised functions.
--
-- 'I' is an identity functor. The arguments processed by an 'Advice' come wrapped in it.
--
-- 'cfoldMap_NP' is useful to construct homogeneous lists out of the 'NP' product, for example:
--
-- >>> cfoldMap_NP (Proxy @Show) (\(I a) -> [show a]) (I False :* I (1::Int) :* Nil)
-- ["False","1"]

-- $constraints
--
-- Some useful definitions re-exported the from \"constraints\" package.
--
-- 'Dict' and '(:-)' are GADTs used to capture and transform constraints. Used in the 'restrictArgs' function.

-- $constrainthelpers
--
-- To help with the constraint @ca@ that parameterizes 'Advice', this library re-exports the following helpers from \"sop-core\":
--
-- * 'Top' is the \"always satisfied\" constraint, useful when whe don't want to require anything specific in @ca@.
--
-- * 'And' combines two constraints so that an 'Advice' can request them both, for example @Show \`And\` Eq@.
--
-- Also, the 'All' constraint says that some constraint is satisfied by all the
-- components of an 'NP' product. It's in scope when processing the function
-- arguments inside an 'Advice'.