{-# 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 'DepT'-effectful functions of

--    any number of arguments.

--

-- >>> :{

--    foo0 :: DepT NilEnv IO (Sum Int)

--    foo0 = pure (Sum 5)

--    foo1 :: Bool -> DepT NilEnv IO (Sum Int)

--    foo1 _ = foo0

--    foo2 :: Char -> Bool -> DepT NilEnv IO (Sum Int)

--    foo2 _ = foo1

-- :}

--

-- They work for @DepT@-actions of zero arguments:

--

-- >>> advise (fromSimple \_ -> printArgs stdout "foo0") foo0 `runDepT` NilEnv

-- foo0:

-- <BLANKLINE>

-- Sum {getSum = 5}

--

-- And for functions of one or more arguments, provided they end on a @DepT@-action:

--

-- >>> advise (fromSimple \_ -> printArgs stdout "foo1") foo1 False `runDepT` NilEnv

-- foo1: False

-- <BLANKLINE>

-- Sum {getSum = 5}

--

-- >>> advise (fromSimple \_ -> printArgs stdout "foo2") foo2 'd' False `runDepT` NilEnv

-- foo2: 'd' False

-- <BLANKLINE>

-- Sum {getSum = 5}

--

-- 'Advice's can also tweak the result value of functions:

--

-- >>> advise (fromSimple \_ -> returnMempty @Top) foo2 'd' False `runDepT` NilEnv

-- Sum {getSum = 0}

--

-- And they can be combined using @Advice@'s 'Monoid' instance before being

-- applied:

--

-- >>> advise (fromSimple \_ -> printArgs stdout "foo2" <> returnMempty) foo2 'd' False `runDepT` NilEnv

-- 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.Advice
  ( -- * The Advice type

    Advice,

    -- * Creating Advice values

    makeAdvice,
    makeArgsAdvice,
    makeExecutionAdvice,

    -- * Applying Advices

    advise,

    -- * Constraint helpers

    -- $constrainthelpers

    Ensure,

    -- * Harmonizing Advice argument constraints

    -- $restrict

    restrictArgs,

    -- * Invocation helpers

    -- $invocation

    runFinalDepT,
    runFromEnv,
    runFromDep,
    -- askFinalDepT,

    -- * Making functions see a different environment

    deceive,

    -- * Advising and deceiving entire records

    -- $records

    adviseRecord,
    deceiveRecord,
    -- * Plugging Has-based constructors

    component,
    --distributeDepT,


    -- * Interfacing with "simple" advices

    toSimple,
    fromSimple,
    fromSimple_,

    -- * "sop-core" re-exports

    -- $sop

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

import Dep.Has
import Dep.Env
import Control.Monad.Dep
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)
import Dep.SimpleAdvice.Internal qualified as SA

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

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

-- >>> import Control.Monad

-- >>> import Control.Monad.Dep

-- >>> 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


-- | A generic transformation of 'DepT'-effectful functions with environment

-- @e_@, base monad @m@ and return type @r@,

-- provided the functions satisfy certain constraint @ca@

-- on all of their arguments.

--

-- Note that the type constructor for the environment @e_@ is given unapplied.

-- That is, @Advice Show NilEnv IO ()@ kind-checks but @Advice Show (NilEnv IO)

-- IO ()@ doesn't. See also 'Ensure'.

--

-- '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 "Control.Monad.Dep.Advice.Basic" for examples.

type Advice ::
  (Type -> Constraint) ->
  ((Type -> Type) -> Type) ->
  (Type -> Type) ->
  Type ->
  Type
data Advice (ca :: Type -> Constraint) (e_ :: (Type -> Type) -> Type) m r where
  Advice ::
    forall ca e_ m r.
    ( forall as.
      All ca as =>
      NP I as ->
      DepT e_ m (DepT e_ m r -> DepT 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 'DepT' 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 -> DepT e_ m (DepT e_ m r -> DepT 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 -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as)
inner = (forall (as :: [*]).
 All ca as =>
 NP I as -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as))
-> Advice ca e_ m r
forall (ca :: * -> Constraint) (e_ :: (* -> *) -> *) (m :: * -> *)
       r.
(forall (as :: [*]).
 All ca as =>
 NP I as -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as))
-> Advice ca e_ m r
Advice \NP I as
args -> do
    (DepT e_ m r -> DepT e_ m r
tweakOuter, NP I as
argsOuter) <- NP I as -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as)
forall (as :: [*]).
All ca as =>
NP I as -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as)
outer NP I as
args
    (DepT e_ m r -> DepT e_ m r
tweakInner, NP I as
argsInner) <- NP I as -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as)
forall (as :: [*]).
All ca as =>
NP I as -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as)
inner NP I as
argsOuter
    (DepT e_ m r -> DepT e_ m r, NP I as)
-> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DepT e_ m r -> DepT e_ m r
tweakOuter (DepT e_ m r -> DepT e_ m r)
-> (DepT e_ m r -> DepT e_ m r) -> DepT e_ m r -> DepT e_ m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DepT e_ m r -> DepT 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 = Advice ca e_ m r -> Advice ca e_ m r -> Advice ca e_ m r
forall a. Semigroup a => a -> a -> a
(<>)
  mempty :: Advice ca e_ m r
mempty = (forall (as :: [*]).
 All ca as =>
 NP I as -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as))
-> Advice ca e_ m r
forall (ca :: * -> Constraint) (e_ :: (* -> *) -> *) (m :: * -> *)
       r.
(forall (as :: [*]).
 All ca as =>
 NP I as -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as))
-> Advice ca e_ m r
Advice \NP I as
args -> (DepT e_ m r -> DepT e_ m r, NP I as)
-> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DepT e_ m r -> DepT e_ m r
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 ->
    DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as)
  ) ->
  Advice ca e_ m r
makeAdvice :: (forall (as :: [*]).
 All ca as =>
 NP I as -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as))
-> Advice ca e_ m r
makeAdvice = (forall (as :: [*]).
 All ca as =>
 NP I as -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as))
-> Advice ca e_ m r
forall (ca :: * -> Constraint) (e_ :: (* -> *) -> *) (m :: * -> *)
       r.
(forall (as :: [*]).
 All ca as =>
 NP I as -> DepT e_ m (DepT e_ m r -> DepT 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 ->
    DepT e_ m (NP I as)
  ) ->
  Advice ca e_ m r
makeArgsAdvice :: (forall (as :: [*]). All ca as => NP I as -> DepT e_ m (NP I as))
-> Advice ca e_ m r
makeArgsAdvice forall (as :: [*]). All ca as => NP I as -> DepT e_ m (NP I as)
tweakArgs =
  (forall (as :: [*]).
 All ca as =>
 NP I as -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as))
-> Advice ca e_ m r
forall (ca :: * -> Constraint) (e_ :: (* -> *) -> *) (m :: * -> *)
       r.
(forall (as :: [*]).
 All ca as =>
 NP I as -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as))
-> Advice ca e_ m r
makeAdvice ((forall (as :: [*]).
  All ca as =>
  NP I as -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as))
 -> Advice ca e_ m r)
-> (forall (as :: [*]).
    All ca as =>
    NP I as -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as))
-> Advice ca e_ m r
forall a b. (a -> b) -> a -> b
$ \NP I as
args -> do
    NP I as
args' <- NP I as -> DepT e_ m (NP I as)
forall (as :: [*]). All ca as => NP I as -> DepT e_ m (NP I as)
tweakArgs NP I as
args
    (DepT e_ m r -> DepT e_ m r, NP I as)
-> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DepT e_ m r -> DepT e_ 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 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.

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

data Pair a b = Pair !a !b

-- |

-- 'Ensure' is a helper for lifting typeclass definitions of the form:

--

-- >>> :{

--  type HasLogger :: (Type -> Type) -> Type -> Constraint

--  class HasLogger d e | e -> d where

--    logger :: e -> String -> d ()

-- :}

--

-- To work as a constraints on the @e_@ and @m@ parameters of an 'Advice', like this:

--

-- >>> :{

--  requiresLogger :: forall e_ m r. (Ensure HasLogger e_ m, Monad m) => Advice Show e_ m r

--  requiresLogger = mempty

--  :}

--

-- Why is it necessary? Two-place @HasX@-style constraints receive the \"fully

-- applied\" type of the record-of-functions. That is: @NilEnv IO@ instead of

-- simply @NilEnv@. This allows them to also work with monomorphic environments

-- (like those in <http://hackage.haskell.org/package/rio RIO>) whose type

-- isn't parameterized by any monad.

--

-- But the @e_@ type parameter of 'Advice' has kind @(Type -> Type) -> Type@.

-- That is: @NilEnv@ alone.

--

-- Furthermore, 'Advices' require @HasX@-style constraints to be placed on the

-- @DepT@ transformer, not directly on the base monad @m@. @Ensure@ takes care

-- of that as well.

type Ensure :: ((Type -> Type) -> Type -> Constraint) -> ((Type -> Type) -> Type) -> (Type -> Type) -> Constraint

type Ensure c e_ m = c (DepT e_ m) (e_ (DepT e_ m))

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

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

--

-- >>> :{

--  foo :: Int -> DepT NilEnv IO String

--  foo _ = pure "foo"

--  advisedFoo = advise (fromSimple \_ -> 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 -> DepT NilEnv IO String

--  bar _ = pure "bar"

--  advisedBar1 = advise (fromSimple \_ -> returnMempty @Top) bar

--  advisedBar2 = advise @Top (fromSimple \_ -> 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 :: Advice ca e_ m r -> advisee -> advisee
advise (Advice forall (as :: [*]).
All ca as =>
NP I as -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as)
f) advisee
advisee = do
  let uncurried :: NP I as -> DepT e_ m r
uncurried = advisee -> NP I as -> DepT e_ m r
forall (as :: [*]) (e_ :: (* -> *) -> *) (m :: * -> *) r curried.
Multicurryable as e_ m r curried =>
curried -> NP I as -> DepT e_ m r
multiuncurry @as @e_ @m @r advisee
advisee
      uncurried' :: NP I as -> DepT e_ m r
uncurried' NP I as
args = do
        (DepT e_ m r -> DepT e_ m r
tweakExecution, NP I as
args') <- NP I as -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as)
forall (as :: [*]).
All ca as =>
NP I as -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as)
f NP I as
args
        DepT e_ m r -> DepT e_ m r
tweakExecution (NP I as -> DepT e_ m r
uncurried NP I as
args')
   in (NP I as -> DepT e_ m r) -> advisee
forall (as :: [*]) (e_ :: (* -> *) -> *) (m :: * -> *) r curried.
Multicurryable as e_ m r curried =>
(NP I as -> DepT e_ m r) -> curried
multicurry @as @e_ @m @r NP I as -> DepT e_ m r
uncurried'

type Multicurryable ::
  [Type] ->
  ((Type -> Type) -> Type) ->
  (Type -> Type) ->
  Type ->
  Type ->
  Constraint
class Multicurryable as e_ m r curried | curried -> as e_ m r where
  type DownToBaseMonad as e_ m r curried :: Type
  multiuncurry :: curried -> NP I as -> DepT e_ m r
  multicurry :: (NP I as -> DepT e_ m r) -> curried
  _runFromEnv :: m (e_ (DepT e_ m)) -> (e_ (DepT e_ m) -> curried) -> DownToBaseMonad as e_ m r curried
  _askFinalDepT :: (e_ (DepT e_ m) -> m curried) -> curried

instance Monad m => Multicurryable '[] e_ m r (DepT e_ m r) where
  type DownToBaseMonad '[] e_ m r (DepT e_ m r) = m r
  multiuncurry :: DepT e_ m r -> NP I '[] -> DepT e_ m r
multiuncurry DepT e_ m r
action NP I '[]
Nil = DepT e_ m r
action
  multicurry :: (NP I '[] -> DepT e_ m r) -> DepT e_ m r
multicurry NP I '[] -> DepT e_ m r
f = NP I '[] -> DepT e_ m r
f NP I '[]
forall k (a :: k -> *). NP a '[]
Nil
  _runFromEnv :: m (e_ (DepT e_ m))
-> (e_ (DepT e_ m) -> DepT e_ m r)
-> DownToBaseMonad '[] e_ m r (DepT e_ m r)
_runFromEnv m (e_ (DepT e_ m))
producer e_ (DepT e_ m) -> DepT e_ m r
extractor = do
    e_ (DepT e_ m)
e <- m (e_ (DepT e_ m))
producer
    DepT e_ m r -> e_ (DepT e_ m) -> m r
forall (e_ :: (* -> *) -> *) (m :: * -> *) r.
DepT e_ m r -> e_ (DepT e_ m) -> m r
runDepT (e_ (DepT e_ m) -> DepT e_ m r
extractor e_ (DepT e_ m)
e) e_ (DepT e_ m)
e
  _askFinalDepT :: (e_ (DepT e_ m) -> m (DepT e_ m r)) -> DepT e_ m r
_askFinalDepT e_ (DepT e_ m) -> m (DepT e_ m r)
f = do
    e_ (DepT e_ m)
env <- DepT e_ m (e_ (DepT e_ m))
forall r (m :: * -> *). MonadReader r m => m r
ask
    DepT e_ m r
r <- m (DepT e_ m r) -> DepT e_ m (DepT e_ m r)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (e_ (DepT e_ m) -> m (DepT e_ m r)
f e_ (DepT e_ m)
env)
    DepT e_ m r
r

instance (Functor m, Multicurryable as e_ m r curried) => Multicurryable (a ': as) e_ m r (a -> curried) where
  type DownToBaseMonad (a ': as) e_ m r (a -> curried) = a -> DownToBaseMonad as e_ m r curried
  multiuncurry :: (a -> curried) -> NP I (a : as) -> DepT e_ m r
multiuncurry a -> curried
f (I x
a :* NP I xs
as) = curried -> NP I as -> DepT e_ m r
forall (as :: [*]) (e_ :: (* -> *) -> *) (m :: * -> *) r curried.
Multicurryable as e_ m r curried =>
curried -> NP I as -> DepT e_ m r
multiuncurry @as @e_ @m @r @curried (a -> curried
f a
x
a) NP I as
NP I xs
as
  multicurry :: (NP I (a : as) -> DepT e_ m r) -> a -> curried
multicurry NP I (a : as) -> DepT e_ m r
f a
a = (NP I as -> DepT e_ m r) -> curried
forall (as :: [*]) (e_ :: (* -> *) -> *) (m :: * -> *) r curried.
Multicurryable as e_ m r curried =>
(NP I as -> DepT e_ m r) -> curried
multicurry @as @e_ @m @r @curried (NP I (a : as) -> DepT e_ m r
f (NP I (a : as) -> DepT e_ m r)
-> (NP I as -> NP I (a : as)) -> NP I as -> DepT e_ 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))
  _runFromEnv :: m (e_ (DepT e_ m))
-> (e_ (DepT e_ m) -> a -> curried)
-> DownToBaseMonad (a : as) e_ m r (a -> curried)
_runFromEnv m (e_ (DepT e_ m))
producer e_ (DepT e_ m) -> a -> curried
extractor a
a = m (e_ (DepT e_ m))
-> (e_ (DepT e_ m) -> curried) -> DownToBaseMonad as e_ m r curried
forall (as :: [*]) (e_ :: (* -> *) -> *) (m :: * -> *) r curried.
Multicurryable as e_ m r curried =>
m (e_ (DepT e_ m))
-> (e_ (DepT e_ m) -> curried) -> DownToBaseMonad as e_ m r curried
_runFromEnv @as @e_ @m @r @curried m (e_ (DepT e_ m))
producer (\e_ (DepT e_ m)
f -> e_ (DepT e_ m) -> a -> curried
extractor e_ (DepT e_ m)
f a
a)
  _askFinalDepT :: (e_ (DepT e_ m) -> m (a -> curried)) -> a -> curried
_askFinalDepT e_ (DepT e_ m) -> m (a -> curried)
f = 
    let switcheroo :: f (a -> b) -> a -> f b
switcheroo f (a -> b)
action a
a = ((a -> b) -> b) -> f (a -> b) -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ a
a) f (a -> b)
action
     in forall (as :: [*]) (e_ :: (* -> *) -> *) (m :: * -> *) r curried.
Multicurryable as e_ m r curried =>
(e_ (DepT e_ m) -> m curried) -> curried
forall curried.
Multicurryable as e_ m r curried =>
(e_ (DepT e_ m) -> m curried) -> curried
_askFinalDepT @as @e_ @m @r ((e_ (DepT e_ m) -> m curried) -> curried)
-> (a -> e_ (DepT e_ m) -> m curried) -> a -> curried
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e_ (DepT e_ m) -> a -> m curried)
-> a -> e_ (DepT e_ m) -> m curried
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((m (a -> curried) -> a -> m curried)
-> (e_ (DepT e_ m) -> m (a -> curried))
-> e_ (DepT e_ m)
-> a
-> m curried
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap m (a -> curried) -> a -> m curried
forall (f :: * -> *) a b. Functor f => f (a -> b) -> a -> f b
switcheroo e_ (DepT e_ m) -> m (a -> curried)
f)

-- | Given a base monad @m@ action that gets hold of the 'DepT' environment, run

-- the 'DepT' transformer at the tip of a curried function.

--

-- >>> :{

--  foo :: Int -> Int -> Int -> DepT NilEnv IO ()

--  foo _ _ _ = pure ()

-- :}

--

--  >>> runFinalDepT (pure NilEnv) foo 1 2 3 :: IO ()

runFinalDepT ::
  forall as e_ m r curried.
  Multicurryable as e_ m r curried =>
  -- | action that gets hold of the environment

  m (e_ (DepT e_ m)) ->
  -- | function to invoke with effects in 'DepT'

  curried ->
  -- | a new function with effects in the base monad

  DownToBaseMonad as e_ m r curried
runFinalDepT :: m (e_ (DepT e_ m)) -> curried -> DownToBaseMonad as e_ m r curried
runFinalDepT m (e_ (DepT e_ m))
producer curried
extractor = m (e_ (DepT e_ m))
-> (e_ (DepT e_ m) -> curried) -> DownToBaseMonad as e_ m r curried
forall (as :: [*]) (e_ :: (* -> *) -> *) (m :: * -> *) r curried.
Multicurryable as e_ m r curried =>
m (e_ (DepT e_ m))
-> (e_ (DepT e_ m) -> curried) -> DownToBaseMonad as e_ m r curried
_runFromEnv m (e_ (DepT e_ m))
producer (curried -> e_ (DepT e_ m) -> curried
forall a b. a -> b -> a
const curried
extractor)

askFinalDepT ::
  forall as e_ m r curried. 
  Multicurryable as e_ m r curried =>
  (e_ (DepT e_ m) -> m curried) -> curried
askFinalDepT :: (e_ (DepT e_ m) -> m curried) -> curried
askFinalDepT = forall (as :: [*]) (e_ :: (* -> *) -> *) (m :: * -> *) r curried.
Multicurryable as e_ m r curried =>
(e_ (DepT e_ m) -> m curried) -> curried
forall curried.
Multicurryable as e_ m r curried =>
(e_ (DepT e_ m) -> m curried) -> curried
_askFinalDepT @as @e_ @m @r

-- | Given a base monad @m@ action that gets hold of the 'DepT' environment,

-- and a function capable of extracting a curried function from the

-- environment, run the 'DepT' transformer at the tip of the resulting curried

-- function.

--

-- Why put the environment behind the @m@ action? Well, since getting to the

-- end of the curried function takes some work, it's a good idea to have some

-- flexibility once we arrive there. For example, the environment could be

-- stored in a "Data.IORef" and change in response to events, perhaps with

-- advices being added or removed.

--

-- >>> :{

--   type MutableEnv :: (Type -> Type) -> Type

--   data MutableEnv m = MutableEnv { _foo :: Int -> m (Sum Int) }

--   :}

--

-- >>> :{

--   do envRef <- newIORef (MutableEnv (pure . Sum))

--      let foo' = runFromEnv (readIORef envRef) _foo

--      do r <- foo' 7

--         print r

--      modifyIORef envRef (\e -> e { _foo = advise @Top (fromSimple \_ -> returnMempty) (_foo e) })

--      do r <- foo' 7

--         print r

-- :}

-- Sum {getSum = 7}

-- Sum {getSum = 0}

runFromEnv ::
  forall as e_ m r curried.
  Multicurryable as e_ m r curried =>
  -- | action that gets hold of the environment

  m (e_ (DepT e_ m)) ->
  -- | gets a function from the environment with effects in 'DepT'

  (e_ (DepT e_ m) -> curried) ->
  -- | a new function with effects in the base monad

  DownToBaseMonad as e_ m r curried
runFromEnv :: m (e_ (DepT e_ m))
-> (e_ (DepT e_ m) -> curried) -> DownToBaseMonad as e_ m r curried
runFromEnv = m (e_ (DepT e_ m))
-> (e_ (DepT e_ m) -> curried) -> DownToBaseMonad as e_ m r curried
forall (as :: [*]) (e_ :: (* -> *) -> *) (m :: * -> *) r curried.
Multicurryable as e_ m r curried =>
m (e_ (DepT e_ m))
-> (e_ (DepT e_ m) -> curried) -> DownToBaseMonad as e_ m r curried
_runFromEnv

-- | Like 'runFromEnv', but the function to run is extracted from a dependency

-- @dep@ which is found using 'Has'. The selector should be concrete enough to

-- identify @dep@ in the environment.

runFromDep ::
  forall dep as e_ m r curried.
  (Multicurryable as e_ m r curried, Has dep (DepT e_ m) (e_ (DepT e_ m))) =>
  -- | action that gets hold of the environment

  m (e_ (DepT e_ m)) ->
  -- | selector that gets a function from a dependency found using 'Has'

  (dep (DepT e_ m) -> curried) ->
  -- | a new function with effects in the base monad

  DownToBaseMonad as e_ m r curried
runFromDep :: m (e_ (DepT e_ m))
-> (dep (DepT e_ m) -> curried)
-> DownToBaseMonad as e_ m r curried
runFromDep m (e_ (DepT e_ m))
envAction dep (DepT e_ m) -> curried
member = m (e_ (DepT e_ m))
-> (e_ (DepT e_ m) -> curried) -> DownToBaseMonad as e_ m r curried
forall (as :: [*]) (e_ :: (* -> *) -> *) (m :: * -> *) r curried.
Multicurryable as e_ m r curried =>
m (e_ (DepT e_ m))
-> (e_ (DepT e_ m) -> curried) -> DownToBaseMonad as e_ m r curried
_runFromEnv m (e_ (DepT e_ m))
envAction (dep (DepT e_ m) -> curried
member (dep (DepT e_ m) -> curried)
-> (e_ (DepT e_ m) -> dep (DepT e_ m)) -> e_ (DepT e_ m) -> curried
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e_ (DepT e_ m) -> dep (DepT e_ m)
forall (r_ :: (* -> *) -> *) (m :: * -> *) env.
Has r_ m env =>
env -> r_ m
dep)

-- $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) (fromSimple \_ -> printArgs stdout "foo")

-- :}

--

--    or with a type application to 'restrictArgs':

--

-- >>> stricterPrintArgs = restrictArgs @(Show `And` Eq `And` Ord) (\Dict -> Dict) (fromSimple \_ -> 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 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 -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as)
advice) = (forall (as :: [*]).
 All more as =>
 NP I as -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as))
-> Advice more e_ m r
forall (ca :: * -> Constraint) (e_ :: (* -> *) -> *) (m :: * -> *)
       r.
(forall (as :: [*]).
 All ca as =>
 NP I as -> DepT e_ m (DepT e_ m r -> DepT 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 -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as)
        advice' :: NP I as -> DepT e_ m (DepT e_ m r -> DepT e_ 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 -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as)
forall (as :: [*]).
All less as =>
NP I as -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as)
advice NP I as
args'
     in NP I as -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as)
forall (as :: [*]).
All more as =>
NP I as -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as)
advice' NP I as
args

--

type Gullible ::
  [Type] ->
  Type ->
  ((Type -> Type) -> Type) ->
  (Type -> Type) ->
  Type ->
  Type ->
  Constraint
class Multicurryable as e_ m r curried => Gullible as e e_ m r curried where
  type NewtypedEnv as e e_ m r curried :: Type
  _deceive :: (e_ (DepT e_ m) -> e) -> NewtypedEnv as e e_ m r curried -> curried

instance Monad m => Gullible '[] e e_ m r (DepT e_ m r) where
  type NewtypedEnv '[] e e_ m r (DepT e_ m r) = ReaderT e m r
  _deceive :: (e_ (DepT e_ m) -> e)
-> NewtypedEnv '[] e e_ m r (DepT e_ m r) -> DepT e_ m r
_deceive e_ (DepT e_ m) -> e
f NewtypedEnv '[] e e_ m r (DepT e_ m r)
action = ReaderT (e_ (DepT e_ m)) m r -> DepT e_ m r
forall (e_ :: (* -> *) -> *) (m :: * -> *) r.
ReaderT (e_ (DepT e_ m)) m r -> DepT e_ m r
DepT ((e_ (DepT e_ m) -> e)
-> ReaderT e m r -> ReaderT (e_ (DepT e_ m)) m r
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT e_ (DepT e_ m) -> e
f ReaderT e m r
NewtypedEnv '[] e e_ m r (DepT e_ m r)
action)

instance (Functor m, Gullible as e e_ m r curried) => Gullible (a ': as) e e_ m r (a -> curried) where
  type NewtypedEnv (a ': as) e e_ m r (a -> curried) = a -> NewtypedEnv as e e_ m r curried
  _deceive :: (e_ (DepT e_ m) -> e)
-> NewtypedEnv (a : as) e e_ m r (a -> curried) -> a -> curried
_deceive e_ (DepT e_ m) -> e
f NewtypedEnv (a : as) e e_ m r (a -> curried)
g a
a = (e_ (DepT e_ m) -> e) -> NewtypedEnv as e e_ m r curried -> curried
forall (as :: [*]) e (e_ :: (* -> *) -> *) (m :: * -> *) r curried.
Gullible as e e_ m r curried =>
(e_ (DepT e_ m) -> e) -> NewtypedEnv as e e_ m r curried -> curried
deceive @as @e @e_ @m @r e_ (DepT e_ m) -> e
f (NewtypedEnv (a : as) e e_ m r (a -> curried)
a -> NewtypedEnv as e e_ m r curried
g a
a)

-- | Makes a function see a newtyped version of the environment record, a version that might have different @HasX@ instances.

--

-- The \"deception\" doesn't affect the dependencies used by the function, only the function itself.

--

-- For example, consider the following setup which features both a \"deceviced\"

-- and an \"undeceived\" version of a controller function:

--

-- >>> :{

--  type HasLogger :: (Type -> Type) -> Type -> Constraint

--  class HasLogger d e | e -> d where

--    logger :: e -> String -> d ()

--  type HasIntermediate :: (Type -> Type) -> Type -> Constraint

--  class HasIntermediate d e | e -> d where

--    intermediate :: e -> String -> d ()

--  type Env :: (Type -> Type) -> Type

--  data Env m = Env

--    { _logger1 :: String -> m (),

--      _logger2 :: String -> m (),

--      _intermediate :: String -> m (),

--      _controllerA :: Int -> m (),

--      _controllerB :: Int -> m ()

--    }

--  instance HasLogger m (Env m) where

--    logger = _logger1

--  instance HasIntermediate m (Env m) where

--    intermediate = _intermediate

--  newtype Switcheroo m = Switcheroo (Env m)

--      deriving newtype (HasIntermediate m)

--  instance HasLogger m (Switcheroo m) where

--    logger (Switcheroo e) = _logger2 e

--  env :: Env (DepT Env (Writer [String]))

--  env =

--    let mkController :: forall d e m. MonadDep [HasLogger, HasIntermediate] d e m => Int -> m ()

--        mkController _ = do e <- ask; liftD $ logger e "foo" ; liftD $ intermediate e "foo"

--        mkIntermediate :: forall d e m. MonadDep '[HasLogger] d e m => String -> m ()

--        mkIntermediate _ = do e <- ask ; liftD $ logger e "foo"

--     in Env

--        {

--          _logger1 =

--             \_ -> tell ["logger 1"],

--          _logger2 =

--             \_ -> tell ["logger 2"],

--          _intermediate =

--             mkIntermediate,

--          _controllerA =

--             mkController,

--          _controllerB =

--             deceive Switcheroo $

--             mkController

--        }

-- :}

--

-- If we run @_controllerA@ the ouput is:

--

-- >>> execWriter $ runFromEnv (pure env) _controllerA 7

-- ["logger 1","logger 1"]

--

-- But if we run the \"deceived\" @_controllerB@, we see that the function and its @_intermediate@ dependency use different loggers:

--

-- >>> execWriter $ runFromEnv (pure env) _controllerB 7

-- ["logger 2","logger 1"]

--

-- Note that the function that is \"deceived\" must be polymorphic over

-- 'Control.Monad.Dep.MonadDep'. Passing a function whose effect monad has

-- already \"collapsed\" into 'DepT' won't work. Therefore, 'deceive' must be applied before any 'Advice'.

deceive ::
  forall as e e_ m r curried.
  Gullible as e e_ m r curried =>
  -- | The newtype constructor that masks the \"true\" environment.

  (e_ (DepT e_ m) -> e) ->
  -- | A function to be deceived. It must be polymorphic over 'Control.Monad.Dep.MonadDep'.

  NewtypedEnv as e e_ m r curried ->
  -- | The deceived function, that has effects in 'DepT'.

  curried
deceive :: (e_ (DepT e_ m) -> e) -> NewtypedEnv as e e_ m r curried -> curried
deceive = (e_ (DepT e_ m) -> e) -> NewtypedEnv as e e_ m r curried -> curried
forall (as :: [*]) e (e_ :: (* -> *) -> *) (m :: * -> *) r curried.
Gullible as e e_ m r curried =>
(e_ (DepT e_ m) -> e) -> NewtypedEnv as e e_ m r curried -> curried
_deceive

-- deceving *all* fields of a record

--

--

type GullibleRecord :: Type -> ((Type -> Type) -> Type) -> (Type -> Type) -> ((Type -> Type) -> Type) -> Constraint
class GullibleRecord e e_ m gullible where
  _deceiveRecord :: (e_ (DepT e_ m) -> e) -> gullible (ReaderT e m) -> gullible (DepT e_ m)

-- https://gitlab.haskell.org/ghc/ghc/-/issues/13952

type GullibleProduct :: Type -> ((Type -> Type) -> Type) -> (Type -> Type) -> (k -> Type) -> (k -> Type) -> Constraint
class GullibleProduct e e_ m gullible_ deceived_ | e e_ m deceived_ -> gullible_ where
  _deceiveProduct :: (e_ (DepT e_ m) -> e) -> gullible_ k -> deceived_ k

instance
  ( GullibleProduct e e_ m gullible_left deceived_left,
    GullibleProduct e e_ m gullible_right deceived_right
  ) =>
  GullibleProduct e e_ m (gullible_left G.:*: gullible_right) (deceived_left G.:*: deceived_right)
  where
  _deceiveProduct :: (e_ (DepT e_ m) -> e)
-> (:*:) gullible_left gullible_right k
-> (:*:) deceived_left deceived_right k
_deceiveProduct e_ (DepT e_ m) -> e
f (gullible_left k
gullible_left G.:*: gullible_right k
gullible_right) = (e_ (DepT e_ m) -> e) -> gullible_left k -> deceived_left k
forall k e (e_ :: (* -> *) -> *) (m :: * -> *)
       (gullible_ :: k -> *) (deceived_ :: k -> *) (k :: k).
GullibleProduct e e_ m gullible_ deceived_ =>
(e_ (DepT e_ m) -> e) -> gullible_ k -> deceived_ k
_deceiveProduct @_ @e @e_ @m e_ (DepT e_ m) -> e
f gullible_left k
gullible_left deceived_left k
-> deceived_right k -> (:*:) deceived_left deceived_right k
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
G.:*: (e_ (DepT e_ m) -> e) -> gullible_right k -> deceived_right k
forall k e (e_ :: (* -> *) -> *) (m :: * -> *)
       (gullible_ :: k -> *) (deceived_ :: k -> *) (k :: k).
GullibleProduct e e_ m gullible_ deceived_ =>
(e_ (DepT e_ m) -> e) -> gullible_ k -> deceived_ k
_deceiveProduct @_ @e @e_ @m e_ (DepT e_ m) -> e
f gullible_right k
gullible_right

data RecordComponent
  = Terminal
  | IWrapped
  | Recurse

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

type GullibleComponent :: RecordComponent -> Type -> ((Type -> Type) -> Type) -> (Type -> Type) -> Type -> Type -> Constraint
class GullibleComponent component_type e e_ m gullible deceived | e e_ m deceived -> gullible where
  _deceiveComponent :: (e_ (DepT e_ m) -> e) -> gullible -> deceived

instance
  (Gullible as e e_ m r deceived, NewtypedEnv as e e_ m r deceived ~ gullible) =>
  GullibleComponent Terminal e e_ m gullible deceived
  where
  _deceiveComponent :: (e_ (DepT e_ m) -> e) -> gullible -> deceived
_deceiveComponent e_ (DepT e_ m) -> e
f gullible
gullible = (e_ (DepT e_ m) -> e)
-> NewtypedEnv as e e_ m r deceived -> deceived
forall (as :: [*]) e (e_ :: (* -> *) -> *) (m :: * -> *) r curried.
Gullible as e e_ m r curried =>
(e_ (DepT e_ m) -> e) -> NewtypedEnv as e e_ m r curried -> curried
deceive @as @e @_ @m @r e_ (DepT e_ m) -> e
f gullible
NewtypedEnv as e e_ m r deceived
gullible

instance
  GullibleComponent (DiscriminateGullibleComponent gullible) e e_ m gullible deceived =>
  GullibleComponent IWrapped e e_ m (Identity gullible) (Identity deceived)
  where
  _deceiveComponent :: (e_ (DepT e_ m) -> e) -> Identity gullible -> Identity deceived
_deceiveComponent e_ (DepT e_ m) -> e
f (Identity gullible
gullible) = deceived -> Identity deceived
forall a. a -> Identity a
Identity ((e_ (DepT e_ m) -> e) -> gullible -> deceived
forall (component_type :: RecordComponent) e (e_ :: (* -> *) -> *)
       (m :: * -> *) gullible deceived.
GullibleComponent component_type e e_ m gullible deceived =>
(e_ (DepT e_ m) -> e) -> gullible -> deceived
_deceiveComponent @(DiscriminateGullibleComponent gullible) @e @e_ @m e_ (DepT e_ m) -> e
f gullible
gullible)

instance
  GullibleComponent (DiscriminateGullibleComponent gullible) e e_ m gullible deceived =>
  GullibleComponent IWrapped e e_ m (I gullible) (I deceived)
  where
  _deceiveComponent :: (e_ (DepT e_ m) -> e) -> I gullible -> I deceived
_deceiveComponent e_ (DepT e_ m) -> e
f (I gullible
gullible) = deceived -> I deceived
forall a. a -> I a
I ((e_ (DepT e_ m) -> e) -> gullible -> deceived
forall (component_type :: RecordComponent) e (e_ :: (* -> *) -> *)
       (m :: * -> *) gullible deceived.
GullibleComponent component_type e e_ m gullible deceived =>
(e_ (DepT e_ m) -> e) -> gullible -> deceived
_deceiveComponent @(DiscriminateGullibleComponent gullible) @e @e_ @m e_ (DepT e_ m) -> e
f gullible
gullible)

instance
  GullibleRecord e e_ m gullible =>
  GullibleComponent Recurse e e_ m (gullible (ReaderT e m)) (gullible (DepT e_ m))
  where
  _deceiveComponent :: (e_ (DepT e_ m) -> e)
-> gullible (ReaderT e m) -> gullible (DepT e_ m)
_deceiveComponent e_ (DepT e_ m) -> e
f gullible (ReaderT e m)
gullible = (e_ (DepT e_ m) -> e)
-> gullible (ReaderT e m) -> gullible (DepT e_ m)
forall e (e_ :: (* -> *) -> *) (m :: * -> *)
       (gullible :: (* -> *) -> *).
GullibleRecord e e_ m gullible =>
(e_ (DepT e_ m) -> e)
-> gullible (ReaderT e m) -> gullible (DepT e_ m)
_deceiveRecord @e @e_ @m e_ (DepT e_ m) -> e
f gullible (ReaderT e m)
gullible

instance
  GullibleComponent (DiscriminateGullibleComponent gullible) e e_ m gullible deceived =>
  GullibleProduct e e_ m (G.S1 x (G.Rec0 gullible)) (G.S1 x (G.Rec0 deceived))
  where
  _deceiveProduct :: (e_ (DepT e_ m) -> e)
-> S1 x (Rec0 gullible) k -> S1 x (Rec0 deceived) k
_deceiveProduct e_ (DepT e_ m) -> e
f (G.M1 (G.K1 gullible
gullible)) = K1 R deceived k -> S1 x (Rec0 deceived) k
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 (deceived -> K1 R deceived k
forall k i c (p :: k). c -> K1 i c p
G.K1 ((e_ (DepT e_ m) -> e) -> gullible -> deceived
forall (component_type :: RecordComponent) e (e_ :: (* -> *) -> *)
       (m :: * -> *) gullible deceived.
GullibleComponent component_type e e_ m gullible deceived =>
(e_ (DepT e_ m) -> e) -> gullible -> deceived
_deceiveComponent @(DiscriminateGullibleComponent gullible) @e @e_ @m e_ (DepT e_ m) -> e
f gullible
gullible))

instance
  ( G.Generic (gullible (ReaderT e m)),
    G.Generic (gullible (DepT e_ m)),
    G.Rep (gullible (ReaderT e m)) ~ G.D1 x (G.C1 y gullible_),
    G.Rep (gullible (DepT e_ m)) ~ G.D1 x (G.C1 y deceived_),
    GullibleProduct e e_ m gullible_ deceived_
  ) =>
  GullibleRecord e e_ m gullible
  where
  _deceiveRecord :: (e_ (DepT e_ m) -> e)
-> gullible (ReaderT e m) -> gullible (DepT e_ m)
_deceiveRecord e_ (DepT e_ m) -> e
f gullible (ReaderT e m)
gullible =
    let G.M1 (G.M1 gullible_ Any
gullible_) = gullible (ReaderT e m) -> Rep (gullible (ReaderT e m)) Any
forall a x. Generic a => a -> Rep a x
G.from gullible (ReaderT e m)
gullible
        deceived_ :: deceived_ Any
deceived_ = (e_ (DepT e_ m) -> e) -> gullible_ Any -> deceived_ Any
forall k e (e_ :: (* -> *) -> *) (m :: * -> *)
       (gullible_ :: k -> *) (deceived_ :: k -> *) (k :: k).
GullibleProduct e e_ m gullible_ deceived_ =>
(e_ (DepT e_ m) -> e) -> gullible_ k -> deceived_ k
_deceiveProduct @_ @e @e_ @m e_ (DepT e_ m) -> e
f gullible_ Any
gullible_
     in Rep (gullible (DepT e_ m)) Any -> gullible (DepT e_ m)
forall a x. Generic a => Rep a x -> a
G.to (M1 C y deceived_ Any -> M1 D x (C1 y deceived_) Any
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 (deceived_ Any -> M1 C y deceived_ Any
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 deceived_ Any
deceived_))

-- | Makes an entire record-of-functions see a different version of the global environment record, a version that might have different @HasX@ instances.

--

-- 'deceiveRecord' must be applied before 'adviseRecord'.

deceiveRecord ::
  forall e e_ m gullible.
  GullibleRecord e e_ m gullible =>
  -- | The newtype constructor that masks the \"true\" environment.

  (e_ (DepT e_ m) -> e) ->
  -- | The record to deceive recursively. The monad parameter must be left polymorphic over @MonadDep@, so that it can unify with `ReaderT`.

  gullible (ReaderT e m) ->
  -- | The deceived record.

  gullible (DepT e_ m)
deceiveRecord :: (e_ (DepT e_ m) -> e)
-> gullible (ReaderT e m) -> gullible (DepT e_ m)
deceiveRecord = GullibleRecord e e_ m gullible =>
(e_ (DepT e_ m) -> e)
-> gullible (ReaderT e m) -> gullible (DepT e_ m)
forall e (e_ :: (* -> *) -> *) (m :: * -> *)
       (gullible :: (* -> *) -> *).
GullibleRecord e e_ m gullible =>
(e_ (DepT e_ m) -> e)
-> gullible (ReaderT e m) -> gullible (DepT e_ m)
_deceiveRecord @e @e_ @m @gullible


-- | Given a constructor that returns a record-of-functions with effects in 'DepT',

-- produce a record in which the member functions 'ask' for the environment themselves.

--

-- You must have a sufficiently polymorphic constructor—both in the monad and

-- in the environment—to invoke this function.

--

-- 'component' lets you plug simple component constructors 

-- into a 'DepT'-based environment.

--

-- Compare with 'Control.Monad.Dep.Env.constructor' from "Control.Monad.Dep.Env", which 

-- is intended to be used with 'Control.Monad.Dep.Env.fixEnv'-based environments.

component 
    :: forall e_ m record . (Applicative m, DistributiveRecord e_ m record) => 
    -- | constructor which takes the environment as a positional parameter.

    (e_ (DepT e_ m) -> record (DepT e_ m)) ->
    -- | component whose methods get the environment by 'ask'ing.

    record (DepT e_ m)
component :: (e_ (DepT e_ m) -> record (DepT e_ m)) -> record (DepT e_ m)
component e_ (DepT e_ m) -> record (DepT e_ m)
f = (e_ (DepT e_ m) -> m (record (DepT e_ m))) -> record (DepT e_ m)
forall (e_ :: (* -> *) -> *) (m :: * -> *)
       (record :: (* -> *) -> *).
DistributiveRecord e_ m record =>
(e_ (DepT e_ m) -> m (record (DepT e_ m))) -> record (DepT e_ m)
_distribute @e_ @m (record (DepT e_ m) -> m (record (DepT e_ m))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (record (DepT e_ m) -> m (record (DepT e_ m)))
-> (e_ (DepT e_ m) -> record (DepT e_ m))
-> e_ (DepT e_ m)
-> m (record (DepT e_ m))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e_ (DepT e_ m) -> record (DepT e_ m)
f)



type DistributiveRecord :: ((Type -> Type) -> Type) -> (Type -> Type) -> ((Type -> Type) -> Type) -> Constraint
class DistributiveRecord e_ m record where
    _distribute :: (e_ (DepT e_ m) -> m (record (DepT e_ m))) -> record (DepT e_ m)

type DistributiveProduct :: ((Type -> Type) -> Type) -> (Type -> Type) -> (k -> Type) -> Constraint
class DistributiveProduct e_ m product where
    _distributeProduct :: (e_ (DepT e_ m) -> m (product k)) -> product k

instance
  ( G.Generic (advised (DepT e_ m)),
    G.Rep (advised (DepT e_ m)) ~ G.D1 x (G.C1 y advised_),
    DistributiveProduct e_ m advised_,
    Functor m
  ) =>
  DistributiveRecord e_ m advised
  where
  _distribute :: (e_ (DepT e_ m) -> m (advised (DepT e_ m))) -> advised (DepT e_ m)
_distribute e_ (DepT e_ m) -> m (advised (DepT e_ m))
f =
    let advised_ :: advised_ Any
advised_ = (e_ (DepT e_ m) -> m (advised_ Any)) -> advised_ Any
forall k (e_ :: (* -> *) -> *) (m :: * -> *) (product :: k -> *)
       (k :: k).
DistributiveProduct e_ m product =>
(e_ (DepT e_ m) -> m (product k)) -> product k
_distributeProduct @_ @e_ @m ((m (advised (DepT e_ m)) -> m (advised_ Any))
-> (e_ (DepT e_ m) -> m (advised (DepT e_ m)))
-> e_ (DepT e_ m)
-> m (advised_ Any)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((advised (DepT e_ m) -> advised_ Any)
-> m (advised (DepT e_ m)) -> m (advised_ Any)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (M1 C y advised_ Any -> advised_ Any
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
G.unM1 (M1 C y advised_ Any -> advised_ Any)
-> (advised (DepT e_ m) -> M1 C y advised_ Any)
-> advised (DepT e_ m)
-> advised_ Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 D x (C1 y advised_) Any -> M1 C y advised_ Any
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
G.unM1 (M1 D x (C1 y advised_) Any -> M1 C y advised_ Any)
-> (advised (DepT e_ m) -> M1 D x (C1 y advised_) Any)
-> advised (DepT e_ m)
-> M1 C y advised_ Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. advised (DepT e_ m) -> M1 D x (C1 y advised_) Any
forall a x. Generic a => a -> Rep a x
G.from)) e_ (DepT e_ m) -> m (advised (DepT e_ m))
f)
     in Rep (advised (DepT e_ m)) Any -> advised (DepT e_ 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
  ( DistributiveProduct e_ m advised_left,
    DistributiveProduct e_ m advised_right,
    Functor m
  ) =>
  DistributiveProduct e_ m (advised_left G.:*: advised_right)
  where
  _distributeProduct :: (e_ (DepT e_ m) -> m ((:*:) advised_left advised_right k))
-> (:*:) advised_left advised_right k
_distributeProduct e_ (DepT e_ m) -> m ((:*:) advised_left advised_right k)
f  = 
      (e_ (DepT e_ m) -> m (advised_left k)) -> advised_left k
forall k (e_ :: (* -> *) -> *) (m :: * -> *) (product :: k -> *)
       (k :: k).
DistributiveProduct e_ m product =>
(e_ (DepT e_ m) -> m (product k)) -> product k
_distributeProduct @_ @e_ @m ((m ((:*:) advised_left advised_right k) -> m (advised_left k))
-> (e_ (DepT e_ m) -> m ((:*:) advised_left advised_right k))
-> e_ (DepT e_ m)
-> m (advised_left k)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((:*:) advised_left advised_right k -> advised_left k)
-> m ((:*:) advised_left advised_right k) -> m (advised_left k)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(advised_left k
l G.:*: advised_right k
_) -> advised_left k
l)) e_ (DepT e_ m) -> m ((:*:) advised_left advised_right k)
f) 
      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.:*: 
      (e_ (DepT e_ m) -> m (advised_right k)) -> advised_right k
forall k (e_ :: (* -> *) -> *) (m :: * -> *) (product :: k -> *)
       (k :: k).
DistributiveProduct e_ m product =>
(e_ (DepT e_ m) -> m (product k)) -> product k
_distributeProduct @_ @e_ @m ((m ((:*:) advised_left advised_right k) -> m (advised_right k))
-> (e_ (DepT e_ m) -> m ((:*:) advised_left advised_right k))
-> e_ (DepT e_ m)
-> m (advised_right k)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((:*:) advised_left advised_right k -> advised_right k)
-> m ((:*:) advised_left advised_right k) -> m (advised_right k)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(advised_left k
_ G.:*: advised_right k
r) -> advised_right k
r)) e_ (DepT e_ m) -> m ((:*:) advised_left advised_right k)
f) 

instance
  ( 
    Functor m,
    DistributiveSubcomponent (DiscriminateDistributiveSubcomponent advised) e_ m advised
  ) =>
  DistributiveProduct e_ m (G.S1 ( 'G.MetaSel msymbol su ss ds) (G.Rec0 advised))
  where
  _distributeProduct :: (e_ (DepT e_ m)
 -> m (S1 ('MetaSel msymbol su ss ds) (Rec0 advised) k))
-> S1 ('MetaSel msymbol su ss ds) (Rec0 advised) k
_distributeProduct e_ (DepT e_ m)
-> m (S1 ('MetaSel msymbol su ss ds) (Rec0 advised) k)
f = K1 R advised k -> S1 ('MetaSel msymbol su ss ds) (Rec0 advised) k
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 (K1 R advised k -> S1 ('MetaSel msymbol su ss ds) (Rec0 advised) k)
-> (advised -> K1 R advised k)
-> advised
-> S1 ('MetaSel msymbol su ss ds) (Rec0 advised) k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. advised -> K1 R advised k
forall k i c (p :: k). c -> K1 i c p
G.K1 (advised -> S1 ('MetaSel msymbol su ss ds) (Rec0 advised) k)
-> advised -> S1 ('MetaSel msymbol su ss ds) (Rec0 advised) k
forall a b. (a -> b) -> a -> b
$ (e_ (DepT e_ m) -> m advised) -> advised
forall (component_type :: RecordComponent) (e_ :: (* -> *) -> *)
       (m :: * -> *) sub.
DistributiveSubcomponent component_type e_ m sub =>
(e_ (DepT e_ m) -> m sub) -> sub
_distributeSubcomponent @(DiscriminateDistributiveSubcomponent advised) @e_ @m @advised ((m (S1 ('MetaSel msymbol su ss ds) (Rec0 advised) k) -> m advised)
-> (e_ (DepT e_ m)
    -> m (S1 ('MetaSel msymbol su ss ds) (Rec0 advised) k))
-> e_ (DepT e_ m)
-> m advised
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((S1 ('MetaSel msymbol su ss ds) (Rec0 advised) k -> advised)
-> m (S1 ('MetaSel msymbol su ss ds) (Rec0 advised) k) -> m advised
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (K1 R advised k -> advised
forall i c k (p :: k). K1 i c p -> c
G.unK1 (K1 R advised k -> advised)
-> (S1 ('MetaSel msymbol su ss ds) (Rec0 advised) k
    -> K1 R advised k)
-> S1 ('MetaSel msymbol su ss ds) (Rec0 advised) k
-> advised
forall b c a. (b -> c) -> (a -> b) -> a -> c
. S1 ('MetaSel msymbol su ss ds) (Rec0 advised) k -> K1 R advised k
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
G.unM1))  e_ (DepT e_ m)
-> m (S1 ('MetaSel msymbol su ss ds) (Rec0 advised) k)
f)

-- Here we have dropped the polymorphic parameter in the last type argument.

type DistributiveSubcomponent :: RecordComponent -> ((Type -> Type) -> Type) -> (Type -> Type) -> Type -> Constraint
class DistributiveSubcomponent component_type e_ m sub where
  _distributeSubcomponent ::  (e_ (DepT e_ m) -> m sub) -> sub

instance
  ( 
    Functor m, 
    Multicurryable as e_ m r advised
  ) =>
  DistributiveSubcomponent Terminal e_ m advised
  where
  _distributeSubcomponent :: (e_ (DepT e_ m) -> m advised) -> advised
_distributeSubcomponent e_ (DepT e_ m) -> m advised
f = (e_ (DepT e_ m) -> m advised) -> advised
forall (as :: [*]) (e_ :: (* -> *) -> *) (m :: * -> *) r curried.
Multicurryable as e_ m r curried =>
(e_ (DepT e_ m) -> m curried) -> curried
askFinalDepT @as @e_ @m @r e_ (DepT e_ m) -> m advised
f

instance
  (
  Functor m,
  DistributiveSubcomponent (DiscriminateDistributiveSubcomponent advised) e_ m advised 
  ) =>
  DistributiveSubcomponent IWrapped e_ m (Identity advised)
  where
  _distributeSubcomponent :: (e_ (DepT e_ m) -> m (Identity advised)) -> Identity advised
_distributeSubcomponent e_ (DepT e_ m) -> m (Identity advised)
f = advised -> Identity advised
forall a. a -> Identity a
Identity ((e_ (DepT e_ m) -> m advised) -> advised
forall (component_type :: RecordComponent) (e_ :: (* -> *) -> *)
       (m :: * -> *) sub.
DistributiveSubcomponent component_type e_ m sub =>
(e_ (DepT e_ m) -> m sub) -> sub
_distributeSubcomponent @(DiscriminateDistributiveSubcomponent advised) @e_ @m ((m (Identity advised) -> m advised)
-> (e_ (DepT e_ m) -> m (Identity advised))
-> e_ (DepT e_ m)
-> m advised
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Identity advised -> advised) -> m (Identity advised) -> m advised
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Identity advised -> advised
forall a. Identity a -> a
runIdentity) e_ (DepT e_ m) -> m (Identity advised)
f))

instance
  (
  Functor m,
  DistributiveSubcomponent (DiscriminateDistributiveSubcomponent advised) e_ m advised 
  ) =>
  DistributiveSubcomponent IWrapped e_ m (I advised)
  where
  _distributeSubcomponent :: (e_ (DepT e_ m) -> m (I advised)) -> I advised
_distributeSubcomponent e_ (DepT e_ m) -> m (I advised)
f = advised -> I advised
forall a. a -> I a
I ((e_ (DepT e_ m) -> m advised) -> advised
forall (component_type :: RecordComponent) (e_ :: (* -> *) -> *)
       (m :: * -> *) sub.
DistributiveSubcomponent component_type e_ m sub =>
(e_ (DepT e_ m) -> m sub) -> sub
_distributeSubcomponent @(DiscriminateDistributiveSubcomponent advised) @e_ @m ((m (I advised) -> m advised)
-> (e_ (DepT e_ m) -> m (I advised)) -> e_ (DepT e_ m) -> m advised
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((I advised -> advised) -> m (I advised) -> m advised
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap I advised -> advised
forall a. I a -> a
unI) e_ (DepT e_ m) -> m (I advised)
f))

instance
    (DistributiveRecord e_ m subrecord)
    =>
    DistributiveSubcomponent Recurse e_ m (subrecord (DepT e_ m)) where
  _distributeSubcomponent :: (e_ (DepT e_ m) -> m (subrecord (DepT e_ m)))
-> subrecord (DepT e_ m)
_distributeSubcomponent e_ (DepT e_ m) -> m (subrecord (DepT e_ m))
f = (e_ (DepT e_ m) -> m (subrecord (DepT e_ m)))
-> subrecord (DepT e_ m)
forall (e_ :: (* -> *) -> *) (m :: * -> *)
       (record :: (* -> *) -> *).
DistributiveRecord e_ m record =>
(e_ (DepT e_ m) -> m (record (DepT e_ m))) -> record (DepT e_ m)
_distribute @e_ @m e_ (DepT e_ m) -> m (subrecord (DepT e_ m))
f

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

-- advising *all* fields of a record

--

--

type AdvisedRecord :: (Type -> Constraint) -> ((Type -> Type) -> 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 (DepT e_ m) -> advised (DepT e_ m)

type AdvisedProduct :: (Type -> Constraint) -> ((Type -> Type) -> 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 (DepT e_ m)),
    -- G.Rep (advised (DepT e_ m)) ~ G.D1 ('G.MetaData name mod p nt) (G.C1 y advised_),

    G.Rep (advised (DepT 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 (DepT e_ m)
-> advised (DepT e_ m)
_adviseRecord [(TypeRep, String)]
acc forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e_ m r
f advised (DepT e_ m)
unadvised =
    let G.M1 (G.M1 advised_ Any
unadvised_) = advised (DepT e_ m) -> Rep (advised (DepT e_ m)) Any
forall a x. Generic a => a -> Rep a x
G.from advised (DepT e_ m)
unadvised
        advised_ :: advised_ Any
advised_ = TypeRep
-> [(TypeRep, String)]
-> (forall r.
    cr r =>
    NonEmpty (TypeRep, String) -> Advice ca e_ m r)
-> advised_ Any
-> advised_ Any
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 (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 e_ m r
f advised_ Any
unadvised_
     in Rep (advised (DepT e_ m)) Any -> advised (DepT e_ 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 e_ m cr advised_left,
    AdvisedProduct ca e_ m cr advised_right
  ) =>
  AdvisedProduct ca e_ m cr (advised_left G.:*: advised_right)
  where
  _adviseProduct :: 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) = TypeRep
-> [(TypeRep, String)]
-> (forall r.
    cr r =>
    NonEmpty (TypeRep, String) -> Advice ca e_ m r)
-> advised_left k
-> advised_left k
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 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 e_ m r)
-> advised_right k
-> advised_right k
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 (a -> b) = Terminal
  DiscriminateAdvisedComponent (DepT e_ m x) = Terminal
  DiscriminateAdvisedComponent (Identity _) = IWrapped
  DiscriminateAdvisedComponent (I _) = IWrapped
  DiscriminateAdvisedComponent _ = Recurse

type AdvisedComponent :: RecordComponent -> (Type -> Constraint) -> ((Type -> Type) -> 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 :: 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, 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 e_ m r)
-> advised
-> advised
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 = Advice ca e_ m r -> 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 (NonEmpty (TypeRep, String) -> Advice ca e_ m r
forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e_ m r
f ([(TypeRep, String)] -> NonEmpty (TypeRep, String)
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) = advised -> Identity advised
forall a. a -> Identity a
Identity ([(TypeRep, String)]
-> (forall r.
    cr r =>
    NonEmpty (TypeRep, String) -> Advice ca e_ m r)
-> advised
-> advised
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) = advised -> I advised
forall a. a -> I a
I ([(TypeRep, String)]
-> (forall r.
    cr r =>
    NonEmpty (TypeRep, String) -> Advice ca e_ m r)
-> advised
-> advised
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 (DepT e_ m))
  where
  _adviseComponent :: [(TypeRep, String)]
-> (forall r.
    cr r =>
    NonEmpty (TypeRep, String) -> Advice ca e_ m r)
-> advisable (DepT e_ m)
-> advisable (DepT e_ m)
_adviseComponent [(TypeRep, String)]
acc forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e_ m r
f advisable (DepT e_ m)
advised = [(TypeRep, String)]
-> (forall r.
    cr r =>
    NonEmpty (TypeRep, String) -> Advice ca e_ m r)
-> advisable (DepT e_ m)
-> advisable (DepT e_ m)
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 (DepT e_ m)
-> advisable (DepT e_ m)
_adviseRecord @ca @e_ @m @cr [(TypeRep, String)]
acc forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e_ m r
f advisable (DepT 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 (DepT e_ m) ->
  -- | The advised record.

  advised (DepT e_ m)
adviseRecord :: (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e_ m r)
-> advised (DepT e_ m) -> advised (DepT e_ m)
adviseRecord = [(TypeRep, String)]
-> (forall r.
    cr r =>
    NonEmpty (TypeRep, String) -> Advice ca e_ m r)
-> advised (DepT e_ m)
-> advised (DepT e_ m)
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 (DepT e_ m)
-> advisable (DepT e_ m)
_adviseRecord @ca @e_ @m @cr []

-- $records

--

-- 'adviseRecord' and 'deceiveRecord' are versions of 'advise' and 'deceive' that, instead of working on bare

-- functions, transform entire records-of-functions in one go. They also work

-- 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

--     }

--   newtype Wraps x = Wraps x

--   env :: Env (DepT Env (Writer ()))

--   env =

--     let logger = Logger \_ -> pure ()

--         repository =

--           adviseRecord @Top @Top mempty $

--           deceiveRecord Wraps $

--           Repository {select = \_ -> pure [], insert = \_ -> pure ()}

--         controller =

--           adviseRecord @Top @Top mempty $

--           deceiveRecord Wraps $

--           Controller \_ -> pure "view"

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


-- $invocation

-- These functions are helpers for running 'DepT' computations, beyond what 'runDepT' provides.

--

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


-- | An advice that is polymorphic on the environment (allowing it to unify

-- with 'Control.Monad.Dep.NilEnv') can be converted to a "simple" 'Control.Monad.Dep.SimpleAdvice.Advice' that doesn't require 'Control.Monad.Dep.DepT' at all. 

toSimple :: Monad m => Advice ca NilEnv m r -> SA.Advice ca m r
toSimple :: Advice ca NilEnv m r -> Advice ca m r
toSimple (Advice forall (as :: [*]).
All ca as =>
NP I as
-> DepT NilEnv m (DepT NilEnv m r -> DepT NilEnv m r, NP I as)
f) = (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
SA.Advice \NP I as
args -> m (AspectT m r -> AspectT m r, NP I as)
-> AspectT m (AspectT m r -> AspectT m r, NP I as)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift do
    (DepT NilEnv m r -> DepT NilEnv m r
withExecution, NP I as
args') <- NP I as
-> DepT NilEnv m (DepT NilEnv m r -> DepT NilEnv m r, NP I as)
forall (as :: [*]).
All ca as =>
NP I as
-> DepT NilEnv m (DepT NilEnv m r -> DepT NilEnv m r, NP I as)
f NP I as
args DepT NilEnv m (DepT NilEnv m r -> DepT NilEnv m r, NP I as)
-> NilEnv (DepT NilEnv m)
-> m (DepT NilEnv m r -> DepT NilEnv m r, NP I as)
forall (e_ :: (* -> *) -> *) (m :: * -> *) r.
DepT e_ m r -> e_ (DepT e_ m) -> m r
`runDepT` NilEnv (DepT NilEnv m)
forall (m :: * -> *). NilEnv m
NilEnv
    let withExecution' :: AspectT m r -> AspectT m r
withExecution' = m r -> AspectT m r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m r -> AspectT m r)
-> (AspectT m r -> m r) -> AspectT m r -> AspectT m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DepT NilEnv m r -> NilEnv (DepT NilEnv m) -> m r)
-> NilEnv (DepT NilEnv m) -> DepT NilEnv m r -> m r
forall a b c. (a -> b -> c) -> b -> a -> c
flip DepT NilEnv m r -> NilEnv (DepT NilEnv m) -> m r
forall (e_ :: (* -> *) -> *) (m :: * -> *) r.
DepT e_ m r -> e_ (DepT e_ m) -> m r
runDepT NilEnv (DepT NilEnv m)
forall (m :: * -> *). NilEnv m
NilEnv (DepT NilEnv m r -> m r)
-> (AspectT m r -> DepT NilEnv m r) -> AspectT m r -> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DepT NilEnv m r -> DepT NilEnv m r
withExecution (DepT NilEnv m r -> DepT NilEnv m r)
-> (AspectT m r -> DepT NilEnv m r)
-> AspectT m r
-> DepT NilEnv m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m r -> DepT NilEnv m r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m r -> DepT NilEnv m r)
-> (AspectT m r -> m r) -> AspectT m r -> DepT NilEnv m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AspectT m r -> m r
forall (m :: * -> *) r. AspectT m r -> m r
SA.runAspectT
    (AspectT m r -> AspectT m r, NP I as)
-> 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
withExecution', NP I as
args')

-- | Convert a simple 'Control.Monad.Dep.SimpleAdvice.Advice' whose monad unifies with `DepT e_ m` into an 'Advice'.

fromSimple :: forall ca e_ m r. Monad m => (e_ (DepT e_ m) -> SA.Advice ca (DepT e_ m) r) -> Advice ca e_ m r
fromSimple :: (e_ (DepT e_ m) -> Advice ca (DepT e_ m) r) -> Advice ca e_ m r
fromSimple e_ (DepT e_ m) -> Advice ca (DepT e_ m) r
makeAdvice = (forall (as :: [*]).
 All ca as =>
 NP I as -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as))
-> Advice ca e_ m r
forall (ca :: * -> Constraint) (e_ :: (* -> *) -> *) (m :: * -> *)
       r.
(forall (as :: [*]).
 All ca as =>
 NP I as -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as))
-> Advice ca e_ m r
Advice \NP I as
args -> do
    e_ (DepT e_ m)
env <- DepT e_ m (e_ (DepT e_ m))
forall r (m :: * -> *). MonadReader r m => m r
ask
    case e_ (DepT e_ m) -> Advice ca (DepT e_ m) r
makeAdvice e_ (DepT e_ m)
env of
        SA.Advice forall (as :: [*]).
All ca as =>
NP I as
-> AspectT
     (DepT e_ m)
     (AspectT (DepT e_ m) r -> AspectT (DepT e_ m) r, NP I as)
f -> do
            let SA.AspectT DepT e_ m (AspectT (DepT e_ m) r -> AspectT (DepT e_ m) r, NP I as)
argsAction = NP I as
-> AspectT
     (DepT e_ m)
     (AspectT (DepT e_ m) r -> AspectT (DepT e_ m) r, NP I as)
forall (as :: [*]).
All ca as =>
NP I as
-> AspectT
     (DepT e_ m)
     (AspectT (DepT e_ m) r -> AspectT (DepT e_ m) r, NP I as)
f NP I as
args
            (AspectT (DepT e_ m) r -> AspectT (DepT e_ m) r
tweakExecution, NP I as
args') <- DepT e_ m (AspectT (DepT e_ m) r -> AspectT (DepT e_ m) r, NP I as)
argsAction
            (DepT e_ m r -> DepT e_ m r, NP I as)
-> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((AspectT (DepT e_ m) r -> AspectT (DepT e_ m) r)
-> DepT e_ m r -> DepT e_ m r
coerce AspectT (DepT e_ m) r -> AspectT (DepT e_ m) r
tweakExecution, NP I as
args')

-- | Like 'fromSimple', but for 'Control.Monad.Dep.SimpleAdvice.Advice's that don't use the environment.

fromSimple_ :: forall ca e_ m r. Monad m => SA.Advice ca (DepT e_ m) r -> Advice ca e_ m r
fromSimple_ :: Advice ca (DepT e_ m) r -> Advice ca e_ m r
fromSimple_ Advice ca (DepT e_ m) r
advice = (e_ (DepT e_ m) -> Advice ca (DepT e_ m) r) -> Advice ca e_ m r
forall (ca :: * -> Constraint) (e_ :: (* -> *) -> *) (m :: * -> *)
       r.
Monad m =>
(e_ (DepT e_ m) -> Advice ca (DepT e_ m) r) -> Advice ca e_ m r
fromSimple \e_ (DepT e_ m)
_ -> Advice ca (DepT e_ m) r
advice