{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoFieldSelectors #-}

module Cauldron.Args.Internal
  
where

import Cauldron.Beans (Beans, SomeMonoidTypeRep (..), fromDynList)
import Cauldron.Beans qualified
import Control.Exception (Exception, throw)
import Data.Dynamic
import Data.Foldable qualified
import Data.Function ((&))
import Data.Functor ((<&>))
import Data.Kind
import Data.Sequence (Seq)
import Data.Sequence qualified
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Typeable
import Type.Reflection (SomeTypeRep (..))
import Type.Reflection qualified

-- | An 'Applicative' that knows how to construct values by searching in a
-- 'Beans' map, and keeps track of the types that will be searched in the
-- 'Beans' map.
data Args a = Args
  { forall a. Args a -> Set SomeTypeRep
_argReps :: Set SomeTypeRep,
    forall a. Args a -> Set SomeMonoidTypeRep
_regReps :: Set SomeMonoidTypeRep,
    forall a. Args a -> (forall t. Typeable t => Maybe t) -> a
_runArgs :: (forall t. (Typeable t) => Maybe t) -> a
  }
  deriving stock ((forall a b. (a -> b) -> Args a -> Args b)
-> (forall a b. a -> Args b -> Args a) -> Functor Args
forall a b. a -> Args b -> Args a
forall a b. (a -> b) -> Args a -> Args b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Args a -> Args b
fmap :: forall a b. (a -> b) -> Args a -> Args b
$c<$ :: forall a b. a -> Args b -> Args a
<$ :: forall a b. a -> Args b -> Args a
Functor)

-- | Look for a type in the 'Beans' map and return its corresponding value.
--
-- >>> :{
-- fun1 :: Bool -> Int
-- fun1 _ = 5
-- w1 :: Args Int
-- w1 = fun1 <$> arg
-- fun2 :: String -> Bool -> Int
-- fun2 _ _ = 5
-- w2 :: Args Int
-- w2 = fun2 <$> arg <*> arg
-- :}
arg :: forall a. (Typeable a) => Args a
arg :: forall a. Typeable a => Args a
arg =
  let tr :: SomeTypeRep
tr = Proxy a -> SomeTypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)
   in Args
        { _argReps :: Set SomeTypeRep
_argReps = SomeTypeRep -> Set SomeTypeRep
forall a. a -> Set a
Set.singleton SomeTypeRep
tr,
          _regReps :: Set SomeMonoidTypeRep
_regReps = Set SomeMonoidTypeRep
forall a. Set a
Set.empty,
          _runArgs :: (forall t. Typeable t => Maybe t) -> a
_runArgs = \forall t. Typeable t => Maybe t
f ->
            case forall t. Typeable t => Maybe t
f @a of
              Just a
v -> a
v
              Maybe a
Nothing -> LazilyReadBeanMissing -> a
forall a e. Exception e => e -> a
throw (SomeTypeRep -> LazilyReadBeanMissing
LazilyReadBeanMissing SomeTypeRep
tr)
        }

-- | Here the 'Beans' map is not passed /directly/, instead, we pass a
-- function-like value that, given a type, will return a value of that type or
-- 'Nothing'. Such function is usually constructed using 'taste' on some 'Beans'
-- map.
--
-- >>> :{
-- let beans = fromDynList [toDyn @Int 5]
--  in runArgs (taste beans) (arg @Int)
-- :}
-- 5
--
-- See also 'LazilyReadBeanMissing'.
runArgs :: (forall b. (Typeable b) => Maybe b) -> Args a -> a
runArgs :: forall a. (forall t. Typeable t => Maybe t) -> Args a -> a
runArgs forall t. Typeable t => Maybe t
f (Args Set SomeTypeRep
_ Set SomeMonoidTypeRep
_ (forall t. Typeable t => Maybe t) -> a
_runArgs) =
  -- https://www.reddit.com/r/haskell/comments/16diti/comment/c7vc9ky/
  (forall t. Typeable t => Maybe t) -> a
_runArgs Maybe t
forall t. Typeable t => Maybe t
f

-- | Inspect ahead of time what types will be searched in the 'Beans' map.
--
-- >>> :{
-- let beans = fromDynList [toDyn @Int 5, toDyn False]
--     args = (,) <$> arg @Int <*> arg @Bool
--  in (getArgsReps args, runArgs (taste beans) args)
-- :}
-- (fromList [Int,Bool],(5,False))
getArgsReps :: Args a -> Set TypeRep
getArgsReps :: forall a. Args a -> Set SomeTypeRep
getArgsReps (Args {Set SomeTypeRep
_argReps :: forall a. Args a -> Set SomeTypeRep
_argReps :: Set SomeTypeRep
_argReps}) = Set SomeTypeRep
_argReps

-- | Tweak the look-by-type function that is eventually passed to 'runArgs'.
--
-- Unlikely to be commonly useful.
--
-- >>> :{
-- let tweak :: forall t. Typeable t => Maybe t -> Maybe t
--     tweak _ = case Type.Reflection.typeRep @t
--                    `Type.Reflection.eqTypeRep`
--                    Type.Reflection.typeRep @Int of
--                  Just HRefl -> Just 5
--                  Nothing -> Nothing
--  in runArgs (taste Cauldron.Beans.empty) $ contramapArgs tweak $ arg @Int
-- :}
-- 5
contramapArgs :: (forall t. (Typeable t) => Maybe t -> Maybe t) -> Args a -> Args a
contramapArgs :: forall a.
(forall t. Typeable t => Maybe t -> Maybe t) -> Args a -> Args a
contramapArgs forall t. Typeable t => Maybe t -> Maybe t
tweak args :: Args a
args@Args {(forall t. Typeable t => Maybe t) -> a
_runArgs :: forall a. Args a -> (forall t. Typeable t => Maybe t) -> a
_runArgs :: (forall t. Typeable t => Maybe t) -> a
_runArgs} = Args a
args {_runArgs = \forall t. Typeable t => Maybe t
f -> (forall t. Typeable t => Maybe t) -> a
_runArgs (Maybe t -> Maybe t
forall t. Typeable t => Maybe t -> Maybe t
tweak Maybe t
forall t. Typeable t => Maybe t
f)}

-- | Inspect ahead of time the types of registrations that might be contained in
-- the result value of an 'Args'.
--
-- >>> :{
-- let args = foretellReg @(Sum Int) *> pure ()
--  in getRegsReps args
-- :}
-- fromList [Sum Int]
getRegsReps :: Args a -> Set SomeMonoidTypeRep
getRegsReps :: forall a. Args a -> Set SomeMonoidTypeRep
getRegsReps (Args {Set SomeMonoidTypeRep
_regReps :: forall a. Args a -> Set SomeMonoidTypeRep
_regReps :: Set SomeMonoidTypeRep
_regReps}) = Set SomeMonoidTypeRep
_regReps

-- | This function is used in an 'Args' context to create a tell-like function
-- that can later be used to register a value into a 'Regs'.
--
-- The type of the future registration must be an instance of 'Monoid'.
--
-- There are no other ways of registering values into 'Regs'.
foretellReg :: forall a. (Typeable a, Monoid a) => Args (a -> Regs ())
foretellReg :: forall a. (Typeable a, Monoid a) => Args (a -> Regs ())
foretellReg =
  let tr :: SomeMonoidTypeRep
tr = TypeRep a -> SomeMonoidTypeRep
forall a. Monoid a => TypeRep a -> SomeMonoidTypeRep
SomeMonoidTypeRep (forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
Type.Reflection.typeRep @a)
   in Args
        { _argReps :: Set SomeTypeRep
_argReps = Set SomeTypeRep
forall a. Set a
Set.empty,
          _regReps :: Set SomeMonoidTypeRep
_regReps = SomeMonoidTypeRep -> Set SomeMonoidTypeRep
forall a. a -> Set a
Set.singleton SomeMonoidTypeRep
tr,
          _runArgs :: (forall t. Typeable t => Maybe t) -> a -> Regs ()
_runArgs = \forall t. Typeable t => Maybe t
_ a
a -> Seq Dynamic -> () -> Regs ()
forall a. Seq Dynamic -> a -> Regs a
Regs (Dynamic -> Seq Dynamic
forall a. a -> Seq a
Data.Sequence.singleton (a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn a
a)) ()
        }

instance Applicative Args where
  pure :: forall a. a -> Args a
pure a
a =
    Args
      { _argReps :: Set SomeTypeRep
_argReps = Set SomeTypeRep
forall a. Set a
Set.empty,
        _regReps :: Set SomeMonoidTypeRep
_regReps = Set SomeMonoidTypeRep
forall a. Set a
Set.empty,
        _runArgs :: (forall t. Typeable t => Maybe t) -> a
_runArgs = \forall t. Typeable t => Maybe t
_ -> a
a
      }
  Args
    { _argReps :: forall a. Args a -> Set SomeTypeRep
_argReps = Set SomeTypeRep
_argReps1,
      _regReps :: forall a. Args a -> Set SomeMonoidTypeRep
_regReps = Set SomeMonoidTypeRep
_regReps1,
      _runArgs :: forall a. Args a -> (forall t. Typeable t => Maybe t) -> a
_runArgs = (forall t. Typeable t => Maybe t) -> a -> b
f
    }
    <*> :: forall a b. Args (a -> b) -> Args a -> Args b
<*> Args
      { _argReps :: forall a. Args a -> Set SomeTypeRep
_argReps = Set SomeTypeRep
_argReps2,
        _regReps :: forall a. Args a -> Set SomeMonoidTypeRep
_regReps = Set SomeMonoidTypeRep
_regReps2,
        _runArgs :: forall a. Args a -> (forall t. Typeable t => Maybe t) -> a
_runArgs = (forall t. Typeable t => Maybe t) -> a
a
      } =
      Args
        { _argReps :: Set SomeTypeRep
_argReps = Set SomeTypeRep
_argReps1 Set SomeTypeRep -> Set SomeTypeRep -> Set SomeTypeRep
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set SomeTypeRep
_argReps2,
          _regReps :: Set SomeMonoidTypeRep
_regReps = Set SomeMonoidTypeRep
_regReps1 Set SomeMonoidTypeRep
-> Set SomeMonoidTypeRep -> Set SomeMonoidTypeRep
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set SomeMonoidTypeRep
_regReps2,
          _runArgs :: (forall t. Typeable t => Maybe t) -> b
_runArgs = \forall t. Typeable t => Maybe t
beans -> ((forall t. Typeable t => Maybe t) -> a -> b
f Maybe t
forall t. Typeable t => Maybe t
beans) ((forall t. Typeable t => Maybe t) -> a
a Maybe t
forall t. Typeable t => Maybe t
beans)
        }

someMonoidTypeRepToSomeTypeRep :: SomeMonoidTypeRep -> SomeTypeRep
someMonoidTypeRepToSomeTypeRep :: SomeMonoidTypeRep -> SomeTypeRep
someMonoidTypeRepToSomeTypeRep (SomeMonoidTypeRep TypeRep a
tr) = TypeRep a -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep a
tr

-- | A writer-like monad for collecting the values of registrations.
data Regs a = Regs (Seq Dynamic) a
  deriving stock ((forall a b. (a -> b) -> Regs a -> Regs b)
-> (forall a b. a -> Regs b -> Regs a) -> Functor Regs
forall a b. a -> Regs b -> Regs a
forall a b. (a -> b) -> Regs a -> Regs b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Regs a -> Regs b
fmap :: forall a b. (a -> b) -> Regs a -> Regs b
$c<$ :: forall a b. a -> Regs b -> Regs a
<$ :: forall a b. a -> Regs b -> Regs a
Functor)

-- | Extract the 'Beans' map of registrations, along with the main result value.
--
-- The 'Set' of 'SomeMonoidTypeRep's will typically come from 'getRegsReps'.
--
-- Only values for 'TypeRep's present in the set will be returned. There will be
-- values for all 'TypeRep's present in the set (some of them might be the
-- 'mempty' for that type).
runRegs :: Set SomeMonoidTypeRep -> Regs a -> (Beans, a)
runRegs :: forall a. Set SomeMonoidTypeRep -> Regs a -> (Beans, a)
runRegs Set SomeMonoidTypeRep
monoidReps (Regs Seq Dynamic
dyns a
a) =
  -- https://www.reddit.com/r/haskell/comments/16diti/comment/c7vc9ky/
  let onlyStaticlyKnown :: Beans
onlyStaticlyKnown =
        ( Set SomeMonoidTypeRep -> Beans
manyMemptys Set SomeMonoidTypeRep
monoidReps Beans -> [Beans] -> [Beans]
forall a. a -> [a] -> [a]
: do
            Dynamic
dyn <- Seq Dynamic -> [Dynamic]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Data.Foldable.toList Seq Dynamic
dyns
            -- This bit is subtle. I mistakenly used Cauldron.Beans.singleton here
            -- and ended up with the Dynamic type as the *key*. It was hell to debug.
            [[Dynamic] -> Beans
fromDynList [Dynamic
dyn]]
        )
          [Beans] -> ([Beans] -> Beans) -> Beans
forall a b. a -> (a -> b) -> b
& do (Beans -> Beans -> Beans) -> Beans -> [Beans] -> Beans
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Set SomeMonoidTypeRep -> Beans -> Beans -> Beans
Cauldron.Beans.unionBeansMonoidally Set SomeMonoidTypeRep
monoidReps) (forall a. Monoid a => a
mempty @Beans)
          Beans -> (Beans -> Beans) -> Beans
forall a b. a -> (a -> b) -> b
& do (Beans -> Set SomeTypeRep -> Beans)
-> Set SomeTypeRep -> Beans -> Beans
forall a b c. (a -> b -> c) -> b -> a -> c
flip Beans -> Set SomeTypeRep -> Beans
Cauldron.Beans.restrictKeys ((SomeMonoidTypeRep -> SomeTypeRep)
-> Set SomeMonoidTypeRep -> Set SomeTypeRep
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map SomeMonoidTypeRep -> SomeTypeRep
someMonoidTypeRepToSomeTypeRep Set SomeMonoidTypeRep
monoidReps)
   in (Beans
onlyStaticlyKnown, a
a)

instance Applicative Regs where
  pure :: forall a. a -> Regs a
pure a
a = Seq Dynamic -> a -> Regs a
forall a. Seq Dynamic -> a -> Regs a
Regs Seq Dynamic
forall a. Seq a
Data.Sequence.empty a
a
  Regs Seq Dynamic
w1 a -> b
f <*> :: forall a b. Regs (a -> b) -> Regs a -> Regs b
<*> Regs Seq Dynamic
w2 a
a2 =
    Seq Dynamic -> b -> Regs b
forall a. Seq Dynamic -> a -> Regs a
Regs (Seq Dynamic
w1 Seq Dynamic -> Seq Dynamic -> Seq Dynamic
forall a. Seq a -> Seq a -> Seq a
Data.Sequence.>< Seq Dynamic
w2) (a -> b
f a
a2)

instance Monad Regs where
  (Regs Seq Dynamic
w1 a
a) >>= :: forall a b. Regs a -> (a -> Regs b) -> Regs b
>>= a -> Regs b
k =
    let Regs Seq Dynamic
w2 b
r = a -> Regs b
k a
a
     in Seq Dynamic -> b -> Regs b
forall a. Seq Dynamic -> a -> Regs a
Regs (Seq Dynamic
w1 Seq Dynamic -> Seq Dynamic -> Seq Dynamic
forall a. Seq a -> Seq a -> Seq a
Data.Sequence.>< Seq Dynamic
w2) b
r

manyMemptys :: Set SomeMonoidTypeRep -> Beans
manyMemptys :: Set SomeMonoidTypeRep -> Beans
manyMemptys Set SomeMonoidTypeRep
reps =
  Set SomeMonoidTypeRep
reps
    Set SomeMonoidTypeRep
-> (Set SomeMonoidTypeRep -> [SomeMonoidTypeRep])
-> [SomeMonoidTypeRep]
forall a b. a -> (a -> b) -> b
& Set SomeMonoidTypeRep -> [SomeMonoidTypeRep]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Data.Foldable.toList
    [SomeMonoidTypeRep] -> (SomeMonoidTypeRep -> Dynamic) -> [Dynamic]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> SomeMonoidTypeRep -> Dynamic
Cauldron.Beans.someMonoidTypeRepMempty
    [Dynamic] -> ([Dynamic] -> Beans) -> Beans
forall a b. a -> (a -> b) -> b
& [Dynamic] -> Beans
fromDynList

-- | Imprecise exception that might lie hidden in the result of 'runArgs', if
-- the 'Beans' map lacks a value for some type demanded by the 'Args'.
--
-- Why not make 'runArgs' return a 'Maybe' instead of throwing an imprecise
-- exception? The answer is that, for my purposes, using 'Maybe' or 'Either'
-- caused undesirable strictness when doing weird things like reading values
-- \"from the future\".
--
-- >>> :{
-- runArgs (taste Cauldron.Beans.empty) (arg @Int)
-- :}
-- *** Exception: LazilyReadBeanMissing Int
--
-- If more safety is needed, one can perform additional preliminary checks with
-- the help of 'getArgsReps'.
newtype LazilyReadBeanMissing = LazilyReadBeanMissing TypeRep
  deriving stock (Int -> LazilyReadBeanMissing -> ShowS
[LazilyReadBeanMissing] -> ShowS
LazilyReadBeanMissing -> String
(Int -> LazilyReadBeanMissing -> ShowS)
-> (LazilyReadBeanMissing -> String)
-> ([LazilyReadBeanMissing] -> ShowS)
-> Show LazilyReadBeanMissing
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LazilyReadBeanMissing -> ShowS
showsPrec :: Int -> LazilyReadBeanMissing -> ShowS
$cshow :: LazilyReadBeanMissing -> String
show :: LazilyReadBeanMissing -> String
$cshowList :: [LazilyReadBeanMissing] -> ShowS
showList :: [LazilyReadBeanMissing] -> ShowS
Show)
  deriving anyclass (Show LazilyReadBeanMissing
Typeable LazilyReadBeanMissing
(Typeable LazilyReadBeanMissing, Show LazilyReadBeanMissing) =>
(LazilyReadBeanMissing -> SomeException)
-> (SomeException -> Maybe LazilyReadBeanMissing)
-> (LazilyReadBeanMissing -> String)
-> Exception LazilyReadBeanMissing
SomeException -> Maybe LazilyReadBeanMissing
LazilyReadBeanMissing -> String
LazilyReadBeanMissing -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: LazilyReadBeanMissing -> SomeException
toException :: LazilyReadBeanMissing -> SomeException
$cfromException :: SomeException -> Maybe LazilyReadBeanMissing
fromException :: SomeException -> Maybe LazilyReadBeanMissing
$cdisplayException :: LazilyReadBeanMissing -> String
displayException :: LazilyReadBeanMissing -> String
Exception)

-- | Convenience typeclass for wiring all the arguments of a curried function in one go.
class Wireable curried tip | curried -> tip where
  -- | Takes a curried function and reads all of its arguments by type using
  -- 'arg', returning an 'Args' for the final result value of the function.
  --
  -- >>> :{
  -- fun0 :: Int
  -- fun0 = 5
  -- w0 :: Args Int
  -- w0 = wire fun0
  -- fun1 :: Bool -> Int
  -- fun1 _ = 5
  -- w1 :: Args Int
  -- w1 = wire fun1
  -- fun2 :: String -> Bool -> Int
  -- fun2 _ _ = 5
  -- w2 :: Args Int
  -- w2 = wire fun2
  -- :}
  wire :: curried -> Args tip

instance (Wireable_ (IsFunction curried) curried tip) => Wireable curried tip where
  wire :: curried -> Args tip
wire curried
curried = Proxy (IsFunction curried) -> Args curried -> Args tip
forall (where_ :: Where) curried tip.
Wireable_ where_ curried tip =>
Proxy where_ -> Args curried -> Args tip
wire_ (forall {k} (t :: k). Proxy t
forall (t :: Where). Proxy t
Proxy @(IsFunction curried)) do curried -> Args curried
forall a. a -> Args a
forall (f :: * -> *) a. Applicative f => a -> f a
pure curried
curried

class Wireable_ (where_ :: Where) curried tip | where_ curried -> tip where
  wire_ :: Proxy where_ -> Args curried -> Args tip

instance Wireable_ AtTheTip a a where
  wire_ :: Proxy 'AtTheTip -> Args a -> Args a
wire_ Proxy 'AtTheTip
_ Args a
r = Args a
r

instance (Typeable b, Wireable_ (IsFunction rest) rest tip) => Wireable_ NotYetThere (b -> rest) tip where
  wire_ :: Proxy 'NotYetThere -> Args (b -> rest) -> Args tip
wire_ Proxy 'NotYetThere
_ Args (b -> rest)
af = Proxy (IsFunction rest) -> Args rest -> Args tip
forall (where_ :: Where) curried tip.
Wireable_ where_ curried tip =>
Proxy where_ -> Args curried -> Args tip
wire_ (forall {k} (t :: k). Proxy t
forall (t :: Where). Proxy t
Proxy @(IsFunction rest)) do Args (b -> rest)
af Args (b -> rest) -> Args b -> Args rest
forall a b. Args (a -> b) -> Args a -> Args b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Typeable a => Args a
arg @b

type IsFunction :: Type -> Where
type family IsFunction f :: Where where
  IsFunction (_ -> _) = 'NotYetThere
  IsFunction _ = 'AtTheTip

data Where
  = NotYetThere
  | AtTheTip

data WhereNested
  = Tup2
  | Tup3
  | Tup4
  | Innermost

type IsReg :: Type -> WhereNested
type family IsReg f :: WhereNested where
  IsReg (_, _) = 'Tup2
  IsReg (_, _, _) = 'Tup3
  IsReg (_, _, _, _) = 'Tup4
  IsReg _ = 'Innermost

-- | Convenience typeclass for automatically extracting registrations from a value.
-- Counterpart of 'Wireable' for registrations.
class Registrable nested tip | nested -> tip where
  -- | We look for (potentially nested) tuples in the value. All tuple
  -- components except the rightmost-innermost must have 'Monoid' instances, and
  -- are put into a 'Regs'.
  --
  -- >>> :{
  -- args :: Args (Identity (Sum Int, All, String))
  -- args = pure (Identity (Sum 5, All False, "foo"))
  -- registeredArgs :: Args (Identity (Regs String))
  -- registeredArgs = register args
  -- :}
  --
  -- >>> :{
  -- let reps = getRegsReps registeredArgs
  --  in ( reps == Data.Set.fromList [ SomeMonoidTypeRep $ Type.Reflection.typeRep @(Sum Int)
  --                                 , SomeMonoidTypeRep $ Type.Reflection.typeRep @All]
  --     , registeredArgs & runArgs (taste Cauldron.Beans.empty)
  --                      & runIdentity
  --                      & runRegs reps
  --                      & \(beans,_) -> (taste @(Sum Int) beans, taste @All beans)
  --     )
  -- :}
  -- (True,(Just (Sum {getSum = 5}),Just (All {getAll = False})))
  --
  -- Tuples can be nested:
  --
  -- >>> :{
  -- args :: Args (Identity (Sum Int, (All, String)))
  -- args = pure (Identity (Sum 5, (All False, "foo")))
  -- registeredArgs :: Args (Identity (Regs String))
  -- registeredArgs = register args
  -- :}
  --
  -- If there are no tuples in the result type, no values are put into 'Regs'.
  --
  -- >>> :{
  -- args :: Args (Identity String)
  -- args = pure (Identity "foo")
  -- registeredArgs :: Args (Identity (Regs String))
  -- registeredArgs = register args
  -- :}
  register :: forall m. (Functor m) => Args (m nested) -> Args (m (Regs tip))

instance (Registrable_ (IsReg nested) nested tip) => Registrable nested tip where
  register :: forall (m :: * -> *).
Functor m =>
Args (m nested) -> Args (m (Regs tip))
register Args (m nested)
amnested = Proxy (IsReg nested)
-> Args (m (Regs nested)) -> Args (m (Regs tip))
forall (where_ :: WhereNested) nested tip (m :: * -> *).
(Registrable_ where_ nested tip, Functor m) =>
Proxy where_ -> Args (m (Regs nested)) -> Args (m (Regs tip))
forall (m :: * -> *).
Functor m =>
Proxy (IsReg nested)
-> Args (m (Regs nested)) -> Args (m (Regs tip))
register_ (forall {k} (t :: k). Proxy t
forall (t :: WhereNested). Proxy t
Proxy @(IsReg nested)) do (m nested -> m (Regs nested))
-> Args (m nested) -> Args (m (Regs nested))
forall a b. (a -> b) -> Args a -> Args b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((nested -> Regs nested) -> m nested -> m (Regs nested)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap nested -> Regs nested
forall a. a -> Regs a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) Args (m nested)
amnested

class Registrable_ (where_ :: WhereNested) nested tip | where_ nested -> tip where
  register_ :: forall m. (Functor m) => Proxy where_ -> Args (m (Regs nested)) -> Args (m (Regs tip))

instance Registrable_ Innermost a a where
  register_ :: forall (m :: * -> *).
Functor m =>
Proxy 'Innermost -> Args (m (Regs a)) -> Args (m (Regs a))
register_ Proxy 'Innermost
_ = Args (m (Regs a)) -> Args (m (Regs a))
forall a. a -> a
id

instance (Typeable b, Monoid b, Registrable_ (IsReg rest) rest tip) => Registrable_ Tup2 (b, rest) tip where
  register_ :: forall (m :: * -> *).
Functor m =>
Proxy 'Tup2 -> Args (m (Regs (b, rest))) -> Args (m (Regs tip))
register_ Proxy 'Tup2
_ Args (m (Regs (b, rest)))
af =
    Proxy (IsReg rest) -> Args (m (Regs rest)) -> Args (m (Regs tip))
forall (where_ :: WhereNested) nested tip (m :: * -> *).
(Registrable_ where_ nested tip, Functor m) =>
Proxy where_ -> Args (m (Regs nested)) -> Args (m (Regs tip))
forall (m :: * -> *).
Functor m =>
Proxy (IsReg rest) -> Args (m (Regs rest)) -> Args (m (Regs tip))
register_ (forall {k} (t :: k). Proxy t
forall (t :: WhereNested). Proxy t
Proxy @(IsReg rest)) do
      b -> Regs ()
tell1 <- forall a. (Typeable a, Monoid a) => Args (a -> Regs ())
foretellReg @b
      m (Regs (b, rest))
action <- Args (m (Regs (b, rest)))
af
      pure (m (Regs (b, rest))
action m (Regs (b, rest))
-> (Regs (b, rest) -> Regs rest) -> m (Regs rest)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Regs (b, rest)
regs -> Regs (b, rest)
regs Regs (b, rest) -> ((b, rest) -> Regs rest) -> Regs rest
forall a b. Regs a -> (a -> Regs b) -> Regs b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(b
b, rest
rest) -> b -> Regs ()
tell1 b
b Regs () -> Regs rest -> Regs rest
forall a b. Regs a -> Regs b -> Regs b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> rest -> Regs rest
forall a. a -> Regs a
forall (f :: * -> *) a. Applicative f => a -> f a
pure rest
rest)

instance (Typeable b, Monoid b, Typeable c, Monoid c, Registrable_ (IsReg rest) rest tip) => Registrable_ Tup3 (b, c, rest) tip where
  register_ :: forall (m :: * -> *).
Functor m =>
Proxy 'Tup3 -> Args (m (Regs (b, c, rest))) -> Args (m (Regs tip))
register_ Proxy 'Tup3
_ Args (m (Regs (b, c, rest)))
af =
    Proxy (IsReg rest) -> Args (m (Regs rest)) -> Args (m (Regs tip))
forall (where_ :: WhereNested) nested tip (m :: * -> *).
(Registrable_ where_ nested tip, Functor m) =>
Proxy where_ -> Args (m (Regs nested)) -> Args (m (Regs tip))
forall (m :: * -> *).
Functor m =>
Proxy (IsReg rest) -> Args (m (Regs rest)) -> Args (m (Regs tip))
register_ (forall {k} (t :: k). Proxy t
forall (t :: WhereNested). Proxy t
Proxy @(IsReg rest)) do
      b -> Regs ()
tell1 <- forall a. (Typeable a, Monoid a) => Args (a -> Regs ())
foretellReg @b
      c -> Regs ()
tell2 <- forall a. (Typeable a, Monoid a) => Args (a -> Regs ())
foretellReg @c
      m (Regs (b, c, rest))
action <- Args (m (Regs (b, c, rest)))
af
      pure (m (Regs (b, c, rest))
action m (Regs (b, c, rest))
-> (Regs (b, c, rest) -> Regs rest) -> m (Regs rest)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Regs (b, c, rest)
regs -> Regs (b, c, rest)
regs Regs (b, c, rest) -> ((b, c, rest) -> Regs rest) -> Regs rest
forall a b. Regs a -> (a -> Regs b) -> Regs b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(b
b, c
c, rest
rest) -> b -> Regs ()
tell1 b
b Regs () -> Regs () -> Regs ()
forall a b. Regs a -> Regs b -> Regs b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> c -> Regs ()
tell2 c
c Regs () -> Regs rest -> Regs rest
forall a b. Regs a -> Regs b -> Regs b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> rest -> Regs rest
forall a. a -> Regs a
forall (f :: * -> *) a. Applicative f => a -> f a
pure rest
rest)

instance (Typeable b, Monoid b, Typeable c, Monoid c, Typeable d, Monoid d, Registrable_ (IsReg rest) rest tip) => Registrable_ Tup3 (b, c, d, rest) tip where
  register_ :: forall (m :: * -> *).
Functor m =>
Proxy 'Tup3
-> Args (m (Regs (b, c, d, rest))) -> Args (m (Regs tip))
register_ Proxy 'Tup3
_ Args (m (Regs (b, c, d, rest)))
af =
    Proxy (IsReg rest) -> Args (m (Regs rest)) -> Args (m (Regs tip))
forall (where_ :: WhereNested) nested tip (m :: * -> *).
(Registrable_ where_ nested tip, Functor m) =>
Proxy where_ -> Args (m (Regs nested)) -> Args (m (Regs tip))
forall (m :: * -> *).
Functor m =>
Proxy (IsReg rest) -> Args (m (Regs rest)) -> Args (m (Regs tip))
register_ (forall {k} (t :: k). Proxy t
forall (t :: WhereNested). Proxy t
Proxy @(IsReg rest)) do
      b -> Regs ()
tell1 <- forall a. (Typeable a, Monoid a) => Args (a -> Regs ())
foretellReg @b
      c -> Regs ()
tell2 <- forall a. (Typeable a, Monoid a) => Args (a -> Regs ())
foretellReg @c
      d -> Regs ()
tell3 <- forall a. (Typeable a, Monoid a) => Args (a -> Regs ())
foretellReg @d
      m (Regs (b, c, d, rest))
action <- Args (m (Regs (b, c, d, rest)))
af
      pure (m (Regs (b, c, d, rest))
action m (Regs (b, c, d, rest))
-> (Regs (b, c, d, rest) -> Regs rest) -> m (Regs rest)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Regs (b, c, d, rest)
regs -> Regs (b, c, d, rest)
regs Regs (b, c, d, rest) -> ((b, c, d, rest) -> Regs rest) -> Regs rest
forall a b. Regs a -> (a -> Regs b) -> Regs b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(b
b, c
c, d
d, rest
rest) -> b -> Regs ()
tell1 b
b Regs () -> Regs () -> Regs ()
forall a b. Regs a -> Regs b -> Regs b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> c -> Regs ()
tell2 c
c Regs () -> Regs () -> Regs ()
forall a b. Regs a -> Regs b -> Regs b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> d -> Regs ()
tell3 d
d Regs () -> Regs rest -> Regs rest
forall a b. Regs a -> Regs b -> Regs b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> rest -> Regs rest
forall a. a -> Regs a
forall (f :: * -> *) a. Applicative f => a -> f a
pure rest
rest)

-- $registrations
--
-- The 'Args' applicative has an additional feature: it lets you \"register\"
-- ahead of time the types of some values that /might/ be included in the result
-- of the 'Args', but without being reflected in the result type. It's not
-- mandatory that these values must be ultimately produced, however.
--
-- Here's an example. We have an 'Args' value that returns a 'Regs'. While
-- constructing the 'Args' value, we register the @Sum Int@ and @All@ types
-- using 'foretellReg', which also gives us the means of later writing into the
-- 'Regs'. By using 'getRegsReps', we can inspect the 'TypeRep's of the types we
-- registered without having to run the 'Args',
--
-- >>> :{
-- fun2 :: String -> Bool -> Int
-- fun2 _ _ = 5
-- args :: Args (Regs Int)
-- args = do -- Using ApplicativeDo
--   r <- fun2 <$> arg <*> arg -- could also have used 'wire'
--   tell1 <- foretellReg @(Sum Int)
--   tell2 <- foretellReg @All
--   pure $ do
--      tell1 (Sum 11)
--      tell2 (All False)
--      pure r
-- :}
--
-- >>> :{
-- let reps = getRegsReps args
--  in ( reps == Data.Set.fromList [ SomeMonoidTypeRep $ Type.Reflection.typeRep @(Sum Int)
--                                 , SomeMonoidTypeRep $ Type.Reflection.typeRep @All]
--     , args & runArgs (taste $ fromDynList [toDyn @String "foo", toDyn False])
--            & runRegs reps
--            & \(beans,_) -> (taste @(Sum Int) beans, taste @All beans)
--     )
-- :}
-- (True,(Just (Sum {getSum = 11}),Just (All {getAll = False})))

-- $setup
-- >>> :set -XBlockArguments
-- >>> :set -XOverloadedLists
-- >>> :set -XApplicativeDo
-- >>> :set -XGADTs
-- >>> :set -Wno-incomplete-uni-patterns
-- >>> import Data.Functor.Identity
-- >>> import Data.Function ((&))
-- >>> import Data.Monoid
-- >>> import Cauldron.Beans (taste)