{-# 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 GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# 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 effectful functions of

--    any number of arguments.

--

--    For example, assuming we have a record-of-functions like

--

-- >>> :{

--    data Env m = Env {

--      foo :: m ()

--    , bar :: Int -> m (Maybe Char)

--    , baz :: Int -> Bool -> m Char

--    } deriving Generic

--    env :: Env IO

--    env = Env {

--      foo = pure ()

--    , bar = \_ -> pure (Just 'c')

--    , baz = \_ _ -> pure 'i'

--    }

-- :}

--

-- We can modify all the functions in the record in this way:

--

-- >>> :{

--    env' :: Env IO

--    env' = env & advising (adviseRecord @_ @Top \_ -> printArgs stdout "prefix ")

-- :}

--

-- using the 'Control.Monad.Dep.SimpleAdvice.Basic.printArgs' advice. 

--

-- Or modify an individual function in this way:

--

-- >>> :{

--    env' :: Env IO

--    env' = env & advising \env -> env { 

--          bar = advise (printArgs stdout "prefix ") (bar env)

--      } 

-- :}

--

-- __NOTE__:

--

-- This module is an alternative to "Control.Monad.Dep.Advice" with two advantages:

--

-- - It doesn't use 'Control.Monad.Dep.DepT'. The types are simpler because

--   they don't need to refer to 'Control.Monad.Dep.DepT''s environment.

--

-- - Unlike in "Control.Monad.Dep.Advice", we can advise components

--   which work on a fixed concrete monad like 'IO'.

--

-- Compared with "Control.Monad.Dep.Advice", it does require the extra step

-- of invoking the 'advising' helper function on a record-of-functions.

module Dep.SimpleAdvice
  ( -- * Preparing components for being advised

    advising,
    AspectT (..),
    -- * The Advice type

    Advice,

    -- * Creating Advice values

    makeAdvice,
    makeArgsAdvice,
    makeExecutionAdvice,

    -- * Applying Advices

    advise,

    -- * Harmonizing Advice argument constraints

    -- $restrict

    restrictArgs,

    -- * Advising entire records

    -- $records

    adviseRecord,

    -- * "sop-core" re-exports

    -- $sop

    Top,
    And,
    All,
    NP (..),
    I (..),
    cfoldMap_NP,
    Dict (..),
  )
where

import Dep.Has
import Dep.SimpleAdvice.Internal 
import Data.Coerce
import Control.Monad
import Control.Monad.Fix
import Data.Functor.Identity
import Data.Kind
import Data.List.NonEmpty qualified as N
import Data.SOP
import Data.SOP.Dict
import Data.SOP.NP
import Data.List.NonEmpty
import Data.Typeable
import GHC.Generics qualified as G
import GHC.TypeLits
import Control.Applicative
import Control.Monad.Cont.Class
import Control.Monad.Error.Class
import Control.Monad.IO.Unlift
import Control.Monad.State.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Identity
import Control.Monad.Writer.Class
import Control.Monad.Zip

-- $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.SimpleAdvice

-- >>> import Dep.SimpleAdvice.Basic (printArgs,returnMempty)

-- >>> import Control.Monad

-- >>> import Control.Monad.Trans

-- >>> import Control.Monad.Writer

-- >>> import Data.Kind

-- >>> import Data.SOP

-- >>> import Data.SOP.NP

-- >>> import Data.Monoid

-- >>> import System.IO

-- >>> import Data.IORef

-- >>> import GHC.Generics (Generic)

-- >>> import GHC.Generics qualified

-- >>> import Data.Function



-- |

--    The most general way of constructing 'Advice's.

--

--    An 'Advice' 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 m r. Monad m => Advice ca m r

--  doesNothing = makeAdvice (\args -> pure (id, args)) 

-- :}

--

--

makeAdvice ::
  forall ca m r.
    -- | The function that tweaks the arguments and the execution.

    ( forall as.
      All ca as =>
      NP I as ->
      AspectT m (AspectT m r -> AspectT m r, NP I as)
    ) ->
    Advice ca m r
makeAdvice :: (forall (as :: [*]).
 All ca as =>
 NP I as -> AspectT m (AspectT m r -> AspectT m r, NP I as))
-> Advice ca m r
makeAdvice = (forall (as :: [*]).
 All ca as =>
 NP I as -> AspectT m (AspectT m r -> AspectT m r, NP I as))
-> Advice ca m r
forall (ca :: * -> Constraint) (m :: * -> *) r.
(forall (as :: [*]).
 All ca as =>
 NP I as -> AspectT m (AspectT m r -> AspectT m r, NP I as))
-> Advice ca m r
Advice

-- |

--    Create an advice which only tweaks and/or analyzes the function arguments.

--

-- >>> :{

--  doesNothing :: forall ca m r. Monad m => Advice ca m r

--  doesNothing = makeArgsAdvice pure

-- :}

makeArgsAdvice ::
  forall ca m r.
  Monad m =>
  -- | The function that tweaks the arguments.

  ( forall as.
    All ca as =>
    NP I as ->
    AspectT m (NP I as)
  ) ->
  Advice ca m r
makeArgsAdvice :: (forall (as :: [*]). All ca as => NP I as -> AspectT m (NP I as))
-> Advice ca m r
makeArgsAdvice forall (as :: [*]). All ca as => NP I as -> AspectT m (NP I as)
tweakArgs =
  (forall (as :: [*]).
 All ca as =>
 NP I as -> AspectT m (AspectT m r -> AspectT m r, NP I as))
-> Advice ca m r
forall (ca :: * -> Constraint) (m :: * -> *) r.
(forall (as :: [*]).
 All ca as =>
 NP I as -> AspectT m (AspectT m r -> AspectT m r, NP I as))
-> Advice ca m r
makeAdvice ((forall (as :: [*]).
  All ca as =>
  NP I as -> AspectT m (AspectT m r -> AspectT m r, NP I as))
 -> Advice ca m r)
-> (forall (as :: [*]).
    All ca as =>
    NP I as -> AspectT m (AspectT m r -> AspectT m r, NP I as))
-> Advice ca m r
forall a b. (a -> b) -> a -> b
$ \NP I as
args -> do
    NP I as
args' <- NP I as -> AspectT m (NP I as)
forall (as :: [*]). All ca as => NP I as -> AspectT m (NP I as)
tweakArgs NP I as
args
    (AspectT m r -> AspectT m r, NP I as)
-> AspectT m (AspectT m r -> AspectT m r, NP I as)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AspectT m r -> AspectT m r
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 m r. Monad m => Advice ca m r

--  doesNothing = makeExecutionAdvice id

-- :}

makeExecutionAdvice ::
  forall ca m r.
  Applicative m =>
  -- | The function that tweaks the execution.

  ( AspectT m r ->
    AspectT m r
  ) ->
  Advice ca m r
makeExecutionAdvice :: (AspectT m r -> AspectT m r) -> Advice ca m r
makeExecutionAdvice AspectT m r -> AspectT m r
tweakExecution = (forall (as :: [*]).
 All ca as =>
 NP I as -> AspectT m (AspectT m r -> AspectT m r, NP I as))
-> Advice ca m r
forall (ca :: * -> Constraint) (m :: * -> *) r.
(forall (as :: [*]).
 All ca as =>
 NP I as -> AspectT m (AspectT m r -> AspectT m r, NP I as))
-> Advice ca m r
makeAdvice \NP I as
args -> (AspectT m r -> AspectT m r, NP I as)
-> AspectT m (AspectT m r -> AspectT m r, NP I as)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AspectT m r -> AspectT m r
tweakExecution, NP I as
args)


-- | Apply an 'Advice' to some compatible function. The function must have its

-- effects in 'AspectT', and all of its arguments must satisfy the @ca@ constraint.

--

-- >>> :{

--  foo :: Int -> AspectT 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 -> AspectT IO String

--  bar _ = pure "bar"

--  advisedBar1 = advise (returnMempty @Top) bar

--  advisedBar2 = advise @Top returnMempty bar

-- :}

advise ::
  forall ca m r as advisee.
  (Multicurryable as m r advisee, All ca as, Monad m) =>
  -- | The advice to apply.

  Advice ca m r ->
  -- | A function to be adviced.

  advisee ->
  advisee
advise :: Advice ca m r -> advisee -> advisee
advise (Advice forall (as :: [*]).
All ca as =>
NP I as -> AspectT m (AspectT m r -> AspectT m r, NP I as)
f) advisee
advisee = do
  let uncurried :: NP I as -> AspectT m r
uncurried = advisee -> NP I as -> AspectT m r
forall (as :: [*]) (m :: * -> *) r curried.
Multicurryable as m r curried =>
curried -> NP I as -> AspectT m r
multiuncurry @as @m @r advisee
advisee
      uncurried' :: NP I as -> AspectT m r
uncurried' NP I as
args = do
        (AspectT m r -> AspectT m r
tweakExecution, NP I as
args') <- NP I as -> AspectT m (AspectT m r -> AspectT m r, NP I as)
forall (as :: [*]).
All ca as =>
NP I as -> AspectT m (AspectT m r -> AspectT m r, NP I as)
f NP I as
args
        AspectT m r -> AspectT m r
tweakExecution (NP I as -> AspectT m r
uncurried NP I as
args')
   in (NP I as -> AspectT m r) -> advisee
forall (as :: [*]) (m :: * -> *) r curried.
Multicurryable as m r curried =>
(NP I as -> AspectT m r) -> curried
multicurry @as @m @r NP I as -> AspectT m r
uncurried'

-- | This function \"installs\" an 'AspectT' newtype wrapper for the monad

-- parameter of a record-of-functions, applies some function on

-- the tweaked component, and then removes the wrapper from the result.

--

-- This is necessary because the typeclass machinery which handles

-- 'Advice's uses 'AspectT' as a \"mark\" to recognize \"the end of the function\".

advising 
    :: Coercible (r_ m) (r_ (AspectT m)) =>
    -- | transform the record coerced to 'AspectT', for example using 'adviseRecord'

    (r_ (AspectT m) -> r_ (AspectT m)) ->
    -- | transform the original record

    r_ m -> r_ m
advising :: (r_ (AspectT m) -> r_ (AspectT m)) -> r_ m -> r_ m
advising r_ (AspectT m) -> r_ (AspectT m)
f = r_ (AspectT m) -> r_ m
coerce (r_ (AspectT m) -> r_ m)
-> (r_ m -> r_ (AspectT m)) -> r_ m -> r_ m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r_ (AspectT m) -> r_ (AspectT m)
f (r_ (AspectT m) -> r_ (AspectT m))
-> (r_ m -> r_ (AspectT m)) -> r_ m -> r_ (AspectT m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r_ m -> r_ (AspectT m)
coerce

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

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

instance Multicurryable as m r curried => Multicurryable (a ': as) m r (a -> curried) where
  multiuncurry :: (a -> curried) -> NP I (a : as) -> AspectT m r
multiuncurry a -> curried
f (I x
a :* NP I xs
as) = curried -> NP I as -> AspectT m r
forall (as :: [*]) (m :: * -> *) r curried.
Multicurryable as m r curried =>
curried -> NP I as -> AspectT m r
multiuncurry @as @m @r @curried (a -> curried
f a
x
a) NP I as
NP I xs
as
  multicurry :: (NP I (a : as) -> AspectT m r) -> a -> curried
multicurry NP I (a : as) -> AspectT m r
f a
a = (NP I as -> AspectT m r) -> curried
forall (as :: [*]) (m :: * -> *) r curried.
Multicurryable as m r curried =>
(NP I as -> AspectT m r) -> curried
multicurry @as @m @r @curried (NP I (a : as) -> AspectT m r
f (NP I (a : as) -> AspectT m r)
-> (NP I as -> NP I (a : as)) -> NP I as -> AspectT m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. I a -> NP I as -> NP I (a : as)
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
(:*) (a -> I a
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 m r. MonadIO m => Advice (Show `And` Eq `And` Ord) 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 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 m r ->
  -- | Advice with more restrictive constraint on the args.

  Advice more 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 x. Dict more x -> Dict less x)
-> Advice less m r -> Advice more m r
restrictArgs forall x. Dict more x -> Dict less x
evidence (Advice forall (as :: [*]).
All less as =>
NP I as -> AspectT m (AspectT m r -> AspectT m r, NP I as)
advice) = (forall (as :: [*]).
 All more as =>
 NP I as -> AspectT m (AspectT m r -> AspectT m r, NP I as))
-> Advice more m r
forall (ca :: * -> Constraint) (m :: * -> *) r.
(forall (as :: [*]).
 All ca as =>
 NP I as -> AspectT m (AspectT m r -> AspectT m r, NP I as))
-> Advice ca m r
Advice \NP I as
args ->
    let advice' :: forall as. All more as => NP I as -> AspectT m (AspectT m r -> AspectT m r, NP I as)
        advice' :: NP I as -> AspectT m (AspectT m r -> AspectT m r, NP I as)
advice' NP I as
args' =
            case (forall x. Dict more x -> Dict less x)
-> Dict (All more) as -> Dict (All less) as
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 (All more as => Dict (All more) as
forall k (c :: k -> Constraint) (a :: k). c a => Dict c a
Dict @(All more) @as) of
                        Dict (All less) as
Dict -> NP I as -> AspectT m (AspectT m r -> AspectT m r, NP I as)
forall (as :: [*]).
All less as =>
NP I as -> AspectT m (AspectT m r -> AspectT m r, NP I as)
advice NP I as
args'
     in NP I as -> AspectT m (AspectT m r -> AspectT m r, NP I as)
forall (as :: [*]).
All more as =>
NP I as -> AspectT m (AspectT m r -> AspectT m r, NP I as)
advice' NP I as
args


-- advising *all* fields of a record

--

--

type AdvisedRecord :: (Type -> Constraint) -> (Type -> Type) -> (Type -> Constraint) -> ((Type -> Type) -> Type) -> Constraint
class AdvisedRecord ca m cr advised where
  _adviseRecord :: [(TypeRep, String)] -> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca m r) -> advised (AspectT m) -> advised (AspectT m)

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

instance
  ( G.Generic (advised (AspectT m)),
    -- G.Rep (advised (AspectT m)) ~ G.D1 ('G.MetaData name mod p nt) (G.C1 y advised_),

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

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

data RecordComponent
  = Terminal
  | IWrapped
  | Recurse

type DiscriminateAdvisedComponent :: Type -> RecordComponent
type family DiscriminateAdvisedComponent c where
  DiscriminateAdvisedComponent (a -> b) = Terminal
  DiscriminateAdvisedComponent (AspectT m x) = Terminal
  DiscriminateAdvisedComponent (Identity _) = IWrapped
  DiscriminateAdvisedComponent (I _) = IWrapped
  DiscriminateAdvisedComponent _ = Recurse

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

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

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

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

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

instance
  AdvisedComponent (DiscriminateAdvisedComponent advised) ca m cr advised =>
  AdvisedComponent IWrapped ca m cr (I advised)
  where
  _adviseComponent :: [(TypeRep, String)]
-> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca m r)
-> I advised
-> I advised
_adviseComponent [(TypeRep, String)]
acc forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca m r
f (I advised
advised) = advised -> I advised
forall a. a -> I a
I ([(TypeRep, String)]
-> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca m r)
-> advised
-> advised
forall (component_type :: RecordComponent) (ca :: * -> Constraint)
       (m :: * -> *) (cr :: * -> Constraint) advised.
AdvisedComponent component_type ca m cr advised =>
[(TypeRep, String)]
-> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca m r)
-> advised
-> advised
_adviseComponent @(DiscriminateAdvisedComponent advised) @ca @m @cr [(TypeRep, String)]
acc forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca m r
f advised
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 m advised.
  AdvisedRecord ca m cr advised =>
  -- | The advice to apply.

  (forall r . cr r => NonEmpty (TypeRep, String) -> Advice ca m r) ->
  -- | The record to advise recursively.

  advised (AspectT m) ->
  -- | The advised record.

  advised (AspectT m)
adviseRecord :: (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca m r)
-> advised (AspectT m) -> advised (AspectT m)
adviseRecord = [(TypeRep, String)]
-> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca m r)
-> advised (AspectT m)
-> advised (AspectT m)
forall (ca :: * -> Constraint) (m :: * -> *)
       (cr :: * -> Constraint) (advisable :: (* -> *) -> *).
AdvisedRecord ca m cr advisable =>
[(TypeRep, String)]
-> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca m r)
-> advisable (AspectT m)
-> advisable (AspectT m)
_adviseRecord @ca @m @cr []

-- $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'.


-- $invocation

-- These functions are helpers for running 'AspectT' computations, beyond what 'runAspectT' provides.

--

-- They aren't directly related to 'Advice's, but they require some of the same machinery, and that's why they are here.