{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NoFieldSelectors #-}

-- | This is a library for performing dependency injection. It's an alternative
-- to manually wiring your functions and passing all required parameters
-- explicitly. Instead of that, you throw your functions into a 'Cauldron', which wires
-- them for you, guiding itself by the types.
--
-- Wiring errors are detected at runtime, not at compile time.
--
-- This library should be used at the ["composition root"](https://stackoverflow.com/questions/6277771/what-is-a-composition-root-in-the-context-of-dependency-injection) of the application,
-- and only there: the components we are wiring together need not be aware that the library exists.
--
-- These extensions, while not required, play well with the library:
--
-- @
-- {-# LANGUAGE ApplicativeDo #-} -- For building complex values in the Args applicative.
-- {-# LANGUAGE OverloadedLists #-} -- For avoiding explicit calls to fromRecipeList and fromDecoList
-- @
--
-- An example of using a 'Cauldron' to wire the constructors of dummy @A@, @B@, @C@ datatypes:
--
-- >>> :{
-- data A = A deriving Show
-- data B = B deriving Show
-- data C = C deriving Show
-- makeA :: A
-- makeA = A
-- makeB :: A -> B
-- makeB = \_ -> B
-- makeC :: A -> B -> IO C
-- makeC = \_ _ -> pure C
-- :}
--
-- >>> :{
-- do
--   let cauldron :: Cauldron IO
--       cauldron = [
--           recipe @A $ val $ wire makeA,
--           recipe @B $ val $ wire makeB,
--           recipe @C $ eff $ wire makeC -- we use eff because the constructor has IO effects
--         ]
--   action <- either throwIO pure $ cook forbidDepCycles cauldron
--   beans <- action
--   pure $ taste @C beans
-- :}
-- Just C
module Cauldron
  ( -- * Filling the cauldron
    Cauldron,
    empty,
    insert,
    adjust,
    delete,
    keysSet,
    restrictKeys,
    fromRecipeList,
    toRecipeMap,
    hoistCauldron,
    hoistCauldron',

    -- * Recipes
    Recipe (..),
    ToRecipe,
    fromDecoList,
    (Data.Sequence.|>),
    (Data.Sequence.<|),
    hoistRecipe,
    hoistRecipe',

    -- ** How decorators work
    -- $decos

    -- ** Hiding a 'Recipe''s bean type
    SomeRecipe,
    recipe,
    withRecipe,
    getRecipeCallStack,

    -- * Constructors
    -- $constructors
    Constructor,
    val_,
    val,
    val',
    eff_,
    ioEff_,
    eff,
    ioEff,
    eff',
    wire,
    getConstructorArgs,
    getConstructorCallStack,
    hoistConstructor,
    hoistConstructor',

    -- ** Registering secondary beans
    -- $secondarybeans

    -- * Cooking the beans
    cook,
    cookNonEmpty,
    cookTree,

    -- ** How loopy can we get?
    Fire,
    forbidDepCycles,
    allowSelfDeps,
    allowDepCycles,

    -- ** Tasting the results
    Beans,
    taste,

    -- ** When things go wrong
    RecipeError (..),
    MissingDependencies (..),
    DoubleDutyBeans (..),
    DependencyCycle (..),
    prettyRecipeError,
    prettyRecipeErrorLines,

    -- ** Visualizing dependencies between beans.
    getDependencyGraph,
    DependencyGraph,
    writeAsDot,
    defaultStyle,
    setVertexName,
    BeanConstructionStep (..),
    toAdjacencyMap,

    -- *** Simplifying the dep graph
    -- $simplifygraph
    removeSecondaryBeans,
    removeDecos,
    collapseToPrimaryBeans,
  )
where

import Algebra.Graph.AdjacencyMap (AdjacencyMap)
import Algebra.Graph.AdjacencyMap qualified as Graph
import Algebra.Graph.AdjacencyMap.Algorithm qualified as Graph
import Algebra.Graph.Export.Dot qualified as Dot
import Cauldron.Args
import Cauldron.Beans (SomeMonoidTypeRep (..))
import Cauldron.Beans qualified
import Control.Exception (Exception (..))
import Control.Monad.Fix
import Control.Monad.IO.Class
import Data.Bifunctor (first)
import Data.ByteString qualified
import Data.Dynamic
import Data.Foldable qualified
import Data.Function ((&))
import Data.Functor ((<&>))
import Data.Functor.Identity (Identity (..))
import Data.Kind
import Data.List qualified
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty qualified
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (fromJust)
import Data.Semigroup qualified
import Data.Sequence (Seq)
import Data.Sequence qualified
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text qualified
import Data.Text.Encoding qualified
import Data.Tree
import Data.Type.Equality (testEquality)
import Data.Typeable
import GHC.Exception (CallStack, prettyCallStackLines)
import GHC.IsList
import GHC.Stack (HasCallStack, callStack, withFrozenCallStack)
import Type.Reflection qualified

-- | A map of bean recipes, indexed by the 'TypeRep' of the bean each recipe
-- ultimately produces. Only one recipe is allowed for each bean type.
-- Parameterized by the monad @m@ in which the recipe 'Constructor's might have
-- effects.
type Cauldron :: (Type -> Type) -> Type
newtype Cauldron m where
  Cauldron :: {forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeRecipe m)
recipeMap :: Map TypeRep (SomeRecipe m)} -> Cauldron m

empty :: Cauldron m
empty :: forall (m :: * -> *). Cauldron m
empty = Map TypeRep (SomeRecipe m) -> Cauldron m
forall (m :: * -> *). Map TypeRep (SomeRecipe m) -> Cauldron m
Cauldron Map TypeRep (SomeRecipe m)
forall k a. Map k a
Map.empty

-- | Union of two 'Cauldron's, right-biased: prefers 'Recipe's from the /right/ cauldron when
-- both contain the same key. (Note that 'Data.Map.Map' is left-biased.)
instance Semigroup (Cauldron m) where
  Cauldron {recipeMap :: forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeRecipe m)
recipeMap = Map TypeRep (SomeRecipe m)
r1} <> :: Cauldron m -> Cauldron m -> Cauldron m
<> Cauldron {recipeMap :: forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeRecipe m)
recipeMap = Map TypeRep (SomeRecipe m)
r2} = Map TypeRep (SomeRecipe m) -> Cauldron m
forall (m :: * -> *). Map TypeRep (SomeRecipe m) -> Cauldron m
Cauldron do (SomeRecipe m -> SomeRecipe m -> SomeRecipe m)
-> Map TypeRep (SomeRecipe m)
-> Map TypeRep (SomeRecipe m)
-> Map TypeRep (SomeRecipe m)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith ((SomeRecipe m -> SomeRecipe m -> SomeRecipe m)
-> SomeRecipe m -> SomeRecipe m -> SomeRecipe m
forall a b c. (a -> b -> c) -> b -> a -> c
flip SomeRecipe m -> SomeRecipe m -> SomeRecipe m
forall a b. a -> b -> a
const) Map TypeRep (SomeRecipe m)
r1 Map TypeRep (SomeRecipe m)
r2

instance Monoid (Cauldron m) where
  mempty :: Cauldron m
mempty = Map TypeRep (SomeRecipe m) -> Cauldron m
forall (m :: * -> *). Map TypeRep (SomeRecipe m) -> Cauldron m
Cauldron Map TypeRep (SomeRecipe m)
forall k a. Map k a
Map.empty

instance IsList (Cauldron m) where
  type Item (Cauldron m) = SomeRecipe m
  toList :: Cauldron m -> [Item (Cauldron m)]
toList (Cauldron {Map TypeRep (SomeRecipe m)
recipeMap :: forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeRecipe m)
recipeMap :: Map TypeRep (SomeRecipe m)
recipeMap}) = Map TypeRep (SomeRecipe m) -> [SomeRecipe m]
forall k a. Map k a -> [a]
Map.elems Map TypeRep (SomeRecipe m)
recipeMap
  fromList :: [Item (Cauldron m)] -> Cauldron m
fromList = [Item (Cauldron m)] -> Cauldron m
[SomeRecipe m] -> Cauldron m
forall (m :: * -> *). [SomeRecipe m] -> Cauldron m
fromRecipeList

-- | Change the monad used by the 'Recipe's in the 'Cauldron'.
hoistCauldron :: (forall x. m x -> n x) -> Cauldron m -> Cauldron n
hoistCauldron :: forall (m :: * -> *) (n :: * -> *).
(forall x. m x -> n x) -> Cauldron m -> Cauldron n
hoistCauldron forall x. m x -> n x
f (Cauldron {Map TypeRep (SomeRecipe m)
recipeMap :: forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeRecipe m)
recipeMap :: Map TypeRep (SomeRecipe m)
recipeMap}) = Cauldron {recipeMap :: Map TypeRep (SomeRecipe n)
recipeMap = (forall x. m x -> n x) -> SomeRecipe m -> SomeRecipe n
forall (m :: * -> *) (n :: * -> *).
(forall x. m x -> n x) -> SomeRecipe m -> SomeRecipe n
hoistSomeRecipe m x -> n x
forall x. m x -> n x
f (SomeRecipe m -> SomeRecipe n)
-> Map TypeRep (SomeRecipe m) -> Map TypeRep (SomeRecipe n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map TypeRep (SomeRecipe m)
recipeMap}

-- | More general form of 'hoistCauldron' that lets you modify the 'Args'
-- inside all the 'Recipe's in the 'Cauldron'. See 'hoistRecipe''.
hoistCauldron' ::
  -- | Transformation to apply to the base constructor of each recipe.
  (forall x. (Typeable x) => Args (m (Regs x)) -> Args (n (Regs x))) ->
  -- | Transformation to apply to each decorator. Takes the decorator index as parameter.
  (forall x. (Typeable x) => Int -> Args (m (Regs x)) -> Args (n (Regs x))) ->
  Cauldron m ->
  Cauldron n
hoistCauldron' :: forall (m :: * -> *) (n :: * -> *).
(forall x. Typeable x => Args (m (Regs x)) -> Args (n (Regs x)))
-> (forall x.
    Typeable x =>
    Int -> Args (m (Regs x)) -> Args (n (Regs x)))
-> Cauldron m
-> Cauldron n
hoistCauldron' forall x. Typeable x => Args (m (Regs x)) -> Args (n (Regs x))
f forall x.
Typeable x =>
Int -> Args (m (Regs x)) -> Args (n (Regs x))
fds Cauldron {Map TypeRep (SomeRecipe m)
recipeMap :: forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeRecipe m)
recipeMap :: Map TypeRep (SomeRecipe m)
recipeMap} =
  Cauldron
    { recipeMap :: Map TypeRep (SomeRecipe n)
recipeMap = (SomeRecipe m -> SomeRecipe n)
-> Map TypeRep (SomeRecipe m) -> Map TypeRep (SomeRecipe n)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((forall x. Typeable x => Args (m (Regs x)) -> Args (n (Regs x)))
-> (forall x.
    Typeable x =>
    Int -> Args (m (Regs x)) -> Args (n (Regs x)))
-> SomeRecipe m
-> SomeRecipe n
forall (m :: * -> *) (n :: * -> *).
(forall x. Typeable x => Args (m (Regs x)) -> Args (n (Regs x)))
-> (forall x.
    Typeable x =>
    Int -> Args (m (Regs x)) -> Args (n (Regs x)))
-> SomeRecipe m
-> SomeRecipe n
hoistSomeRecipe' Args (m (Regs x)) -> Args (n (Regs x))
forall x. Typeable x => Args (m (Regs x)) -> Args (n (Regs x))
f Int -> Args (m (Regs x)) -> Args (n (Regs x))
forall x.
Typeable x =>
Int -> Args (m (Regs x)) -> Args (n (Regs x))
fds) Map TypeRep (SomeRecipe m)
recipeMap
    }

-- | In order to put recipes producing different bean types into a container, we
-- need to hide each recipe's bean type. This wrapper allows that.
type SomeRecipe :: (Type -> Type) -> Type
data SomeRecipe m where
  SomeRecipe :: (Typeable bean) => {forall (m :: * -> *). SomeRecipe m -> CallStack
_recipeCallStack :: CallStack, ()
_recipe :: Recipe m bean} -> SomeRecipe m

-- | Build a 'SomeRecipe' from a 'Recipe' or a 'Constructor'. See 'ToRecipe'.
--
-- Useful in combination with 'fromRecipeList'.
recipe ::
  forall {recipelike} {m} bean.
  (ToRecipe recipelike, Typeable bean, HasCallStack) =>
  -- | A 'Recipe' or a 'Constructor'.
  recipelike m bean ->
  SomeRecipe m
recipe :: forall {recipelike :: (* -> *) -> * -> *} {m :: * -> *} bean.
(ToRecipe recipelike, Typeable bean, HasCallStack) =>
recipelike m bean -> SomeRecipe m
recipe recipelike m bean
theRecipe = (HasCallStack => SomeRecipe m) -> SomeRecipe m
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
  CallStack -> Recipe m bean -> SomeRecipe m
forall bean (m :: * -> *).
Typeable bean =>
CallStack -> Recipe m bean -> SomeRecipe m
SomeRecipe CallStack
HasCallStack => CallStack
callStack (recipelike m bean -> Recipe m bean
forall (m :: * -> *) bean. recipelike m bean -> Recipe m bean
forall (recipelike :: (* -> *) -> * -> *) (m :: * -> *) bean.
ToRecipe recipelike =>
recipelike m bean -> Recipe m bean
toRecipe recipelike m bean
theRecipe)

-- | Access the 'Recipe' inside a 'SomeRecipe'.
withRecipe :: forall {m} r. (forall bean. (Typeable bean) => Recipe m bean -> r) -> SomeRecipe m -> r
withRecipe :: forall {m :: * -> *} r.
(forall bean. Typeable bean => Recipe m bean -> r)
-> SomeRecipe m -> r
withRecipe forall bean. Typeable bean => Recipe m bean -> r
f (SomeRecipe {Recipe m bean
_recipe :: ()
_recipe :: Recipe m bean
_recipe}) = Recipe m bean -> r
forall bean. Typeable bean => Recipe m bean -> r
f Recipe m bean
_recipe

getRecipeRep :: SomeRecipe m -> TypeRep
getRecipeRep :: forall (m :: * -> *). SomeRecipe m -> TypeRep
getRecipeRep = (forall bean. Typeable bean => Recipe m bean -> TypeRep)
-> SomeRecipe m -> TypeRep
forall {m :: * -> *} r.
(forall bean. Typeable bean => Recipe m bean -> r)
-> SomeRecipe m -> r
withRecipe Recipe m bean -> TypeRep
forall bean. Typeable bean => Recipe m bean -> TypeRep
forall bean (m :: * -> *).
Typeable bean =>
Recipe m bean -> TypeRep
go
  where
    go :: forall bean m. (Typeable bean) => Recipe m bean -> TypeRep
    go :: forall bean (m :: * -> *).
Typeable bean =>
Recipe m bean -> TypeRep
go Recipe m bean
_ = Proxy bean -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @bean)

fromRecipeList :: [SomeRecipe m] -> Cauldron m
fromRecipeList :: forall (m :: * -> *). [SomeRecipe m] -> Cauldron m
fromRecipeList =
  (SomeRecipe m -> Cauldron m) -> [SomeRecipe m] -> Cauldron m
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap \SomeRecipe m
sr -> Cauldron {recipeMap :: Map TypeRep (SomeRecipe m)
recipeMap = TypeRep -> SomeRecipe m -> Map TypeRep (SomeRecipe m)
forall k a. k -> a -> Map k a
Map.singleton (SomeRecipe m -> TypeRep
forall (m :: * -> *). SomeRecipe m -> TypeRep
getRecipeRep SomeRecipe m
sr) SomeRecipe m
sr}

toRecipeMap :: Cauldron m -> Map TypeRep (SomeRecipe m)
toRecipeMap :: forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeRecipe m)
toRecipeMap Cauldron {Map TypeRep (SomeRecipe m)
recipeMap :: forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeRecipe m)
recipeMap :: Map TypeRep (SomeRecipe m)
recipeMap} = Map TypeRep (SomeRecipe m)
recipeMap

hoistSomeRecipe :: (forall x. m x -> n x) -> SomeRecipe m -> SomeRecipe n
hoistSomeRecipe :: forall (m :: * -> *) (n :: * -> *).
(forall x. m x -> n x) -> SomeRecipe m -> SomeRecipe n
hoistSomeRecipe forall x. m x -> n x
f r :: SomeRecipe m
r@SomeRecipe {Recipe m bean
_recipe :: ()
_recipe :: Recipe m bean
_recipe} = SomeRecipe m
r {_recipe = hoistRecipe f _recipe}

hoistSomeRecipe' ::
  forall m n.
  (forall x. (Typeable x) => Args (m (Regs x)) -> Args (n (Regs x))) ->
  (forall x. (Typeable x) => Int -> Args (m (Regs x)) -> Args (n (Regs x))) ->
  SomeRecipe m ->
  SomeRecipe n
hoistSomeRecipe' :: forall (m :: * -> *) (n :: * -> *).
(forall x. Typeable x => Args (m (Regs x)) -> Args (n (Regs x)))
-> (forall x.
    Typeable x =>
    Int -> Args (m (Regs x)) -> Args (n (Regs x)))
-> SomeRecipe m
-> SomeRecipe n
hoistSomeRecipe' forall x. Typeable x => Args (m (Regs x)) -> Args (n (Regs x))
f forall x.
Typeable x =>
Int -> Args (m (Regs x)) -> Args (n (Regs x))
fds SomeRecipe m
sr = (forall bean. Typeable bean => Recipe m bean -> SomeRecipe n)
-> SomeRecipe m -> SomeRecipe n
forall {m :: * -> *} r.
(forall bean. Typeable bean => Recipe m bean -> r)
-> SomeRecipe m -> r
withRecipe Recipe m bean -> SomeRecipe n
forall bean. Typeable bean => Recipe m bean -> SomeRecipe n
go SomeRecipe m
sr
  where
    go :: forall bean. (Typeable bean) => Recipe m bean -> SomeRecipe n
    go :: forall bean. Typeable bean => Recipe m bean -> SomeRecipe n
go Recipe m bean
r = SomeRecipe m
sr {_recipe = hoistRecipe' (f @bean) (fds @bean) r}

-- | Instructions for how to build a value of type @bean@ while possibly
-- performing actions in the monad @m@.
--
-- Because the instructions aren't really run until the 'Cauldron' is 'cook'ed,
-- they can be modified with functions like 'adjust', in order to change the
-- base bean 'Constructor', or add or remove decorators.
type Recipe :: (Type -> Type) -> Type -> Type
data Recipe m bean = Recipe
  { -- | How to build the bean itself.
    forall (m :: * -> *) bean. Recipe m bean -> Constructor m bean
bean :: Constructor m bean,
    -- | A 'Data.Sequence.Sequence' of decorators that will wrap the bean. There might be no decorators.
    --
    -- See 'fromDecoList', 'Data.Sequence.|>' and 'Data.Sequence.<|'.
    forall (m :: * -> *) bean.
Recipe m bean -> Seq (Constructor m bean)
decos :: Seq (Constructor m bean)
  }

fromDecoList :: [Constructor m bean] -> Seq (Constructor m bean)
fromDecoList :: forall (m :: * -> *) bean.
[Constructor m bean] -> Seq (Constructor m bean)
fromDecoList = [Constructor m bean] -> Seq (Constructor m bean)
forall a. [a] -> Seq a
Data.Sequence.fromList

-- | Convenience typeclass that allows passing either 'Recipe's or 'Constructor's
-- to the 'insert' and 'recipe' functions.
type ToRecipe :: ((Type -> Type) -> Type -> Type) -> Constraint
class ToRecipe recipelike where
  toRecipe :: recipelike m bean -> Recipe m bean

-- | Simply identity.
instance ToRecipe Recipe where
  toRecipe :: forall (m :: * -> *) bean. Recipe m bean -> Recipe m bean
toRecipe = Recipe m bean -> Recipe m bean
forall a. a -> a
id

-- | 'Constructor' is converted to a 'Recipe' without decorators.
instance ToRecipe Constructor where
  toRecipe :: forall (m :: * -> *) bean. Constructor m bean -> Recipe m bean
toRecipe Constructor m bean
bean = Recipe {Constructor m bean
bean :: Constructor m bean
bean :: Constructor m bean
bean, decos :: Seq (Constructor m bean)
decos = Seq (Constructor m bean)
forall a. Seq a
Data.Sequence.empty}

-- | Change the monad used by the bean\'s main 'Constructor' and its decos.
hoistRecipe :: (forall x. m x -> n x) -> Recipe m bean -> Recipe n bean
hoistRecipe :: forall (m :: * -> *) (n :: * -> *) bean.
(forall x. m x -> n x) -> Recipe m bean -> Recipe n bean
hoistRecipe forall x. m x -> n x
f (Recipe {Constructor m bean
bean :: forall (m :: * -> *) bean. Recipe m bean -> Constructor m bean
bean :: Constructor m bean
bean, Seq (Constructor m bean)
decos :: forall (m :: * -> *) bean.
Recipe m bean -> Seq (Constructor m bean)
decos :: Seq (Constructor m bean)
decos}) =
  Recipe
    { bean :: Constructor n bean
bean = (forall x. m x -> n x) -> Constructor m bean -> Constructor n bean
forall (m :: * -> *) (n :: * -> *) bean.
(forall x. m x -> n x) -> Constructor m bean -> Constructor n bean
hoistConstructor m x -> n x
forall x. m x -> n x
f Constructor m bean
bean,
      decos :: Seq (Constructor n bean)
decos = (forall x. m x -> n x) -> Constructor m bean -> Constructor n bean
forall (m :: * -> *) (n :: * -> *) bean.
(forall x. m x -> n x) -> Constructor m bean -> Constructor n bean
hoistConstructor m x -> n x
forall x. m x -> n x
f (Constructor m bean -> Constructor n bean)
-> Seq (Constructor m bean) -> Seq (Constructor n bean)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq (Constructor m bean)
decos
    }

-- | More general form of 'hoistRecipe' that enables precise control over the inner `Args`
-- of each constructor in the 'Recipe'.
hoistRecipe' ::
  -- | Transformation to apply to the base constructor.
  (Args (m (Regs bean)) -> Args (n (Regs bean))) ->
  -- | Transformation to apply to each decorator. Takes the decorator index as parameter.
  (Int -> Args (m (Regs bean)) -> Args (n (Regs bean))) ->
  Recipe m bean ->
  Recipe n bean
hoistRecipe' :: forall (m :: * -> *) bean (n :: * -> *).
(Args (m (Regs bean)) -> Args (n (Regs bean)))
-> (Int -> Args (m (Regs bean)) -> Args (n (Regs bean)))
-> Recipe m bean
-> Recipe n bean
hoistRecipe' Args (m (Regs bean)) -> Args (n (Regs bean))
f Int -> Args (m (Regs bean)) -> Args (n (Regs bean))
fds (Recipe {Constructor m bean
bean :: forall (m :: * -> *) bean. Recipe m bean -> Constructor m bean
bean :: Constructor m bean
bean, Seq (Constructor m bean)
decos :: forall (m :: * -> *) bean.
Recipe m bean -> Seq (Constructor m bean)
decos :: Seq (Constructor m bean)
decos}) =
  Recipe
    { bean :: Constructor n bean
bean = (Args (m (Regs bean)) -> Args (n (Regs bean)))
-> Constructor m bean -> Constructor n bean
forall (m :: * -> *) bean (n :: * -> *).
(Args (m (Regs bean)) -> Args (n (Regs bean)))
-> Constructor m bean -> Constructor n bean
hoistConstructor' Args (m (Regs bean)) -> Args (n (Regs bean))
f Constructor m bean
bean,
      decos :: Seq (Constructor n bean)
decos = (Int -> Constructor m bean -> Constructor n bean)
-> Seq (Constructor m bean) -> Seq (Constructor n bean)
forall a b. (Int -> a -> b) -> Seq a -> Seq b
Data.Sequence.mapWithIndex (\Int
i Constructor m bean
deco -> (Args (m (Regs bean)) -> Args (n (Regs bean)))
-> Constructor m bean -> Constructor n bean
forall (m :: * -> *) bean (n :: * -> *).
(Args (m (Regs bean)) -> Args (n (Regs bean)))
-> Constructor m bean -> Constructor n bean
hoistConstructor' (Int -> Args (m (Regs bean)) -> Args (n (Regs bean))
fds Int
i) Constructor m bean
deco) Seq (Constructor m bean)
decos
    }

-- $decos
--
-- Decorators are 'Constructor's which, instead constructing the original
-- version of a bean, they modify it in some way (but without changing its
-- type). Because they modify the bean, typically decorators will take the bean
-- as an argument.
--
-- Decorators can have other dependencies beyond the modified bean.
--
-- When the bean is a record-of-functions, decorators can be used to
-- add behaviors like caching and logging to the functions.
--
-- The order of the decorators in the sequence is the order in which they modify
-- the underlying bean. First decorator wraps first, last decorator wraps last.
--
-- >>> :{
-- newtype Foo = Foo { sayFoo :: IO () }
-- makeFoo :: Foo
-- makeFoo = Foo { sayFoo = putStrLn "foo" }
-- makeFooDeco1 :: Foo -> Foo
-- makeFooDeco1 Foo { sayFoo } = Foo { sayFoo = putStrLn "deco1 enter" >> sayFoo >> putStrLn "deco1 exit" }
-- makeFooDeco2 :: Foo -> IO Foo
-- makeFooDeco2 Foo { sayFoo } = putStrLn "deco2 init" >> pure Foo { sayFoo = putStrLn "deco2 enter" >> sayFoo >> putStrLn "deco2 exit" }
-- :}
--
-- >>> :{
-- do
--   let cauldron :: Cauldron IO
--       cauldron = [
--           recipe @Foo $ Recipe {
--             bean = val $ wire makeFoo,
--             decos = [
--                  val $ wire makeFooDeco1,
--                  eff $ wire makeFooDeco2
--               ]
--           }
--         ]
--   action <- either throwIO pure $ cook forbidDepCycles cauldron
--   beans <- action
--   let Just Foo {sayFoo} = taste beans
--   sayFoo
-- :}
-- deco2 init
-- deco2 enter
-- deco1 enter
-- foo
-- deco1 exit
-- deco2 exit

-- $constructors
--
-- Bean-producing and bean-decorating functions need to be coaxed into 'Constructor's in order to be used in 'Cauldron's.

data ConstructorReps where
  ConstructorReps ::
    { ConstructorReps -> TypeRep
beanRep :: TypeRep,
      ConstructorReps -> Set TypeRep
argReps :: Set TypeRep,
      ConstructorReps -> Map TypeRep Dynamic
regReps :: Map TypeRep Dynamic
    } ->
    ConstructorReps

-- | Put a 'Recipe' into the 'Cauldron'.
--
-- Only one recipe is allowed for each bean type, so 'insert' for a
-- bean will overwrite any previous recipe for that bean.
insert ::
  forall {recipelike} {m} (bean :: Type).
  (Typeable bean, ToRecipe recipelike, HasCallStack) =>
  -- | A 'Recipe' or a 'Constructor'.
  recipelike m bean ->
  Cauldron m ->
  Cauldron m
insert :: forall {recipelike :: (* -> *) -> * -> *} {m :: * -> *} bean.
(Typeable bean, ToRecipe recipelike, HasCallStack) =>
recipelike m bean -> Cauldron m -> Cauldron m
insert recipelike m bean
recipelike Cauldron {Map TypeRep (SomeRecipe m)
recipeMap :: forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeRecipe m)
recipeMap :: Map TypeRep (SomeRecipe m)
recipeMap} = (HasCallStack => Cauldron m) -> Cauldron m
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
  let rep :: TypeRep
rep = Proxy bean -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @bean)
  Cauldron {recipeMap :: Map TypeRep (SomeRecipe m)
recipeMap = TypeRep
-> SomeRecipe m
-> Map TypeRep (SomeRecipe m)
-> Map TypeRep (SomeRecipe m)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeRep
rep (CallStack -> Recipe m bean -> SomeRecipe m
forall bean (m :: * -> *).
Typeable bean =>
CallStack -> Recipe m bean -> SomeRecipe m
SomeRecipe CallStack
HasCallStack => CallStack
callStack (recipelike m bean -> Recipe m bean
forall (m :: * -> *) bean. recipelike m bean -> Recipe m bean
forall (recipelike :: (* -> *) -> * -> *) (m :: * -> *) bean.
ToRecipe recipelike =>
recipelike m bean -> Recipe m bean
toRecipe recipelike m bean
recipelike)) Map TypeRep (SomeRecipe m)
recipeMap}

-- | Tweak a 'Recipe' inside the 'Cauldron', if the recipe exists.
adjust ::
  forall {m} bean.
  (Typeable bean) =>
  (Recipe m bean -> Recipe m bean) ->
  Cauldron m ->
  Cauldron m
adjust :: forall {m :: * -> *} bean.
Typeable bean =>
(Recipe m bean -> Recipe m bean) -> Cauldron m -> Cauldron m
adjust Recipe m bean -> Recipe m bean
f (Cauldron {Map TypeRep (SomeRecipe m)
recipeMap :: forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeRecipe m)
recipeMap :: Map TypeRep (SomeRecipe m)
recipeMap}) = (HasCallStack => Cauldron m) -> Cauldron m
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
  let rep :: TypeRep
rep = Proxy bean -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @bean)
  Cauldron
    { recipeMap :: Map TypeRep (SomeRecipe m)
recipeMap =
        Map TypeRep (SomeRecipe m)
recipeMap
          Map TypeRep (SomeRecipe m)
-> (Map TypeRep (SomeRecipe m) -> Map TypeRep (SomeRecipe m))
-> Map TypeRep (SomeRecipe m)
forall a b. a -> (a -> b) -> b
& (SomeRecipe m -> SomeRecipe m)
-> TypeRep
-> Map TypeRep (SomeRecipe m)
-> Map TypeRep (SomeRecipe m)
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust
            do
              \r :: SomeRecipe m
r@SomeRecipe {_recipe :: ()
_recipe = Recipe m bean
_recipe :: Recipe m a} ->
                case TypeRep bean -> TypeRep bean -> Maybe (bean :~: bean)
forall a b. TypeRep a -> TypeRep b -> Maybe (a :~: b)
forall {k} (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality (forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
Type.Reflection.typeRep @bean) (forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
Type.Reflection.typeRep @a) of
                  Maybe (bean :~: bean)
Nothing -> String -> SomeRecipe m
forall a. HasCallStack => String -> a
error String
"should never happen"
                  Just bean :~: bean
Refl -> SomeRecipe m
r {_recipe = f _recipe}
            TypeRep
rep
    }

delete ::
  forall m.
  TypeRep ->
  Cauldron m ->
  Cauldron m
delete :: forall (m :: * -> *). TypeRep -> Cauldron m -> Cauldron m
delete TypeRep
tr Cauldron {Map TypeRep (SomeRecipe m)
recipeMap :: forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeRecipe m)
recipeMap :: Map TypeRep (SomeRecipe m)
recipeMap} =
  Cauldron {recipeMap :: Map TypeRep (SomeRecipe m)
recipeMap = TypeRep -> Map TypeRep (SomeRecipe m) -> Map TypeRep (SomeRecipe m)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete TypeRep
tr Map TypeRep (SomeRecipe m)
recipeMap}

-- | Strategy for dealing with dependency cycles.
--
-- (The name is admittedly uninformative; the culinary metaphor was stretched too far.)
data Fire m = Fire
  { forall (m :: * -> *).
Fire m -> (BeanConstructionStep, BeanConstructionStep) -> Bool
shouldOmitDependency :: (BeanConstructionStep, BeanConstructionStep) -> Bool,
    forall (m :: * -> *).
Fire m -> Cauldron m -> Set TypeRep -> Beans -> Plan -> m Beans
followPlanCauldron ::
      Cauldron m ->
      Set TypeRep ->
      Beans ->
      Plan ->
      m Beans
  }

removeBeanFromArgs :: ConstructorReps -> ConstructorReps
removeBeanFromArgs :: ConstructorReps -> ConstructorReps
removeBeanFromArgs ConstructorReps {Set TypeRep
argReps :: ConstructorReps -> Set TypeRep
argReps :: Set TypeRep
argReps, Map TypeRep Dynamic
regReps :: ConstructorReps -> Map TypeRep Dynamic
regReps :: Map TypeRep Dynamic
regReps, TypeRep
beanRep :: ConstructorReps -> TypeRep
beanRep :: TypeRep
beanRep} =
  ConstructorReps {argReps :: Set TypeRep
argReps = TypeRep -> Set TypeRep -> Set TypeRep
forall a. Ord a => a -> Set a -> Set a
Set.delete TypeRep
beanRep Set TypeRep
argReps, Map TypeRep Dynamic
regReps :: Map TypeRep Dynamic
regReps :: Map TypeRep Dynamic
regReps, TypeRep
beanRep :: TypeRep
beanRep :: TypeRep
beanRep}

-- | Forbid any kind of cyclic dependencies between beans. This is probably what you want.
forbidDepCycles :: (Monad m) => Fire m
forbidDepCycles :: forall (m :: * -> *). Monad m => Fire m
forbidDepCycles =
  Fire
    { shouldOmitDependency :: (BeanConstructionStep, BeanConstructionStep) -> Bool
shouldOmitDependency = \(BeanConstructionStep, BeanConstructionStep)
_ -> Bool
False,
      followPlanCauldron :: Cauldron m -> Set TypeRep -> Beans -> Plan -> m Beans
followPlanCauldron = \Cauldron m
cauldron Set TypeRep
_secondaryBeanReps Beans
initial Plan
plan ->
        (Beans -> BeanConstructionStep -> m Beans)
-> Beans -> Plan -> m Beans
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
Data.Foldable.foldlM
          do (TypeRep -> Beans -> Beans)
-> (TypeRep -> Beans -> Beans)
-> Cauldron m
-> Beans
-> Beans
-> BeanConstructionStep
-> m Beans
forall (m :: * -> *).
Monad m =>
(TypeRep -> Beans -> Beans)
-> (TypeRep -> Beans -> Beans)
-> Cauldron m
-> Beans
-> Beans
-> BeanConstructionStep
-> m Beans
followPlanStep (\TypeRep
_ -> Beans -> Beans
forall a. a -> a
id) (\TypeRep
_ -> Beans -> Beans
forall a. a -> a
id) Cauldron m
cauldron Beans
forall a. Monoid a => a
mempty
          Beans
initial
          Plan
plan
    }

-- | Allow /direct/ self-dependencies.
--
-- A bean constructor might depend on itself. This can be useful for having
-- decorated self-invocations, because the version of the bean received as
-- argument comes \"from the future\" and is already decorated.
--
-- Note that a 'MonadFix' instance is required of the initialization monad.
--
-- __BEWARE__: Pattern-matching too eagerly on a \"bean from the future\" during
-- construction will cause infinite loops or, if you are lucky, throw
-- 'Control.Exception.FixIOException's.
allowSelfDeps :: (MonadFix m) => Fire m
allowSelfDeps :: forall (m :: * -> *). MonadFix m => Fire m
allowSelfDeps =
  Fire
    { shouldOmitDependency :: (BeanConstructionStep, BeanConstructionStep) -> Bool
shouldOmitDependency = \case
        (BarePrimaryBean TypeRep
bean, PrimaryBean TypeRep
anotherBean) | TypeRep
bean TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== TypeRep
anotherBean -> Bool
True
        (BeanConstructionStep, BeanConstructionStep)
_ -> Bool
False,
      followPlanCauldron :: Cauldron m -> Set TypeRep -> Beans -> Plan -> m Beans
followPlanCauldron = \Cauldron m
cauldron Set TypeRep
_secondaryBeanReps Beans
initial Plan
plan ->
        (Beans -> m Beans) -> m Beans
forall a. (a -> m a) -> m a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix do
          \Beans
final ->
            (Beans -> BeanConstructionStep -> m Beans)
-> Beans -> Plan -> m Beans
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
Data.Foldable.foldlM
              do (TypeRep -> Beans -> Beans)
-> (TypeRep -> Beans -> Beans)
-> Cauldron m
-> Beans
-> Beans
-> BeanConstructionStep
-> m Beans
forall (m :: * -> *).
Monad m =>
(TypeRep -> Beans -> Beans)
-> (TypeRep -> Beans -> Beans)
-> Cauldron m
-> Beans
-> Beans
-> BeanConstructionStep
-> m Beans
followPlanStep TypeRep -> Beans -> Beans
Cauldron.Beans.delete (\TypeRep
_ -> Beans -> Beans
forall a. a -> a
id) Cauldron m
cauldron Beans
final
              Beans
initial
              Plan
plan
    }

-- | Allow /any/ kind of dependency cycles.
--
-- Usually comes in handy for creating serializers / deserializers for mutually
-- dependent types.
--
-- Note that a 'MonadFix' instance is required of the initialization monad.
--
-- __BEWARE__: Pattern-matching too eagerly on argument beans during
-- construction will cause infinite loops or, if you are lucky, throw
-- 'Control.Exception.FixIOException's.
allowDepCycles :: (MonadFix m) => Fire m
allowDepCycles :: forall (m :: * -> *). MonadFix m => Fire m
allowDepCycles =
  Fire
    { shouldOmitDependency :: (BeanConstructionStep, BeanConstructionStep) -> Bool
shouldOmitDependency = \case
        (BarePrimaryBean TypeRep
_, PrimaryBean TypeRep
_) -> Bool
True
        (PrimaryBeanDeco TypeRep
_ Int
_, PrimaryBean TypeRep
_) -> Bool
True
        (BeanConstructionStep, BeanConstructionStep)
_ -> Bool
False,
      followPlanCauldron :: Cauldron m -> Set TypeRep -> Beans -> Plan -> m Beans
followPlanCauldron = \Cauldron m
cauldron Set TypeRep
secondaryBeanReps Beans
initial Plan
plan -> do
        let makeBareView :: TypeRep -> Beans -> Beans
makeBareView TypeRep
_ = (Beans -> Set TypeRep -> Beans
`Cauldron.Beans.restrictKeys` Set TypeRep
secondaryBeanReps)
        let makeDecoView :: TypeRep -> Beans -> Beans
makeDecoView TypeRep
tr = (Beans -> Set TypeRep -> Beans
`Cauldron.Beans.restrictKeys` (TypeRep -> Set TypeRep -> Set TypeRep
forall a. Ord a => a -> Set a -> Set a
Set.insert TypeRep
tr Set TypeRep
secondaryBeanReps))
        (Beans -> m Beans) -> m Beans
forall a. (a -> m a) -> m a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix do
          \Beans
final ->
            (Beans -> BeanConstructionStep -> m Beans)
-> Beans -> Plan -> m Beans
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
Data.Foldable.foldlM
              do (TypeRep -> Beans -> Beans)
-> (TypeRep -> Beans -> Beans)
-> Cauldron m
-> Beans
-> Beans
-> BeanConstructionStep
-> m Beans
forall (m :: * -> *).
Monad m =>
(TypeRep -> Beans -> Beans)
-> (TypeRep -> Beans -> Beans)
-> Cauldron m
-> Beans
-> Beans
-> BeanConstructionStep
-> m Beans
followPlanStep TypeRep -> Beans -> Beans
makeBareView TypeRep -> Beans -> Beans
makeDecoView Cauldron m
cauldron Beans
final
              Beans
initial
              Plan
plan
    }

-- https://discord.com/channels/280033776820813825/280036215477239809/1147832555828162594
-- https://github.com/ghc-proposals/ghc-proposals/pull/126#issuecomment-1363403330

-- | This function DOESN'T return the bean rep itself in the argreps.
constructorReps :: forall {m} bean. (Typeable bean) => Constructor m bean -> ConstructorReps
constructorReps :: forall {m :: * -> *} bean.
Typeable bean =>
Constructor m bean -> ConstructorReps
constructorReps (Constructor m bean -> Args (m (Regs bean))
forall (m :: * -> *) bean.
Constructor m bean -> Args (m (Regs bean))
getConstructorArgs -> Args (m (Regs bean))
c) =
  ConstructorReps
    { beanRep :: TypeRep
beanRep = Proxy bean -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @bean),
      argReps :: Set TypeRep
argReps = Args (m (Regs bean)) -> Set TypeRep
forall a. Args a -> Set TypeRep
getArgsReps Args (m (Regs bean))
c,
      regReps :: Map TypeRep Dynamic
regReps =
        Args (m (Regs bean))
c
          Args (m (Regs bean))
-> (Args (m (Regs bean)) -> Set SomeMonoidTypeRep)
-> Set SomeMonoidTypeRep
forall a b. a -> (a -> b) -> b
& Args (m (Regs bean)) -> Set SomeMonoidTypeRep
forall a. Args a -> Set SomeMonoidTypeRep
getRegsReps
          Set SomeMonoidTypeRep
-> (Set SomeMonoidTypeRep -> Set (Arg TypeRep Dynamic))
-> Set (Arg TypeRep Dynamic)
forall a b. a -> (a -> b) -> b
& (SomeMonoidTypeRep -> Arg TypeRep Dynamic)
-> Set SomeMonoidTypeRep -> Set (Arg TypeRep Dynamic)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\mtr :: SomeMonoidTypeRep
mtr@(SomeMonoidTypeRep TypeRep a
tr) -> TypeRep -> Dynamic -> Arg TypeRep Dynamic
forall a b. a -> b -> Arg a b
Data.Semigroup.Arg (TypeRep a -> TypeRep
forall k (a :: k). TypeRep a -> TypeRep
Type.Reflection.SomeTypeRep TypeRep a
tr) (Dynamic -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn (SomeMonoidTypeRep -> Dynamic
Cauldron.Beans.someMonoidTypeRepMempty SomeMonoidTypeRep
mtr)))
          Set (Arg TypeRep Dynamic)
-> (Set (Arg TypeRep Dynamic) -> Map TypeRep Dynamic)
-> Map TypeRep Dynamic
forall a b. a -> (a -> b) -> b
& Set (Arg TypeRep Dynamic) -> Map TypeRep Dynamic
forall k a. Set (Arg k a) -> Map k a
Map.fromArgSet
    }

type Plan = [BeanConstructionStep]

-- | A step in the construction of a bean value.
data BeanConstructionStep
  = -- | Undecorated bean.
    BarePrimaryBean TypeRep
  | -- | Apply the decorator with the given index. Comes after the 'BarePrimaryBean' and all 'PrimaryBeanDeco's with a lower index value.
    PrimaryBeanDeco TypeRep Int
  | -- | Final, fully decorated version of a bean. If there are no decorators, comes directly after 'BarePrimaryBean'.
    PrimaryBean TypeRep
  | -- | Beans that are secondary registrations of a 'Constructor' and which are aggregated monoidally.
    SecondaryBean TypeRep
  deriving stock (Int -> BeanConstructionStep -> ShowS
Plan -> ShowS
BeanConstructionStep -> String
(Int -> BeanConstructionStep -> ShowS)
-> (BeanConstructionStep -> String)
-> (Plan -> ShowS)
-> Show BeanConstructionStep
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BeanConstructionStep -> ShowS
showsPrec :: Int -> BeanConstructionStep -> ShowS
$cshow :: BeanConstructionStep -> String
show :: BeanConstructionStep -> String
$cshowList :: Plan -> ShowS
showList :: Plan -> ShowS
Show, BeanConstructionStep -> BeanConstructionStep -> Bool
(BeanConstructionStep -> BeanConstructionStep -> Bool)
-> (BeanConstructionStep -> BeanConstructionStep -> Bool)
-> Eq BeanConstructionStep
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BeanConstructionStep -> BeanConstructionStep -> Bool
== :: BeanConstructionStep -> BeanConstructionStep -> Bool
$c/= :: BeanConstructionStep -> BeanConstructionStep -> Bool
/= :: BeanConstructionStep -> BeanConstructionStep -> Bool
Eq, Eq BeanConstructionStep
Eq BeanConstructionStep =>
(BeanConstructionStep -> BeanConstructionStep -> Ordering)
-> (BeanConstructionStep -> BeanConstructionStep -> Bool)
-> (BeanConstructionStep -> BeanConstructionStep -> Bool)
-> (BeanConstructionStep -> BeanConstructionStep -> Bool)
-> (BeanConstructionStep -> BeanConstructionStep -> Bool)
-> (BeanConstructionStep
    -> BeanConstructionStep -> BeanConstructionStep)
-> (BeanConstructionStep
    -> BeanConstructionStep -> BeanConstructionStep)
-> Ord BeanConstructionStep
BeanConstructionStep -> BeanConstructionStep -> Bool
BeanConstructionStep -> BeanConstructionStep -> Ordering
BeanConstructionStep
-> BeanConstructionStep -> BeanConstructionStep
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: BeanConstructionStep -> BeanConstructionStep -> Ordering
compare :: BeanConstructionStep -> BeanConstructionStep -> Ordering
$c< :: BeanConstructionStep -> BeanConstructionStep -> Bool
< :: BeanConstructionStep -> BeanConstructionStep -> Bool
$c<= :: BeanConstructionStep -> BeanConstructionStep -> Bool
<= :: BeanConstructionStep -> BeanConstructionStep -> Bool
$c> :: BeanConstructionStep -> BeanConstructionStep -> Bool
> :: BeanConstructionStep -> BeanConstructionStep -> Bool
$c>= :: BeanConstructionStep -> BeanConstructionStep -> Bool
>= :: BeanConstructionStep -> BeanConstructionStep -> Bool
$cmax :: BeanConstructionStep
-> BeanConstructionStep -> BeanConstructionStep
max :: BeanConstructionStep
-> BeanConstructionStep -> BeanConstructionStep
$cmin :: BeanConstructionStep
-> BeanConstructionStep -> BeanConstructionStep
min :: BeanConstructionStep
-> BeanConstructionStep -> BeanConstructionStep
Ord)

-- | Build the beans using the recipeMap stored in the 'Cauldron'.
--
-- Any secondary beans that are registered by constructors are aggregated
-- monoidally.
cook ::
  forall m.
  (Monad m) =>
  Fire m ->
  Cauldron m ->
  Either RecipeError (m Beans)
cook :: forall (m :: * -> *).
Monad m =>
Fire m -> Cauldron m -> Either RecipeError (m Beans)
cook Fire m
fire Cauldron m
cauldron =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap @(Either RecipeError) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap @m Tree Beans -> Beans
forall a. Tree a -> a
rootLabel) (Either RecipeError (m (Tree Beans))
 -> Either RecipeError (m Beans))
-> Either RecipeError (m (Tree Beans))
-> Either RecipeError (m Beans)
forall a b. (a -> b) -> a -> b
$
    Tree (Fire m, Cauldron m) -> Either RecipeError (m (Tree Beans))
forall (m :: * -> *).
Monad m =>
Tree (Fire m, Cauldron m) -> Either RecipeError (m (Tree Beans))
cookTree ((Fire m, Cauldron m)
-> [Tree (Fire m, Cauldron m)] -> Tree (Fire m, Cauldron m)
forall a. a -> [Tree a] -> Tree a
Node (Fire m
fire, Cauldron m
cauldron) [])

-- | Cook a nonempty list of 'Cauldron's.
--
-- 'Cauldron's later in the list can see the beans in all previous 'Cauldron's,
-- but not vice versa.
--
-- Beans in a 'Cauldron' have priority over the same beans in previous 'Cauldron's.
cookNonEmpty ::
  forall m.
  (Monad m) =>
  NonEmpty (Fire m, Cauldron m) ->
  Either RecipeError (m (NonEmpty Beans))
cookNonEmpty :: forall (m :: * -> *).
Monad m =>
NonEmpty (Fire m, Cauldron m)
-> Either RecipeError (m (NonEmpty Beans))
cookNonEmpty NonEmpty (Fire m, Cauldron m)
nonemptyCauldronList = do
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap @(Either RecipeError) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap @m Tree Beans -> NonEmpty Beans
forall a. Tree a -> NonEmpty a
unsafeTreeToNonEmpty) (Either RecipeError (m (Tree Beans))
 -> Either RecipeError (m (NonEmpty Beans)))
-> Either RecipeError (m (Tree Beans))
-> Either RecipeError (m (NonEmpty Beans))
forall a b. (a -> b) -> a -> b
$
    Tree (Fire m, Cauldron m) -> Either RecipeError (m (Tree Beans))
forall (m :: * -> *).
Monad m =>
Tree (Fire m, Cauldron m) -> Either RecipeError (m (Tree Beans))
cookTree (NonEmpty (Fire m, Cauldron m) -> Tree (Fire m, Cauldron m)
forall a. NonEmpty a -> Tree a
nonEmptyToTree NonEmpty (Fire m, Cauldron m)
nonemptyCauldronList)

-- | Cook a hierarchy of 'Cauldron's.
--
-- 'Cauldron's down in the branches can see the beans of their ancestor
-- 'Cauldron's, but not vice versa.
--
-- Beans in a 'Cauldron' have priority over the same beans in ancestor 'Cauldron's.
cookTree ::
  forall m.
  (Monad m) =>
  Tree (Fire m, Cauldron m) ->
  Either RecipeError (m (Tree Beans))
cookTree :: forall (m :: * -> *).
Monad m =>
Tree (Fire m, Cauldron m) -> Either RecipeError (m (Tree Beans))
cookTree (Tree (Fire m, Cauldron m)
treecipes) = do
  accumMap <- (DoubleDutyBeans -> RecipeError)
-> Either DoubleDutyBeans (Map TypeRep Dynamic)
-> Either RecipeError (Map TypeRep Dynamic)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first DoubleDutyBeans -> RecipeError
DoubleDutyBeansError do Tree (Cauldron m) -> Either DoubleDutyBeans (Map TypeRep Dynamic)
forall (m :: * -> *).
Tree (Cauldron m) -> Either DoubleDutyBeans (Map TypeRep Dynamic)
checkNoDoubleDutyBeans ((Fire m, Cauldron m) -> Cauldron m
forall a b. (a, b) -> b
snd ((Fire m, Cauldron m) -> Cauldron m)
-> Tree (Fire m, Cauldron m) -> Tree (Cauldron m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tree (Fire m, Cauldron m)
treecipes)
  () <- first MissingDependenciesError do checkMissingDeps (Map.keysSet accumMap) (snd <$> treecipes)
  treeplan <- first DependencyCycleError do buildPlans (Map.keysSet accumMap) treecipes
  Right $ followPlan (fromDynList (Data.Foldable.toList accumMap)) (treeplan)

newtype DoubleDutyBeans = DoubleDutyBeans (Map TypeRep (CallStack, CallStack))
  deriving stock (Int -> DoubleDutyBeans -> ShowS
[DoubleDutyBeans] -> ShowS
DoubleDutyBeans -> String
(Int -> DoubleDutyBeans -> ShowS)
-> (DoubleDutyBeans -> String)
-> ([DoubleDutyBeans] -> ShowS)
-> Show DoubleDutyBeans
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DoubleDutyBeans -> ShowS
showsPrec :: Int -> DoubleDutyBeans -> ShowS
$cshow :: DoubleDutyBeans -> String
show :: DoubleDutyBeans -> String
$cshowList :: [DoubleDutyBeans] -> ShowS
showList :: [DoubleDutyBeans] -> ShowS
Show)

-- | Get a graph of dependencies between 'BeanConstructionStep's. The graph can
-- be obtained even if the 'Cauldron' can't be 'cook'ed successfully.
getDependencyGraph :: Cauldron m -> DependencyGraph
getDependencyGraph :: forall (m :: * -> *). Cauldron m -> DependencyGraph
getDependencyGraph Cauldron m
cauldron =
  let (Map TypeRep (CallStack, Dynamic)
accumMap, Map TypeRep CallStack
_) = Cauldron m
-> (Map TypeRep (CallStack, Dynamic), Map TypeRep CallStack)
forall (m :: * -> *).
Cauldron m
-> (Map TypeRep (CallStack, Dynamic), Map TypeRep CallStack)
cauldronRegs Cauldron m
cauldron
      (Map BeanConstructionStep CallStack
_, [(BeanConstructionStep, BeanConstructionStep)]
deps) = Set TypeRep
-> Cauldron m
-> (Map BeanConstructionStep CallStack,
    [(BeanConstructionStep, BeanConstructionStep)])
forall (m :: * -> *).
Set TypeRep
-> Cauldron m
-> (Map BeanConstructionStep CallStack,
    [(BeanConstructionStep, BeanConstructionStep)])
buildDepsCauldron (Map TypeRep (CallStack, Dynamic) -> Set TypeRep
forall k a. Map k a -> Set k
Map.keysSet Map TypeRep (CallStack, Dynamic)
accumMap) Cauldron m
cauldron
   in DependencyGraph {graph :: AdjacencyMap BeanConstructionStep
graph = [(BeanConstructionStep, BeanConstructionStep)]
-> AdjacencyMap BeanConstructionStep
forall a. Ord a => [(a, a)] -> AdjacencyMap a
Graph.edges [(BeanConstructionStep, BeanConstructionStep)]
deps}

checkNoDoubleDutyBeans ::
  Tree (Cauldron m) ->
  Either DoubleDutyBeans (Map TypeRep Dynamic)
checkNoDoubleDutyBeans :: forall (m :: * -> *).
Tree (Cauldron m) -> Either DoubleDutyBeans (Map TypeRep Dynamic)
checkNoDoubleDutyBeans Tree (Cauldron m)
treecipes = do
  let (Map TypeRep (CallStack, Dynamic)
accumMap, Map TypeRep CallStack
beanSet) = Tree (Cauldron m)
-> (Map TypeRep (CallStack, Dynamic), Map TypeRep CallStack)
forall (m :: * -> *).
Tree (Cauldron m)
-> (Map TypeRep (CallStack, Dynamic), Map TypeRep CallStack)
cauldronTreeRegs Tree (Cauldron m)
treecipes
  let common :: Map TypeRep (CallStack, CallStack)
common = (CallStack -> CallStack -> (CallStack, CallStack))
-> Map TypeRep CallStack
-> Map TypeRep CallStack
-> Map TypeRep (CallStack, CallStack)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith (,) ((CallStack, Dynamic) -> CallStack
forall a b. (a, b) -> a
fst ((CallStack, Dynamic) -> CallStack)
-> Map TypeRep (CallStack, Dynamic) -> Map TypeRep CallStack
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map TypeRep (CallStack, Dynamic)
accumMap) Map TypeRep CallStack
beanSet
  if Bool -> Bool
not (Map TypeRep (CallStack, CallStack) -> Bool
forall k a. Map k a -> Bool
Map.null Map TypeRep (CallStack, CallStack)
common)
    then DoubleDutyBeans -> Either DoubleDutyBeans (Map TypeRep Dynamic)
forall a b. a -> Either a b
Left (DoubleDutyBeans -> Either DoubleDutyBeans (Map TypeRep Dynamic))
-> DoubleDutyBeans -> Either DoubleDutyBeans (Map TypeRep Dynamic)
forall a b. (a -> b) -> a -> b
$ Map TypeRep (CallStack, CallStack) -> DoubleDutyBeans
DoubleDutyBeans Map TypeRep (CallStack, CallStack)
common
    else Map TypeRep Dynamic -> Either DoubleDutyBeans (Map TypeRep Dynamic)
forall a b. b -> Either a b
Right (Map TypeRep Dynamic
 -> Either DoubleDutyBeans (Map TypeRep Dynamic))
-> Map TypeRep Dynamic
-> Either DoubleDutyBeans (Map TypeRep Dynamic)
forall a b. (a -> b) -> a -> b
$ (CallStack, Dynamic) -> Dynamic
forall a b. (a, b) -> b
snd ((CallStack, Dynamic) -> Dynamic)
-> Map TypeRep (CallStack, Dynamic) -> Map TypeRep Dynamic
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map TypeRep (CallStack, Dynamic)
accumMap

cauldronTreeRegs :: Tree (Cauldron m) -> (Map TypeRep (CallStack, Dynamic), Map TypeRep CallStack)
cauldronTreeRegs :: forall (m :: * -> *).
Tree (Cauldron m)
-> (Map TypeRep (CallStack, Dynamic), Map TypeRep CallStack)
cauldronTreeRegs = (Cauldron m
 -> (Map TypeRep (CallStack, Dynamic), Map TypeRep CallStack))
-> Tree (Cauldron m)
-> (Map TypeRep (CallStack, Dynamic), Map TypeRep CallStack)
forall m a. Monoid m => (a -> m) -> Tree a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Cauldron m
-> (Map TypeRep (CallStack, Dynamic), Map TypeRep CallStack)
forall (m :: * -> *).
Cauldron m
-> (Map TypeRep (CallStack, Dynamic), Map TypeRep CallStack)
cauldronRegs

cauldronRegs :: Cauldron m -> (Map TypeRep (CallStack, Dynamic), Map TypeRep CallStack)
cauldronRegs :: forall (m :: * -> *).
Cauldron m
-> (Map TypeRep (CallStack, Dynamic), Map TypeRep CallStack)
cauldronRegs Cauldron {Map TypeRep (SomeRecipe m)
recipeMap :: forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeRecipe m)
recipeMap :: Map TypeRep (SomeRecipe m)
recipeMap} =
  (TypeRep
 -> SomeRecipe m
 -> (Map TypeRep (CallStack, Dynamic), Map TypeRep CallStack))
-> Map TypeRep (SomeRecipe m)
-> (Map TypeRep (CallStack, Dynamic), Map TypeRep CallStack)
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey
    do \TypeRep
rep SomeRecipe m
aRecipe -> (SomeRecipe m -> Map TypeRep (CallStack, Dynamic)
forall (m :: * -> *).
SomeRecipe m -> Map TypeRep (CallStack, Dynamic)
recipeRegs SomeRecipe m
aRecipe, TypeRep -> CallStack -> Map TypeRep CallStack
forall k a. k -> a -> Map k a
Map.singleton TypeRep
rep (SomeRecipe m -> CallStack
forall (m :: * -> *). SomeRecipe m -> CallStack
getRecipeCallStack SomeRecipe m
aRecipe))
    Map TypeRep (SomeRecipe m)
recipeMap

-- | Returns the accumulators, not the main bean
recipeRegs :: SomeRecipe m -> Map TypeRep (CallStack, Dynamic)
recipeRegs :: forall (m :: * -> *).
SomeRecipe m -> Map TypeRep (CallStack, Dynamic)
recipeRegs (SomeRecipe CallStack
_ (Recipe {Constructor m bean
bean :: forall (m :: * -> *) bean. Recipe m bean -> Constructor m bean
bean :: Constructor m bean
bean, Seq (Constructor m bean)
decos :: forall (m :: * -> *) bean.
Recipe m bean -> Seq (Constructor m bean)
decos :: Seq (Constructor m bean)
decos})) = do
  let extractRegReps :: Constructor m bean -> Map TypeRep (CallStack, Dynamic)
extractRegReps Constructor m bean
c = (Constructor m bean -> CallStack
forall (m :: * -> *) bean. Constructor m bean -> CallStack
getConstructorCallStack Constructor m bean
c,) (Dynamic -> (CallStack, Dynamic))
-> Map TypeRep Dynamic -> Map TypeRep (CallStack, Dynamic)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (\ConstructorReps {Map TypeRep Dynamic
regReps :: ConstructorReps -> Map TypeRep Dynamic
regReps :: Map TypeRep Dynamic
regReps} -> Map TypeRep Dynamic
regReps) (Constructor m bean -> ConstructorReps
forall {m :: * -> *} bean.
Typeable bean =>
Constructor m bean -> ConstructorReps
constructorReps Constructor m bean
c)
  Constructor m bean -> Map TypeRep (CallStack, Dynamic)
forall {bean} {m :: * -> *}.
Typeable bean =>
Constructor m bean -> Map TypeRep (CallStack, Dynamic)
extractRegReps Constructor m bean
bean
    Map TypeRep (CallStack, Dynamic)
-> Map TypeRep (CallStack, Dynamic)
-> Map TypeRep (CallStack, Dynamic)
forall a. Semigroup a => a -> a -> a
<> (Constructor m bean -> Map TypeRep (CallStack, Dynamic))
-> Seq (Constructor m bean) -> Map TypeRep (CallStack, Dynamic)
forall m a. Monoid m => (a -> m) -> Seq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Constructor m bean -> Map TypeRep (CallStack, Dynamic)
forall {bean} {m :: * -> *}.
Typeable bean =>
Constructor m bean -> Map TypeRep (CallStack, Dynamic)
extractRegReps Seq (Constructor m bean)
decos

data MissingDependencies = MissingDependencies CallStack TypeRep (Set TypeRep)
  deriving stock (Int -> MissingDependencies -> ShowS
[MissingDependencies] -> ShowS
MissingDependencies -> String
(Int -> MissingDependencies -> ShowS)
-> (MissingDependencies -> String)
-> ([MissingDependencies] -> ShowS)
-> Show MissingDependencies
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MissingDependencies -> ShowS
showsPrec :: Int -> MissingDependencies -> ShowS
$cshow :: MissingDependencies -> String
show :: MissingDependencies -> String
$cshowList :: [MissingDependencies] -> ShowS
showList :: [MissingDependencies] -> ShowS
Show)

checkMissingDeps ::
  -- | accums
  Set TypeRep ->
  Tree (Cauldron m) ->
  Either MissingDependencies ()
checkMissingDeps :: forall (m :: * -> *).
Set TypeRep -> Tree (Cauldron m) -> Either MissingDependencies ()
checkMissingDeps Set TypeRep
accums Tree (Cauldron m)
treecipes = do
  let decoratedTreecipes :: Tree (Map TypeRep (SomeRecipe m), Cauldron m)
decoratedTreecipes = (Map TypeRep (SomeRecipe m), Tree (Cauldron m))
-> Tree (Map TypeRep (SomeRecipe m), Cauldron m)
forall (m :: * -> *).
(Map TypeRep (SomeRecipe m), Tree (Cauldron m))
-> Tree (Map TypeRep (SomeRecipe m), Cauldron m)
decorate (Map TypeRep (SomeRecipe m)
forall k a. Map k a
Map.empty, Tree (Cauldron m)
treecipes)
      missing :: Tree (Either MissingDependencies ())
missing =
        Tree (Map TypeRep (SomeRecipe m), Cauldron m)
decoratedTreecipes Tree (Map TypeRep (SomeRecipe m), Cauldron m)
-> ((Map TypeRep (SomeRecipe m), Cauldron m)
    -> Either MissingDependencies ())
-> Tree (Either MissingDependencies ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Map TypeRep (SomeRecipe m)
available, Cauldron m
requested) ->
          do Set TypeRep
-> Set TypeRep -> Cauldron m -> Either MissingDependencies ()
forall (m :: * -> *).
Set TypeRep
-> Set TypeRep -> Cauldron m -> Either MissingDependencies ()
checkMissingDepsCauldron Set TypeRep
accums (Map TypeRep (SomeRecipe m) -> Set TypeRep
forall k a. Map k a -> Set k
Map.keysSet Map TypeRep (SomeRecipe m)
available) Cauldron m
requested
  Tree (Either MissingDependencies ())
-> Either MissingDependencies ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ Tree (Either MissingDependencies ())
missing
  where
    decorate ::
      (Map TypeRep (SomeRecipe m), Tree (Cauldron m)) ->
      Tree (Map TypeRep (SomeRecipe m), Cauldron m)
    decorate :: forall (m :: * -> *).
(Map TypeRep (SomeRecipe m), Tree (Cauldron m))
-> Tree (Map TypeRep (SomeRecipe m), Cauldron m)
decorate = ((Map TypeRep (SomeRecipe m), Tree (Cauldron m))
 -> ((Map TypeRep (SomeRecipe m), Cauldron m),
     [(Map TypeRep (SomeRecipe m), Tree (Cauldron m))]))
-> (Map TypeRep (SomeRecipe m), Tree (Cauldron m))
-> Tree (Map TypeRep (SomeRecipe m), Cauldron m)
forall b a. (b -> (a, [b])) -> b -> Tree a
unfoldTree
      do
        \(Map TypeRep (SomeRecipe m)
acc, Node (current :: Cauldron m
current@Cauldron {Map TypeRep (SomeRecipe m)
recipeMap :: forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeRecipe m)
recipeMap :: Map TypeRep (SomeRecipe m)
recipeMap}) [Tree (Cauldron m)]
rest) ->
          let -- current level has priority
              newAcc :: Map TypeRep (SomeRecipe m)
newAcc = Map TypeRep (SomeRecipe m)
recipeMap Map TypeRep (SomeRecipe m)
-> Map TypeRep (SomeRecipe m) -> Map TypeRep (SomeRecipe m)
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map TypeRep (SomeRecipe m)
acc
              newSeeds :: [(Map TypeRep (SomeRecipe m), Tree (Cauldron m))]
newSeeds = do
                z <- [Tree (Cauldron m)]
rest
                [(newAcc, z)]
           in ((Map TypeRep (SomeRecipe m)
newAcc, Cauldron m
current), [(Map TypeRep (SomeRecipe m), Tree (Cauldron m))]
newSeeds)

checkMissingDepsCauldron ::
  -- | accums
  Set TypeRep ->
  -- | available at this level
  Set TypeRep ->
  Cauldron m ->
  Either MissingDependencies ()
checkMissingDepsCauldron :: forall (m :: * -> *).
Set TypeRep
-> Set TypeRep -> Cauldron m -> Either MissingDependencies ()
checkMissingDepsCauldron Set TypeRep
accums Set TypeRep
available Cauldron m
cauldron =
  [(CallStack, TypeRep, Set TypeRep)]
-> ((CallStack, TypeRep, Set TypeRep)
    -> Either MissingDependencies ())
-> Either MissingDependencies ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
Data.Foldable.for_ (Cauldron m -> [(CallStack, TypeRep, Set TypeRep)]
forall (m :: * -> *).
Cauldron m -> [(CallStack, TypeRep, Set TypeRep)]
demandsByConstructorsInCauldron Cauldron m
cauldron) \(CallStack
stack, TypeRep
tr, Set TypeRep
demanded) ->
    let missing :: Set TypeRep
missing = (TypeRep -> Bool) -> Set TypeRep -> Set TypeRep
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (TypeRep -> Set TypeRep -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` (Set TypeRep
available Set TypeRep -> Set TypeRep -> Set TypeRep
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set TypeRep
accums)) Set TypeRep
demanded
     in if Set TypeRep -> Bool
forall a. Set a -> Bool
Set.null Set TypeRep
missing
          then () -> Either MissingDependencies ()
forall a b. b -> Either a b
Right ()
          else MissingDependencies -> Either MissingDependencies ()
forall a b. a -> Either a b
Left (MissingDependencies -> Either MissingDependencies ())
-> MissingDependencies -> Either MissingDependencies ()
forall a b. (a -> b) -> a -> b
$ CallStack -> TypeRep -> Set TypeRep -> MissingDependencies
MissingDependencies CallStack
stack TypeRep
tr Set TypeRep
missing

demandsByConstructorsInCauldron :: Cauldron m -> [(CallStack, TypeRep, Set TypeRep)]
demandsByConstructorsInCauldron :: forall (m :: * -> *).
Cauldron m -> [(CallStack, TypeRep, Set TypeRep)]
demandsByConstructorsInCauldron Cauldron {Map TypeRep (SomeRecipe m)
recipeMap :: forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeRecipe m)
recipeMap :: Map TypeRep (SomeRecipe m)
recipeMap} = do
  (tr, SomeRecipe _ (Recipe {bean, decos})) <- Map TypeRep (SomeRecipe m) -> [(TypeRep, SomeRecipe m)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TypeRep (SomeRecipe m)
recipeMap
  ( let ConstructorReps {argReps = beanArgReps} = constructorReps bean
     in [(getConstructorCallStack bean, tr, beanArgReps)]
    )
    ++ do
      decoCon <- Data.Foldable.toList decos
      let ConstructorReps {argReps = decoArgReps} = constructorReps decoCon
       in [(getConstructorCallStack decoCon, tr, decoArgReps)]

newtype DependencyCycle = DependencyCycle (NonEmpty (BeanConstructionStep, Maybe CallStack))
  deriving stock (Int -> DependencyCycle -> ShowS
[DependencyCycle] -> ShowS
DependencyCycle -> String
(Int -> DependencyCycle -> ShowS)
-> (DependencyCycle -> String)
-> ([DependencyCycle] -> ShowS)
-> Show DependencyCycle
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DependencyCycle -> ShowS
showsPrec :: Int -> DependencyCycle -> ShowS
$cshow :: DependencyCycle -> String
show :: DependencyCycle -> String
$cshowList :: [DependencyCycle] -> ShowS
showList :: [DependencyCycle] -> ShowS
Show)

buildPlans :: Set TypeRep -> Tree (Fire m, Cauldron m) -> Either DependencyCycle (Tree (Plan, Fire m, Cauldron m))
buildPlans :: forall (m :: * -> *).
Set TypeRep
-> Tree (Fire m, Cauldron m)
-> Either DependencyCycle (Tree (Plan, Fire m, Cauldron m))
buildPlans Set TypeRep
secondary = ((Fire m, Cauldron m)
 -> Either DependencyCycle (Plan, Fire m, Cauldron m))
-> Tree (Fire m, Cauldron m)
-> Either DependencyCycle (Tree (Plan, Fire m, Cauldron m))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Tree a -> f (Tree b)
traverse \(fire :: Fire m
fire@Fire {(BeanConstructionStep, BeanConstructionStep) -> Bool
shouldOmitDependency :: forall (m :: * -> *).
Fire m -> (BeanConstructionStep, BeanConstructionStep) -> Bool
shouldOmitDependency :: (BeanConstructionStep, BeanConstructionStep) -> Bool
shouldOmitDependency}, Cauldron m
cauldron) -> do
  let (Map BeanConstructionStep CallStack
locations, [(BeanConstructionStep, BeanConstructionStep)]
deps) = Set TypeRep
-> Cauldron m
-> (Map BeanConstructionStep CallStack,
    [(BeanConstructionStep, BeanConstructionStep)])
forall (m :: * -> *).
Set TypeRep
-> Cauldron m
-> (Map BeanConstructionStep CallStack,
    [(BeanConstructionStep, BeanConstructionStep)])
buildDepsCauldron Set TypeRep
secondary Cauldron m
cauldron
  -- We may omit some dependency edges to allow for cyclic dependencies.
  let graph :: AdjacencyMap BeanConstructionStep
graph = [(BeanConstructionStep, BeanConstructionStep)]
-> AdjacencyMap BeanConstructionStep
forall a. Ord a => [(a, a)] -> AdjacencyMap a
Graph.edges ([(BeanConstructionStep, BeanConstructionStep)]
 -> AdjacencyMap BeanConstructionStep)
-> [(BeanConstructionStep, BeanConstructionStep)]
-> AdjacencyMap BeanConstructionStep
forall a b. (a -> b) -> a -> b
$ ((BeanConstructionStep, BeanConstructionStep) -> Bool)
-> [(BeanConstructionStep, BeanConstructionStep)]
-> [(BeanConstructionStep, BeanConstructionStep)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((BeanConstructionStep, BeanConstructionStep) -> Bool)
-> (BeanConstructionStep, BeanConstructionStep)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BeanConstructionStep, BeanConstructionStep) -> Bool
shouldOmitDependency) [(BeanConstructionStep, BeanConstructionStep)]
deps
  case AdjacencyMap BeanConstructionStep
-> Either (Cycle BeanConstructionStep) Plan
forall a. Ord a => AdjacencyMap a -> Either (Cycle a) [a]
Graph.topSort AdjacencyMap BeanConstructionStep
graph of
    Left Cycle BeanConstructionStep
recipeCycle ->
      DependencyCycle
-> Either DependencyCycle (Plan, Fire m, Cauldron m)
forall a b. a -> Either a b
Left (DependencyCycle
 -> Either DependencyCycle (Plan, Fire m, Cauldron m))
-> DependencyCycle
-> Either DependencyCycle (Plan, Fire m, Cauldron m)
forall a b. (a -> b) -> a -> b
$ NonEmpty (BeanConstructionStep, Maybe CallStack) -> DependencyCycle
DependencyCycle (NonEmpty (BeanConstructionStep, Maybe CallStack)
 -> DependencyCycle)
-> NonEmpty (BeanConstructionStep, Maybe CallStack)
-> DependencyCycle
forall a b. (a -> b) -> a -> b
$ Cycle BeanConstructionStep
recipeCycle Cycle BeanConstructionStep
-> (BeanConstructionStep
    -> (BeanConstructionStep, Maybe CallStack))
-> NonEmpty (BeanConstructionStep, Maybe CallStack)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \BeanConstructionStep
step -> (BeanConstructionStep
step, BeanConstructionStep
-> Map BeanConstructionStep CallStack -> Maybe CallStack
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BeanConstructionStep
step Map BeanConstructionStep CallStack
locations)
    Right (Plan -> Plan
forall a. [a] -> [a]
reverse -> Plan
plan) -> do
      (Plan, Fire m, Cauldron m)
-> Either DependencyCycle (Plan, Fire m, Cauldron m)
forall a b. b -> Either a b
Right (Plan
plan, Fire m
fire, Cauldron m
cauldron)

buildDepsCauldron :: Set TypeRep -> Cauldron m -> (Map BeanConstructionStep CallStack, [(BeanConstructionStep, BeanConstructionStep)])
buildDepsCauldron :: forall (m :: * -> *).
Set TypeRep
-> Cauldron m
-> (Map BeanConstructionStep CallStack,
    [(BeanConstructionStep, BeanConstructionStep)])
buildDepsCauldron Set TypeRep
secondary Cauldron {Map TypeRep (SomeRecipe m)
recipeMap :: forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeRecipe m)
recipeMap :: Map TypeRep (SomeRecipe m)
recipeMap} = do
  -- Are we depending on a primary bean, or on a monoidally aggregated secondary bean?
  -- I wonder if we could make this more uniform, it's kind of annoying to have to make this decision here...
  let makeTargetStep :: TypeRep -> BeanConstructionStep
      makeTargetStep :: TypeRep -> BeanConstructionStep
makeTargetStep TypeRep
rep =
        if TypeRep
rep TypeRep -> Set TypeRep -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TypeRep
secondary
          then TypeRep -> BeanConstructionStep
SecondaryBean TypeRep
rep
          else TypeRep -> BeanConstructionStep
PrimaryBean TypeRep
rep
  Map TypeRep (SomeRecipe m)
recipeMap
    Map TypeRep (SomeRecipe m)
-> (Map TypeRep (SomeRecipe m)
    -> (Map BeanConstructionStep CallStack,
        [(BeanConstructionStep, BeanConstructionStep)]))
-> (Map BeanConstructionStep CallStack,
    [(BeanConstructionStep, BeanConstructionStep)])
forall a b. a -> (a -> b) -> b
& (TypeRep
 -> SomeRecipe m
 -> (Map BeanConstructionStep CallStack,
     [(BeanConstructionStep, BeanConstructionStep)]))
-> Map TypeRep (SomeRecipe m)
-> (Map BeanConstructionStep CallStack,
    [(BeanConstructionStep, BeanConstructionStep)])
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey
      \TypeRep
beanRep
       SomeRecipe
         { CallStack
_recipeCallStack :: forall (m :: * -> *). SomeRecipe m -> CallStack
_recipeCallStack :: CallStack
_recipeCallStack,
           _recipe :: ()
_recipe =
             Recipe
               { bean :: forall (m :: * -> *) bean. Recipe m bean -> Constructor m bean
bean = Constructor m bean
bean :: Constructor m bean,
                 Seq (Constructor m bean)
decos :: forall (m :: * -> *) bean.
Recipe m bean -> Seq (Constructor m bean)
decos :: Seq (Constructor m bean)
decos
               }
         } ->
          do
            let bareBean :: BeanConstructionStep
bareBean = TypeRep -> BeanConstructionStep
BarePrimaryBean TypeRep
beanRep
                boiledBean :: BeanConstructionStep
boiledBean = TypeRep -> BeanConstructionStep
PrimaryBean TypeRep
beanRep
                decoSteps :: [(BeanConstructionStep, Constructor m bean)]
decoSteps = do
                  (decoIndex, decoCon) <- [Int] -> [Constructor m bean] -> [(Int, Constructor m bean)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] (Seq (Constructor m bean) -> [Constructor m bean]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Data.Foldable.toList Seq (Constructor m bean)
decos)
                  [(PrimaryBeanDeco beanRep decoIndex, decoCon)]
                beanDeps :: [(BeanConstructionStep, BeanConstructionStep)]
beanDeps = do
                  (TypeRep -> BeanConstructionStep)
-> BeanConstructionStep
-> ConstructorReps
-> [(BeanConstructionStep, BeanConstructionStep)]
constructorEdges TypeRep -> BeanConstructionStep
makeTargetStep BeanConstructionStep
bareBean (Constructor m bean -> ConstructorReps
forall {m :: * -> *} bean.
Typeable bean =>
Constructor m bean -> ConstructorReps
constructorReps Constructor m bean
bean)
                decoDeps :: [(BeanConstructionStep, BeanConstructionStep)]
decoDeps = do
                  (decoStep, decoCon) <- [(BeanConstructionStep, Constructor m bean)]
decoSteps
                  -- We remove the bean because from the args becase, in the
                  -- case of decos, we want to depend on the in-the-making
                  -- version of the bean, not the completed bean.
                  constructorEdges makeTargetStep decoStep (removeBeanFromArgs do constructorReps decoCon)
                innerSteps :: Cycle BeanConstructionStep
innerSteps = BeanConstructionStep
bareBean BeanConstructionStep -> Plan -> Cycle BeanConstructionStep
forall a. a -> [a] -> NonEmpty a
Data.List.NonEmpty.:| ((BeanConstructionStep, Constructor m bean) -> BeanConstructionStep
forall a b. (a, b) -> a
fst ((BeanConstructionStep, Constructor m bean)
 -> BeanConstructionStep)
-> [(BeanConstructionStep, Constructor m bean)] -> Plan
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(BeanConstructionStep, Constructor m bean)]
decoSteps) Plan -> Plan -> Plan
forall a. [a] -> [a] -> [a]
++ [BeanConstructionStep
boiledBean]
                innerDeps :: [(BeanConstructionStep, BeanConstructionStep)]
innerDeps =
                  -- This explicit dependency between the completed bean and its
                  -- "bare" undecorated form is not strictly required. It will
                  -- always exist in an indirect manner, through the decorators.
                  -- But it might be useful when rendering the dep graph.
                  (TypeRep -> BeanConstructionStep
PrimaryBean TypeRep
beanRep, TypeRep -> BeanConstructionStep
BarePrimaryBean TypeRep
beanRep)
                    (BeanConstructionStep, BeanConstructionStep)
-> [(BeanConstructionStep, BeanConstructionStep)]
-> [(BeanConstructionStep, BeanConstructionStep)]
forall a. a -> [a] -> [a]
:
                    -- The dep chain of completed bean -> decorators -> bare bean.
                    Plan -> Plan -> [(BeanConstructionStep, BeanConstructionStep)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Cycle BeanConstructionStep -> Plan
forall a. NonEmpty a -> [a]
Data.List.NonEmpty.tail Cycle BeanConstructionStep
innerSteps) (Cycle BeanConstructionStep -> Plan
forall a. NonEmpty a -> [a]
Data.List.NonEmpty.toList Cycle BeanConstructionStep
innerSteps)
            ( [(BeanConstructionStep, CallStack)]
-> Map BeanConstructionStep CallStack
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(BeanConstructionStep, CallStack)]
 -> Map BeanConstructionStep CallStack)
-> [(BeanConstructionStep, CallStack)]
-> Map BeanConstructionStep CallStack
forall a b. (a -> b) -> a -> b
$
                [ (BeanConstructionStep
bareBean, Constructor m bean -> CallStack
forall (m :: * -> *) bean. Constructor m bean -> CallStack
getConstructorCallStack Constructor m bean
bean),
                  (BeanConstructionStep
boiledBean, CallStack
_recipeCallStack)
                ]
                  [(BeanConstructionStep, CallStack)]
-> [(BeanConstructionStep, CallStack)]
-> [(BeanConstructionStep, CallStack)]
forall a. [a] -> [a] -> [a]
++ do
                    (decoStep, decoCon) <- [(BeanConstructionStep, Constructor m bean)]
decoSteps
                    [(decoStep, getConstructorCallStack decoCon)],
              [(BeanConstructionStep, BeanConstructionStep)]
beanDeps [(BeanConstructionStep, BeanConstructionStep)]
-> [(BeanConstructionStep, BeanConstructionStep)]
-> [(BeanConstructionStep, BeanConstructionStep)]
forall a. [a] -> [a] -> [a]
++ [(BeanConstructionStep, BeanConstructionStep)]
decoDeps [(BeanConstructionStep, BeanConstructionStep)]
-> [(BeanConstructionStep, BeanConstructionStep)]
-> [(BeanConstructionStep, BeanConstructionStep)]
forall a. [a] -> [a] -> [a]
++ [(BeanConstructionStep, BeanConstructionStep)]
innerDeps
              )

constructorEdges ::
  (TypeRep -> BeanConstructionStep) ->
  BeanConstructionStep ->
  ConstructorReps ->
  [(BeanConstructionStep, BeanConstructionStep)]
constructorEdges :: (TypeRep -> BeanConstructionStep)
-> BeanConstructionStep
-> ConstructorReps
-> [(BeanConstructionStep, BeanConstructionStep)]
constructorEdges TypeRep -> BeanConstructionStep
makeTargetStep BeanConstructionStep
item (ConstructorReps {Set TypeRep
argReps :: ConstructorReps -> Set TypeRep
argReps :: Set TypeRep
argReps, Map TypeRep Dynamic
regReps :: ConstructorReps -> Map TypeRep Dynamic
regReps :: Map TypeRep Dynamic
regReps}) =
  -- consumers depend on their args
  ( do
      argRep <- Set TypeRep -> [TypeRep]
forall a. Set a -> [a]
Set.toList Set TypeRep
argReps
      let argStep = TypeRep -> BeanConstructionStep
makeTargetStep TypeRep
argRep
      [(item, argStep)]
  )
    [(BeanConstructionStep, BeanConstructionStep)]
-> [(BeanConstructionStep, BeanConstructionStep)]
-> [(BeanConstructionStep, BeanConstructionStep)]
forall a. [a] -> [a] -> [a]
++
    -- secondary beans depend on their producers
    ( do
        (regRep, _) <- Map TypeRep Dynamic -> [(TypeRep, Dynamic)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TypeRep Dynamic
regReps
        let repStep = TypeRep -> BeanConstructionStep
SecondaryBean TypeRep
regRep
        [(repStep, item)]
    )

followPlan ::
  (Monad m) =>
  Beans ->
  (Tree (Plan, Fire m, Cauldron m)) ->
  m (Tree Beans)
followPlan :: forall (m :: * -> *).
Monad m =>
Beans -> Tree (Plan, Fire m, Cauldron m) -> m (Tree Beans)
followPlan Beans
initialBeans Tree (Plan, Fire m, Cauldron m)
treecipes =
  let secondaryBeanReps :: Set TypeRep
secondaryBeanReps = Beans -> Set TypeRep
Cauldron.Beans.keysSet Beans
initialBeans
   in ((Beans, Tree (Plan, Fire m, Cauldron m))
 -> m (Beans, [(Beans, Tree (Plan, Fire m, Cauldron m))]))
-> (Beans, Tree (Plan, Fire m, Cauldron m)) -> m (Tree Beans)
forall (m :: * -> *) b a.
Monad m =>
(b -> m (a, [b])) -> b -> m (Tree a)
unfoldTreeM
        ( \(Beans
previousStageBeans, Node (Plan
plan, Fire {Cauldron m -> Set TypeRep -> Beans -> Plan -> m Beans
followPlanCauldron :: forall (m :: * -> *).
Fire m -> Cauldron m -> Set TypeRep -> Beans -> Plan -> m Beans
followPlanCauldron :: Cauldron m -> Set TypeRep -> Beans -> Plan -> m Beans
followPlanCauldron}, Cauldron m
cauldron) [Tree (Plan, Fire m, Cauldron m)]
rest) -> do
            currentStageBeans <- Cauldron m -> Set TypeRep -> Beans -> Plan -> m Beans
followPlanCauldron Cauldron m
cauldron Set TypeRep
secondaryBeanReps Beans
previousStageBeans Plan
plan
            pure (currentStageBeans, (,) currentStageBeans <$> rest)
        )
        (Beans
initialBeans, Tree (Plan, Fire m, Cauldron m)
treecipes)

followPlanStep ::
  (Monad m) =>
  (TypeRep -> Beans -> Beans) ->
  (TypeRep -> Beans -> Beans) ->
  Cauldron m ->
  Beans ->
  Beans ->
  BeanConstructionStep ->
  m Beans
followPlanStep :: forall (m :: * -> *).
Monad m =>
(TypeRep -> Beans -> Beans)
-> (TypeRep -> Beans -> Beans)
-> Cauldron m
-> Beans
-> Beans
-> BeanConstructionStep
-> m Beans
followPlanStep TypeRep -> Beans -> Beans
makeBareView TypeRep -> Beans -> Beans
makeDecoView Cauldron {Map TypeRep (SomeRecipe m)
recipeMap :: forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeRecipe m)
recipeMap :: Map TypeRep (SomeRecipe m)
recipeMap} Beans
final Beans
super BeanConstructionStep
item =
  case BeanConstructionStep
item of
    BarePrimaryBean TypeRep
rep -> case Maybe (SomeRecipe m) -> SomeRecipe m
forall a. HasCallStack => Maybe a -> a
fromJust do TypeRep -> Map TypeRep (SomeRecipe m) -> Maybe (SomeRecipe m)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TypeRep
rep Map TypeRep (SomeRecipe m)
recipeMap of
      SomeRecipe {_recipe :: ()
_recipe = Recipe {Constructor m bean
bean :: forall (m :: * -> *) bean. Recipe m bean -> Constructor m bean
bean :: Constructor m bean
bean}} -> do
        let ConstructorReps {TypeRep
beanRep :: ConstructorReps -> TypeRep
beanRep :: TypeRep
beanRep} = Constructor m bean -> ConstructorReps
forall {m :: * -> *} bean.
Typeable bean =>
Constructor m bean -> ConstructorReps
constructorReps Constructor m bean
bean
        -- We delete the beanRep before running the bean,
        -- because if we have a self-dependency, we don't want to use the bean
        -- from a previous context (if it exists) we want the bean from final.
        -- There is a test for this.
        inserter <- Constructor m bean -> Beans -> Beans -> m (Beans -> Beans)
forall (m :: * -> *) bean.
(Monad m, Typeable bean) =>
Constructor m bean -> Beans -> Beans -> m (Beans -> Beans)
followConstructor Constructor m bean
bean Beans
final (TypeRep -> Beans -> Beans
makeBareView TypeRep
beanRep Beans
super)
        pure do inserter super
    PrimaryBeanDeco TypeRep
rep Int
index -> case Maybe (SomeRecipe m) -> SomeRecipe m
forall a. HasCallStack => Maybe a -> a
fromJust do TypeRep -> Map TypeRep (SomeRecipe m) -> Maybe (SomeRecipe m)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TypeRep
rep Map TypeRep (SomeRecipe m)
recipeMap of
      SomeRecipe {_recipe :: ()
_recipe = Recipe {Seq (Constructor m bean)
decos :: forall (m :: * -> *) bean.
Recipe m bean -> Seq (Constructor m bean)
decos :: Seq (Constructor m bean)
decos}} -> do
        let deco :: Constructor m bean
deco = Seq (Constructor m bean)
decos Seq (Constructor m bean) -> Int -> Constructor m bean
forall a. Seq a -> Int -> a
`Data.Sequence.index` Int
index
        let ConstructorReps {TypeRep
beanRep :: ConstructorReps -> TypeRep
beanRep :: TypeRep
beanRep} = Constructor m bean -> ConstructorReps
forall {m :: * -> *} bean.
Typeable bean =>
Constructor m bean -> ConstructorReps
constructorReps Constructor m bean
deco
        -- Unlike before, we don't delete the beanRep before running the constructor.
        inserter <- Constructor m bean -> Beans -> Beans -> m (Beans -> Beans)
forall (m :: * -> *) bean.
(Monad m, Typeable bean) =>
Constructor m bean -> Beans -> Beans -> m (Beans -> Beans)
followConstructor Constructor m bean
deco Beans
final (TypeRep -> Beans -> Beans
makeDecoView TypeRep
beanRep Beans
super)
        pure do inserter super
    -- \| We do nothing here, the work has been done in previous 'BarePrimaryBean' and
    -- 'PrimaryBeanDeco' steps.
    PrimaryBean {} -> Beans -> m Beans
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Beans
super
    -- \| We do nothing here, secondary beans are built as a byproduct
    -- of primary beans and decorators.
    SecondaryBean {} -> Beans -> m Beans
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Beans
super

-- | Build a bean out of already built beans.
-- This can only work without blowing up if there aren't dependecy cycles
-- and the order of construction respects the depedencies!
followConstructor ::
  (Monad m, Typeable bean) =>
  Constructor m bean ->
  Beans ->
  Beans ->
  m (Beans -> Beans)
followConstructor :: forall (m :: * -> *) bean.
(Monad m, Typeable bean) =>
Constructor m bean -> Beans -> Beans -> m (Beans -> Beans)
followConstructor Constructor m bean
c Beans
final Beans
super = do
  (regs, bean) <- [Beans] -> Constructor m bean -> m (Beans, bean)
forall (m :: * -> *) bean.
Monad m =>
[Beans] -> Constructor m bean -> m (Beans, bean)
runConstructor [Beans
super, Beans
final] Constructor m bean
c
  pure \Beans
bs ->
    Set SomeMonoidTypeRep -> Beans -> Beans -> Beans
Cauldron.Beans.unionBeansMonoidally (Args (m (Regs bean)) -> Set SomeMonoidTypeRep
forall a. Args a -> Set SomeMonoidTypeRep
getRegsReps (Constructor m bean -> Args (m (Regs bean))
forall (m :: * -> *) bean.
Constructor m bean -> Args (m (Regs bean))
getConstructorArgs Constructor m bean
c)) Beans
bs Beans
regs
      Beans -> (Beans -> Beans) -> Beans
forall a b. a -> (a -> b) -> b
& bean -> Beans -> Beans
forall bean. Typeable bean => bean -> Beans -> Beans
Cauldron.Beans.insert bean
bean

-- | Sometimes the 'cook'ing process goes wrong.
data RecipeError
  = -- | A 'Constructor' depends on beans that can't be found either in the current 'Cauldron' or its ancestors.
    MissingDependenciesError MissingDependencies
  | -- | Beans that work both as primary beans and as secondary beans
    -- are disallowed.
    DoubleDutyBeansError DoubleDutyBeans
  | -- | Dependency cycles are disallowed by some 'Fire's.
    DependencyCycleError DependencyCycle
  deriving stock (Int -> RecipeError -> ShowS
[RecipeError] -> ShowS
RecipeError -> String
(Int -> RecipeError -> ShowS)
-> (RecipeError -> String)
-> ([RecipeError] -> ShowS)
-> Show RecipeError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RecipeError -> ShowS
showsPrec :: Int -> RecipeError -> ShowS
$cshow :: RecipeError -> String
show :: RecipeError -> String
$cshowList :: [RecipeError] -> ShowS
showList :: [RecipeError] -> ShowS
Show)

instance Exception RecipeError where
  displayException :: RecipeError -> String
displayException = RecipeError -> String
prettyRecipeError

prettyRecipeError :: RecipeError -> String
prettyRecipeError :: RecipeError -> String
prettyRecipeError = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
Data.List.intercalate String
"\n" ([String] -> String)
-> (RecipeError -> [String]) -> RecipeError -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecipeError -> [String]
prettyRecipeErrorLines

prettyRecipeErrorLines :: RecipeError -> [String]
prettyRecipeErrorLines :: RecipeError -> [String]
prettyRecipeErrorLines = \case
  MissingDependenciesError
    (MissingDependencies CallStack
constructorCallStack TypeRep
constructorResultRep Set TypeRep
missingDependenciesReps) ->
      [ String
"This constructor for a value of type "
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
constructorResultRep
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":"
      ]
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ((String
"\t" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CallStack -> [String]
prettyCallStackLines CallStack
constructorCallStack)
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"is missing the following dependencies:"
           ]
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ do
          rep <- Set TypeRep -> [TypeRep]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Data.Foldable.toList Set TypeRep
missingDependenciesReps
          ["- " ++ show rep]
  DoubleDutyBeansError (DoubleDutyBeans Map TypeRep (CallStack, CallStack)
doubleDutyMap) ->
    [ String
"The following beans work both as primary beans and secondary beans:"
    ]
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ( ((TypeRep -> (CallStack, CallStack) -> [String])
 -> Map TypeRep (CallStack, CallStack) -> [String])
-> Map TypeRep (CallStack, CallStack)
-> (TypeRep -> (CallStack, CallStack) -> [String])
-> [String]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (TypeRep -> (CallStack, CallStack) -> [String])
-> Map TypeRep (CallStack, CallStack) -> [String]
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey Map TypeRep (CallStack, CallStack)
doubleDutyMap \TypeRep
rep (CallStack
secCS, CallStack
primCS) ->
             [ String
"- " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
rep String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is a secondary bean in this constructor:"
             ]
               [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ((String
"\t" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CallStack -> [String]
prettyCallStackLines CallStack
secCS)
               [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"  and a primary bean in this recipe:"
                  ]
               [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ((String
"\t" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CallStack -> [String]
prettyCallStackLines CallStack
primCS)
         )
  DependencyCycleError (DependencyCycle NonEmpty (BeanConstructionStep, Maybe CallStack)
theCycle) ->
    [ String
"Forbidden dependency cycle between bean construction steps:"
    ]
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ( (((BeanConstructionStep, Maybe CallStack) -> [String])
 -> NonEmpty (BeanConstructionStep, Maybe CallStack) -> [String])
-> NonEmpty (BeanConstructionStep, Maybe CallStack)
-> ((BeanConstructionStep, Maybe CallStack) -> [String])
-> [String]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((BeanConstructionStep, Maybe CallStack) -> [String])
-> NonEmpty (BeanConstructionStep, Maybe CallStack) -> [String]
forall m a. Monoid m => (a -> m) -> NonEmpty a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap NonEmpty (BeanConstructionStep, Maybe CallStack)
theCycle \(BeanConstructionStep
step, Maybe CallStack
mstack) ->
             [ String
"- " String -> ShowS
forall a. [a] -> [a] -> [a]
++ case BeanConstructionStep
step of
                 BarePrimaryBean TypeRep
rep -> String
"Bare bean " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
rep
                 PrimaryBeanDeco TypeRep
rep Int
i -> String
"Decorator " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" for bean " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
rep
                 PrimaryBean TypeRep
rep -> String
"Complete bean " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
rep
                 SecondaryBean TypeRep
rep -> String
"Secondary bean " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
rep
             ]
               [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ case Maybe CallStack
mstack of
                 Maybe CallStack
Nothing -> []
                 Just CallStack
stack -> ((String
"\t" String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CallStack -> [String]
prettyCallStackLines CallStack
stack)
         )

-- | An edge means that the source depends on the target.
--
-- The dependencies of each bean are given separatedly from its decorators.
newtype DependencyGraph = DependencyGraph {DependencyGraph -> AdjacencyMap BeanConstructionStep
graph :: AdjacencyMap BeanConstructionStep}
  deriving newtype (Int -> DependencyGraph -> ShowS
[DependencyGraph] -> ShowS
DependencyGraph -> String
(Int -> DependencyGraph -> ShowS)
-> (DependencyGraph -> String)
-> ([DependencyGraph] -> ShowS)
-> Show DependencyGraph
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DependencyGraph -> ShowS
showsPrec :: Int -> DependencyGraph -> ShowS
$cshow :: DependencyGraph -> String
show :: DependencyGraph -> String
$cshowList :: [DependencyGraph] -> ShowS
showList :: [DependencyGraph] -> ShowS
Show, DependencyGraph -> DependencyGraph -> Bool
(DependencyGraph -> DependencyGraph -> Bool)
-> (DependencyGraph -> DependencyGraph -> Bool)
-> Eq DependencyGraph
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DependencyGraph -> DependencyGraph -> Bool
== :: DependencyGraph -> DependencyGraph -> Bool
$c/= :: DependencyGraph -> DependencyGraph -> Bool
/= :: DependencyGraph -> DependencyGraph -> Bool
Eq, Eq DependencyGraph
Eq DependencyGraph =>
(DependencyGraph -> DependencyGraph -> Ordering)
-> (DependencyGraph -> DependencyGraph -> Bool)
-> (DependencyGraph -> DependencyGraph -> Bool)
-> (DependencyGraph -> DependencyGraph -> Bool)
-> (DependencyGraph -> DependencyGraph -> Bool)
-> (DependencyGraph -> DependencyGraph -> DependencyGraph)
-> (DependencyGraph -> DependencyGraph -> DependencyGraph)
-> Ord DependencyGraph
DependencyGraph -> DependencyGraph -> Bool
DependencyGraph -> DependencyGraph -> Ordering
DependencyGraph -> DependencyGraph -> DependencyGraph
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DependencyGraph -> DependencyGraph -> Ordering
compare :: DependencyGraph -> DependencyGraph -> Ordering
$c< :: DependencyGraph -> DependencyGraph -> Bool
< :: DependencyGraph -> DependencyGraph -> Bool
$c<= :: DependencyGraph -> DependencyGraph -> Bool
<= :: DependencyGraph -> DependencyGraph -> Bool
$c> :: DependencyGraph -> DependencyGraph -> Bool
> :: DependencyGraph -> DependencyGraph -> Bool
$c>= :: DependencyGraph -> DependencyGraph -> Bool
>= :: DependencyGraph -> DependencyGraph -> Bool
$cmax :: DependencyGraph -> DependencyGraph -> DependencyGraph
max :: DependencyGraph -> DependencyGraph -> DependencyGraph
$cmin :: DependencyGraph -> DependencyGraph -> DependencyGraph
min :: DependencyGraph -> DependencyGraph -> DependencyGraph
Ord, NonEmpty DependencyGraph -> DependencyGraph
DependencyGraph -> DependencyGraph -> DependencyGraph
(DependencyGraph -> DependencyGraph -> DependencyGraph)
-> (NonEmpty DependencyGraph -> DependencyGraph)
-> (forall b.
    Integral b =>
    b -> DependencyGraph -> DependencyGraph)
-> Semigroup DependencyGraph
forall b. Integral b => b -> DependencyGraph -> DependencyGraph
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: DependencyGraph -> DependencyGraph -> DependencyGraph
<> :: DependencyGraph -> DependencyGraph -> DependencyGraph
$csconcat :: NonEmpty DependencyGraph -> DependencyGraph
sconcat :: NonEmpty DependencyGraph -> DependencyGraph
$cstimes :: forall b. Integral b => b -> DependencyGraph -> DependencyGraph
stimes :: forall b. Integral b => b -> DependencyGraph -> DependencyGraph
Semigroup, Semigroup DependencyGraph
DependencyGraph
Semigroup DependencyGraph =>
DependencyGraph
-> (DependencyGraph -> DependencyGraph -> DependencyGraph)
-> ([DependencyGraph] -> DependencyGraph)
-> Monoid DependencyGraph
[DependencyGraph] -> DependencyGraph
DependencyGraph -> DependencyGraph -> DependencyGraph
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: DependencyGraph
mempty :: DependencyGraph
$cmappend :: DependencyGraph -> DependencyGraph -> DependencyGraph
mappend :: DependencyGraph -> DependencyGraph -> DependencyGraph
$cmconcat :: [DependencyGraph] -> DependencyGraph
mconcat :: [DependencyGraph] -> DependencyGraph
Monoid)

-- | Conversion to a graph type
-- from the
-- [algebraic-graphs](https://hackage.haskell.org/package/algebraic-graphs-0.7/docs/Algebra-Graph-AdjacencyMap.html)
-- library for further processing.
toAdjacencyMap :: DependencyGraph -> AdjacencyMap BeanConstructionStep
toAdjacencyMap :: DependencyGraph -> AdjacencyMap BeanConstructionStep
toAdjacencyMap DependencyGraph {AdjacencyMap BeanConstructionStep
graph :: DependencyGraph -> AdjacencyMap BeanConstructionStep
graph :: AdjacencyMap BeanConstructionStep
graph} = AdjacencyMap BeanConstructionStep
graph

-- | Remove all vertices and edges related to secondary beans.
removeSecondaryBeans :: DependencyGraph -> DependencyGraph
removeSecondaryBeans :: DependencyGraph -> DependencyGraph
removeSecondaryBeans DependencyGraph {AdjacencyMap BeanConstructionStep
graph :: DependencyGraph -> AdjacencyMap BeanConstructionStep
graph :: AdjacencyMap BeanConstructionStep
graph} =
  DependencyGraph {graph :: AdjacencyMap BeanConstructionStep
graph = (BeanConstructionStep -> Bool)
-> AdjacencyMap BeanConstructionStep
-> AdjacencyMap BeanConstructionStep
forall a. (a -> Bool) -> AdjacencyMap a -> AdjacencyMap a
Graph.induce (\case SecondaryBean {} -> Bool
False; BeanConstructionStep
_ -> Bool
True) AdjacencyMap BeanConstructionStep
graph}

-- | Remove all vertices and edges related to bean decorators.
removeDecos :: DependencyGraph -> DependencyGraph
removeDecos :: DependencyGraph -> DependencyGraph
removeDecos DependencyGraph {AdjacencyMap BeanConstructionStep
graph :: DependencyGraph -> AdjacencyMap BeanConstructionStep
graph :: AdjacencyMap BeanConstructionStep
graph} =
  DependencyGraph {graph :: AdjacencyMap BeanConstructionStep
graph = (BeanConstructionStep -> Bool)
-> AdjacencyMap BeanConstructionStep
-> AdjacencyMap BeanConstructionStep
forall a. (a -> Bool) -> AdjacencyMap a -> AdjacencyMap a
Graph.induce (\case PrimaryBeanDeco {} -> Bool
False; BeanConstructionStep
_ -> Bool
True) AdjacencyMap BeanConstructionStep
graph}

-- | Unifies 'PrimaryBean's with their respective 'BarePrimaryBean's and 'PrimaryBeanDeco's.
--
-- Also removes any self-loops.
collapseToPrimaryBeans :: DependencyGraph -> DependencyGraph
collapseToPrimaryBeans :: DependencyGraph -> DependencyGraph
collapseToPrimaryBeans DependencyGraph {AdjacencyMap BeanConstructionStep
graph :: DependencyGraph -> AdjacencyMap BeanConstructionStep
graph :: AdjacencyMap BeanConstructionStep
graph} = do
  let simplified :: AdjacencyMap BeanConstructionStep
simplified =
        (BeanConstructionStep -> BeanConstructionStep)
-> AdjacencyMap BeanConstructionStep
-> AdjacencyMap BeanConstructionStep
forall a b.
(Ord a, Ord b) =>
(a -> b) -> AdjacencyMap a -> AdjacencyMap b
Graph.gmap
          ( \case
              BarePrimaryBean TypeRep
rep -> TypeRep -> BeanConstructionStep
PrimaryBean TypeRep
rep
              PrimaryBeanDeco TypeRep
rep Int
_ -> TypeRep -> BeanConstructionStep
PrimaryBean TypeRep
rep
              BeanConstructionStep
other -> BeanConstructionStep
other
          )
          AdjacencyMap BeanConstructionStep
graph
      -- Is there a simpler way to removoe self-loops?
      vertices :: Plan
vertices = AdjacencyMap BeanConstructionStep -> Plan
forall a. AdjacencyMap a -> [a]
Graph.vertexList AdjacencyMap BeanConstructionStep
simplified
      edges :: [(BeanConstructionStep, BeanConstructionStep)]
edges = AdjacencyMap BeanConstructionStep
-> [(BeanConstructionStep, BeanConstructionStep)]
forall a. AdjacencyMap a -> [(a, a)]
Graph.edgeList AdjacencyMap BeanConstructionStep
simplified
      edgesWithoutSelfLoops :: [(BeanConstructionStep, BeanConstructionStep)]
edgesWithoutSelfLoops =
        ((BeanConstructionStep, BeanConstructionStep) -> Bool)
-> [(BeanConstructionStep, BeanConstructionStep)]
-> [(BeanConstructionStep, BeanConstructionStep)]
forall a. (a -> Bool) -> [a] -> [a]
filter
          ( \case
              (PrimaryBean TypeRep
source, PrimaryBean TypeRep
target) -> if TypeRep
source TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== TypeRep
target then Bool
False else Bool
True
              (BeanConstructionStep, BeanConstructionStep)
_ -> Bool
True
          )
          [(BeanConstructionStep, BeanConstructionStep)]
edges
  DependencyGraph {graph :: AdjacencyMap BeanConstructionStep
graph = Plan -> AdjacencyMap BeanConstructionStep
forall a. Ord a => [a] -> AdjacencyMap a
Graph.vertices Plan
vertices AdjacencyMap BeanConstructionStep
-> AdjacencyMap BeanConstructionStep
-> AdjacencyMap BeanConstructionStep
forall a.
Ord a =>
AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a
`Graph.overlay` [(BeanConstructionStep, BeanConstructionStep)]
-> AdjacencyMap BeanConstructionStep
forall a. Ord a => [(a, a)] -> AdjacencyMap a
Graph.edges [(BeanConstructionStep, BeanConstructionStep)]
edgesWithoutSelfLoops}

-- | See the [DOT format](https://graphviz.org/doc/info/lang.html).
writeAsDot :: Dot.Style BeanConstructionStep Data.Text.Text -> FilePath -> DependencyGraph -> IO ()
writeAsDot :: Style BeanConstructionStep Text
-> String -> DependencyGraph -> IO ()
writeAsDot Style BeanConstructionStep Text
style String
filepath DependencyGraph {AdjacencyMap BeanConstructionStep
graph :: DependencyGraph -> AdjacencyMap BeanConstructionStep
graph :: AdjacencyMap BeanConstructionStep
graph} = do
  let dot :: Text
dot = Style BeanConstructionStep Text
-> AdjacencyMap BeanConstructionStep -> Text
forall s a g.
(IsString s, Monoid s, Ord a, ToGraph g, ToVertex g ~ a) =>
Style a s -> g -> s
Dot.export Style BeanConstructionStep Text
style AdjacencyMap BeanConstructionStep
graph
  String -> ByteString -> IO ()
Data.ByteString.writeFile String
filepath (Text -> ByteString
Data.Text.Encoding.encodeUtf8 Text
dot)

-- | Default DOT rendering style to use with 'writeAsDot'.
-- When a 'RecipeError' exists, is highlights the problematic 'BeanConstructionStep's.
defaultStyle :: Maybe RecipeError -> Dot.Style BeanConstructionStep Data.Text.Text
defaultStyle :: Maybe RecipeError -> Style BeanConstructionStep Text
defaultStyle Maybe RecipeError
merr =
  -- https://graphviz.org/docs/attr-types/style/
  -- https://hackage.haskell.org/package/algebraic-graphs-0.7/docs/Algebra-Graph-Export-Dot.html
  ((BeanConstructionStep -> Text) -> Style BeanConstructionStep Text
forall s a. Monoid s => (a -> s) -> Style a s
Dot.defaultStyle BeanConstructionStep -> Text
defaultStepToText)
    { Dot.vertexAttributes = \BeanConstructionStep
step -> case Maybe RecipeError
merr of
        Maybe RecipeError
Nothing -> []
        Just (MissingDependenciesError (MissingDependencies CallStack
_ TypeRep
_ Set TypeRep
missing)) ->
          case BeanConstructionStep
step of
            PrimaryBean TypeRep
rep
              | TypeRep -> Set TypeRep -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member TypeRep
rep Set TypeRep
missing ->
                  [ String -> Text
Data.Text.pack String
"style" Text -> Text -> Attribute Text
forall s. s -> s -> Attribute s
Dot.:= String -> Text
Data.Text.pack String
"dashed",
                    String -> Text
Data.Text.pack String
"color" Text -> Text -> Attribute Text
forall s. s -> s -> Attribute s
Dot.:= String -> Text
Data.Text.pack String
"red"
                  ]
            BeanConstructionStep
_ -> []
        Just (DoubleDutyBeansError (DoubleDutyBeans (Map TypeRep (CallStack, CallStack) -> Set TypeRep
forall k a. Map k a -> Set k
Map.keysSet -> Set TypeRep
bs))) ->
          case BeanConstructionStep
step of
            PrimaryBean TypeRep
rep
              | TypeRep -> Set TypeRep -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member TypeRep
rep Set TypeRep
bs ->
                  [ String -> Text
Data.Text.pack String
"style" Text -> Text -> Attribute Text
forall s. s -> s -> Attribute s
Dot.:= String -> Text
Data.Text.pack String
"bold",
                    String -> Text
Data.Text.pack String
"color" Text -> Text -> Attribute Text
forall s. s -> s -> Attribute s
Dot.:= String -> Text
Data.Text.pack String
"green"
                  ]
            SecondaryBean TypeRep
rep
              | TypeRep -> Set TypeRep -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member TypeRep
rep Set TypeRep
bs ->
                  [ String -> Text
Data.Text.pack String
"style" Text -> Text -> Attribute Text
forall s. s -> s -> Attribute s
Dot.:= String -> Text
Data.Text.pack String
"bold",
                    String -> Text
Data.Text.pack String
"color" Text -> Text -> Attribute Text
forall s. s -> s -> Attribute s
Dot.:= String -> Text
Data.Text.pack String
"green"
                  ]
            BeanConstructionStep
_ -> []
        Just (DependencyCycleError (DependencyCycle (Plan -> Set BeanConstructionStep
forall a. Ord a => [a] -> Set a
Set.fromList (Plan -> Set BeanConstructionStep)
-> (NonEmpty (BeanConstructionStep, Maybe CallStack) -> Plan)
-> NonEmpty (BeanConstructionStep, Maybe CallStack)
-> Set BeanConstructionStep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cycle BeanConstructionStep -> Plan
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Data.Foldable.toList (Cycle BeanConstructionStep -> Plan)
-> (NonEmpty (BeanConstructionStep, Maybe CallStack)
    -> Cycle BeanConstructionStep)
-> NonEmpty (BeanConstructionStep, Maybe CallStack)
-> Plan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((BeanConstructionStep, Maybe CallStack) -> BeanConstructionStep)
-> NonEmpty (BeanConstructionStep, Maybe CallStack)
-> Cycle BeanConstructionStep
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (BeanConstructionStep, Maybe CallStack) -> BeanConstructionStep
forall a b. (a, b) -> a
fst -> Set BeanConstructionStep
cycleStepSet))) ->
          if BeanConstructionStep -> Set BeanConstructionStep -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member BeanConstructionStep
step Set BeanConstructionStep
cycleStepSet
            then
              [ String -> Text
Data.Text.pack String
"style" Text -> Text -> Attribute Text
forall s. s -> s -> Attribute s
Dot.:= String -> Text
Data.Text.pack String
"bold",
                String -> Text
Data.Text.pack String
"color" Text -> Text -> Attribute Text
forall s. s -> s -> Attribute s
Dot.:= String -> Text
Data.Text.pack String
"blue"
              ]
            else []
    }

-- | Change the default way of how 'BeanConstructionStep's are rendered to text.
setVertexName :: (BeanConstructionStep -> Data.Text.Text) -> Dot.Style BeanConstructionStep Data.Text.Text -> Dot.Style BeanConstructionStep Data.Text.Text
setVertexName :: (BeanConstructionStep -> Text)
-> Style BeanConstructionStep Text
-> Style BeanConstructionStep Text
setVertexName BeanConstructionStep -> Text
vertexName Style BeanConstructionStep Text
style = Style BeanConstructionStep Text
style {Dot.vertexName}

defaultStepToText :: BeanConstructionStep -> Data.Text.Text
defaultStepToText :: BeanConstructionStep -> Text
defaultStepToText =
  let p :: a -> Text
p a
rep = String -> Text
Data.Text.pack do a -> String
forall a. Show a => a -> String
show a
rep
   in \case
        BarePrimaryBean TypeRep
rep -> TypeRep -> Text
forall {a}. Show a => a -> Text
p TypeRep
rep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Data.Text.pack String
"#bare"
        PrimaryBeanDeco TypeRep
rep Int
index -> TypeRep -> Text
forall {a}. Show a => a -> Text
p TypeRep
rep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Data.Text.pack (String
"#deco#" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
index)
        PrimaryBean TypeRep
rep -> TypeRep -> Text
forall {a}. Show a => a -> Text
p TypeRep
rep
        SecondaryBean TypeRep
rep -> TypeRep -> Text
forall {a}. Show a => a -> Text
p TypeRep
rep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Data.Text.pack String
"#agg"

nonEmptyToTree :: NonEmpty a -> Tree a
nonEmptyToTree :: forall a. NonEmpty a -> Tree a
nonEmptyToTree = \case
  a
a Data.List.NonEmpty.:| [] -> a -> [Tree a] -> Tree a
forall a. a -> [Tree a] -> Tree a
Node a
a []
  a
a Data.List.NonEmpty.:| (a
b : [a]
rest) -> a -> [Tree a] -> Tree a
forall a. a -> [Tree a] -> Tree a
Node a
a [NonEmpty a -> Tree a
forall a. NonEmpty a -> Tree a
nonEmptyToTree (a
b a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
Data.List.NonEmpty.:| [a]
rest)]

unsafeTreeToNonEmpty :: Tree a -> NonEmpty a
unsafeTreeToNonEmpty :: forall a. Tree a -> NonEmpty a
unsafeTreeToNonEmpty = \case
  Node a
a [] -> a
a a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
Data.List.NonEmpty.:| []
  Node a
a [Tree a
b] -> a -> NonEmpty a -> NonEmpty a
forall a. a -> NonEmpty a -> NonEmpty a
Data.List.NonEmpty.cons a
a (Tree a -> NonEmpty a
forall a. Tree a -> NonEmpty a
unsafeTreeToNonEmpty Tree a
b)
  Tree a
_ -> String -> NonEmpty a
forall a. HasCallStack => String -> a
error String
"tree not list-shaped"

-- | A way of building value of type @bean@, potentially requiring some
-- dependencies, potentially returning some secondary beans
-- along the primary @bean@ result, and also potentially requiring some
-- initialization effect in a monad @m@.
--
-- Note that only the type of the primary @bean@ is reflected in the
-- 'Constructor' type. Those of the dependencies and secondary beans are not.
--
-- A typical initialization monad will be 'IO', used for example to create
-- mutable references that the bean will use internally. Sometimes the
-- constructor will allocate resources with bracket-like operations, and in that
-- case a monad like 'Cauldron.Managed.Managed' might be needed instead.
data Constructor m bean = Constructor
  { forall (m :: * -> *) bean. Constructor m bean -> CallStack
_constructorCallStack :: CallStack,
    forall (m :: * -> *) bean.
Constructor m bean -> Args (m (Regs bean))
_args :: Args (m (Regs bean))
  }

-- | Create a 'Constructor' from an 'Args' value that returns a 'bean'.
--
-- Usually, the 'Args' value will be created by 'wire'ing a constructor function.
val_ :: forall bean m. (Applicative m, HasCallStack) => Args bean -> Constructor m bean
val_ :: forall bean (m :: * -> *).
(Applicative m, HasCallStack) =>
Args bean -> Constructor m bean
val_ Args bean
x = CallStack -> Args (m (Regs bean)) -> Constructor m bean
forall (m :: * -> *) bean.
CallStack -> Args (m (Regs bean)) -> Constructor m bean
Constructor CallStack
HasCallStack => CallStack
callStack (Args (m (Regs bean)) -> Constructor m bean)
-> Args (m (Regs bean)) -> Constructor m bean
forall a b. (a -> b) -> a -> b
$ (bean -> m (Regs bean)) -> Args bean -> Args (m (Regs bean))
forall a b. (a -> b) -> Args a -> Args b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Regs bean -> m (Regs bean)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Regs bean -> m (Regs bean))
-> (bean -> Regs bean) -> bean -> m (Regs bean)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. bean -> Regs bean
forall a. a -> Regs a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) Args bean
x

-- | Like 'val_', but examines the @nested@ value returned by the 'Args' looking
-- for (potentially nested) tuples.  All tuple components except the
-- rightmost-innermost one are registered as secondary beans (if they have
-- 'Monoid' instances, otherwise 'val' won't compile).
val :: forall {nested} bean m. (Registrable nested bean, Applicative m, HasCallStack) => Args nested -> Constructor m bean
val :: forall {nested} bean (m :: * -> *).
(Registrable nested bean, Applicative m, HasCallStack) =>
Args nested -> Constructor m bean
val Args nested
x = (HasCallStack => Constructor m bean) -> Constructor m bean
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (Args (Regs bean) -> Constructor m bean
forall bean (m :: * -> *).
(Applicative m, HasCallStack) =>
Args (Regs bean) -> Constructor m bean
val' (Args (Regs bean) -> Constructor m bean)
-> Args (Regs bean) -> Constructor m bean
forall a b. (a -> b) -> a -> b
$ (Identity (Regs bean) -> Regs bean)
-> Args (Identity (Regs bean)) -> Args (Regs bean)
forall a b. (a -> b) -> Args a -> Args b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Identity (Regs bean) -> Regs bean
forall a. Identity a -> a
runIdentity (Args (Identity (Regs bean)) -> Args (Regs bean))
-> Args (Identity (Regs bean)) -> Args (Regs bean)
forall a b. (a -> b) -> a -> b
$ Args (Identity nested) -> Args (Identity (Regs bean))
forall nested tip (m :: * -> *).
(Registrable nested tip, Functor m) =>
Args (m nested) -> Args (m (Regs tip))
forall (m :: * -> *).
Functor m =>
Args (m nested) -> Args (m (Regs bean))
register (Args (Identity nested) -> Args (Identity (Regs bean)))
-> Args (Identity nested) -> Args (Identity (Regs bean))
forall a b. (a -> b) -> a -> b
$ (nested -> Identity nested)
-> Args nested -> Args (Identity nested)
forall a b. (a -> b) -> Args a -> Args b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap nested -> Identity nested
forall a. a -> Identity a
Identity Args nested
x)

-- | Like 'val', but uses an alternative form of registering secondary beans.
-- Less 'Registrable' typeclass magic, but more verbose. Likely not what you want.
val' :: forall bean m. (Applicative m, HasCallStack) => Args (Regs bean) -> Constructor m bean
val' :: forall bean (m :: * -> *).
(Applicative m, HasCallStack) =>
Args (Regs bean) -> Constructor m bean
val' Args (Regs bean)
x = CallStack -> Args (m (Regs bean)) -> Constructor m bean
forall (m :: * -> *) bean.
CallStack -> Args (m (Regs bean)) -> Constructor m bean
Constructor CallStack
HasCallStack => CallStack
callStack (Args (m (Regs bean)) -> Constructor m bean)
-> Args (m (Regs bean)) -> Constructor m bean
forall a b. (a -> b) -> a -> b
$ (Regs bean -> m (Regs bean))
-> Args (Regs bean) -> Args (m (Regs bean))
forall a b. (a -> b) -> Args a -> Args b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Regs bean -> m (Regs bean)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Args (Regs bean)
x

-- | Create a 'Constructor' from an 'Args' value that returns an initialization
-- effect that produces 'bean'.
--
-- Usually, the 'Args' value will be created by 'wire'ing an effectul constructor function.
eff_ :: forall bean m. (Functor m, HasCallStack) => Args (m bean) -> Constructor m bean
eff_ :: forall bean (m :: * -> *).
(Functor m, HasCallStack) =>
Args (m bean) -> Constructor m bean
eff_ Args (m bean)
x = CallStack -> Args (m (Regs bean)) -> Constructor m bean
forall (m :: * -> *) bean.
CallStack -> Args (m (Regs bean)) -> Constructor m bean
Constructor CallStack
HasCallStack => CallStack
callStack (Args (m (Regs bean)) -> Constructor m bean)
-> Args (m (Regs bean)) -> Constructor m bean
forall a b. (a -> b) -> a -> b
$ (m bean -> m (Regs bean)) -> Args (m bean) -> Args (m (Regs bean))
forall a b. (a -> b) -> Args a -> Args b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((bean -> Regs bean) -> m bean -> m (Regs bean)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap bean -> Regs bean
forall a. a -> Regs a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) Args (m bean)
x

-- | Like 'eff_', but lifts 'IO' constructor effects into a general 'MonadIO'.
ioEff_ :: forall bean m. (MonadIO m, HasCallStack) => Args (IO bean) -> Constructor m bean
ioEff_ :: forall bean (m :: * -> *).
(MonadIO m, HasCallStack) =>
Args (IO bean) -> Constructor m bean
ioEff_ Args (IO bean)
args = (HasCallStack => Constructor m bean) -> Constructor m bean
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((forall x. IO x -> m x)
-> Constructor IO bean -> Constructor m bean
forall (m :: * -> *) (n :: * -> *) bean.
(forall x. m x -> n x) -> Constructor m bean -> Constructor n bean
hoistConstructor IO x -> m x
forall x. IO x -> m x
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Args (IO bean) -> Constructor IO bean
forall bean (m :: * -> *).
(Functor m, HasCallStack) =>
Args (m bean) -> Constructor m bean
eff_ Args (IO bean)
args))

-- | Like 'eff_', but examines the @nested@ value produced by the action
-- returned by the 'Args' looking for (potentially nested) tuples.  All tuple
-- components except the rightmost-innermost one are registered as secondary
-- beans (if they have 'Monoid' instances, otherwise 'eff' won't compile).
eff :: forall {nested} bean m. (Registrable nested bean, Monad m, HasCallStack) => Args (m nested) -> Constructor m bean
eff :: forall {nested} bean (m :: * -> *).
(Registrable nested bean, Monad m, HasCallStack) =>
Args (m nested) -> Constructor m bean
eff Args (m nested)
x = (HasCallStack => Constructor m bean) -> Constructor m bean
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (Args (m (Regs bean)) -> Constructor m bean
forall bean (m :: * -> *).
HasCallStack =>
Args (m (Regs bean)) -> Constructor m bean
eff' (Args (m (Regs bean)) -> Constructor m bean)
-> Args (m (Regs bean)) -> Constructor m bean
forall a b. (a -> b) -> a -> b
$ Args (m nested) -> Args (m (Regs bean))
forall nested tip (m :: * -> *).
(Registrable nested tip, Functor m) =>
Args (m nested) -> Args (m (Regs tip))
forall (m :: * -> *).
Functor m =>
Args (m nested) -> Args (m (Regs bean))
register Args (m nested)
x)

-- | Like 'eff', but lifts 'IO' constructor effects into a general 'MonadIO'.
ioEff :: forall {nested} bean m. (Registrable nested bean, MonadIO m, HasCallStack) => Args (IO nested) -> Constructor m bean
ioEff :: forall {nested} bean (m :: * -> *).
(Registrable nested bean, MonadIO m, HasCallStack) =>
Args (IO nested) -> Constructor m bean
ioEff Args (IO nested)
args = (HasCallStack => Constructor m bean) -> Constructor m bean
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((forall x. IO x -> m x)
-> Constructor IO bean -> Constructor m bean
forall (m :: * -> *) (n :: * -> *) bean.
(forall x. m x -> n x) -> Constructor m bean -> Constructor n bean
hoistConstructor IO x -> m x
forall x. IO x -> m x
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Args (IO nested) -> Constructor IO bean
forall {nested} bean (m :: * -> *).
(Registrable nested bean, Monad m, HasCallStack) =>
Args (m nested) -> Constructor m bean
eff Args (IO nested)
args))

-- | Like 'eff', but uses an alternative form of registering secondary beans.
-- Less 'Registrable' typeclass magic, but more verbose. Likely not what you want.
eff' :: forall bean m. (HasCallStack) => Args (m (Regs bean)) -> Constructor m bean
eff' :: forall bean (m :: * -> *).
HasCallStack =>
Args (m (Regs bean)) -> Constructor m bean
eff' = CallStack -> Args (m (Regs bean)) -> Constructor m bean
forall (m :: * -> *) bean.
CallStack -> Args (m (Regs bean)) -> Constructor m bean
Constructor CallStack
HasCallStack => CallStack
callStack

runConstructor :: (Monad m) => [Beans] -> Constructor m bean -> m (Beans, bean)
runConstructor :: forall (m :: * -> *) bean.
Monad m =>
[Beans] -> Constructor m bean -> m (Beans, bean)
runConstructor [Beans]
bss (Constructor {Args (m (Regs bean))
_args :: forall (m :: * -> *) bean.
Constructor m bean -> Args (m (Regs bean))
_args :: Args (m (Regs bean))
_args}) = do
  regs <- Args (m (Regs bean))
_args Args (m (Regs bean))
-> (Args (m (Regs bean)) -> m (Regs bean)) -> m (Regs bean)
forall a b. a -> (a -> b) -> b
& (forall b. Typeable b => Maybe b)
-> Args (m (Regs bean)) -> m (Regs bean)
forall a. (forall b. Typeable b => Maybe b) -> Args a -> a
runArgs ([Maybe b] -> Maybe b
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
Data.Foldable.asum (Beans -> Maybe b
forall bean. Typeable bean => Beans -> Maybe bean
taste (Beans -> Maybe b) -> [Beans] -> [Maybe b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Beans]
bss))
  pure (runRegs (getRegsReps _args) regs)

-- | Change the monad in which the 'Constructor'\'s effects take place.
hoistConstructor :: (forall x. m x -> n x) -> Constructor m bean -> Constructor n bean
hoistConstructor :: forall (m :: * -> *) (n :: * -> *) bean.
(forall x. m x -> n x) -> Constructor m bean -> Constructor n bean
hoistConstructor forall x. m x -> n x
f c :: Constructor m bean
c@Constructor {Args (m (Regs bean))
_args :: forall (m :: * -> *) bean.
Constructor m bean -> Args (m (Regs bean))
_args :: Args (m (Regs bean))
_args} = Constructor m bean
c {_args = fmap f _args}

-- | More general form of 'hoistConstructor' that enables precise control over the inner `Args`.
hoistConstructor' :: (Args (m (Regs bean)) -> Args (n (Regs bean))) -> Constructor m bean -> Constructor n bean
hoistConstructor' :: forall (m :: * -> *) bean (n :: * -> *).
(Args (m (Regs bean)) -> Args (n (Regs bean)))
-> Constructor m bean -> Constructor n bean
hoistConstructor' Args (m (Regs bean)) -> Args (n (Regs bean))
f c :: Constructor m bean
c@Constructor {Args (m (Regs bean))
_args :: forall (m :: * -> *) bean.
Constructor m bean -> Args (m (Regs bean))
_args :: Args (m (Regs bean))
_args} = Constructor m bean
c {_args = f _args}

-- | Get the inner 'Args' value for the 'Constructor', typically for inspecting
-- 'TypeRep's of its arguments/registrations.
getConstructorArgs :: Constructor m bean -> Args (m (Regs bean))
getConstructorArgs :: forall (m :: * -> *) bean.
Constructor m bean -> Args (m (Regs bean))
getConstructorArgs (Constructor {Args (m (Regs bean))
_args :: forall (m :: * -> *) bean.
Constructor m bean -> Args (m (Regs bean))
_args :: Args (m (Regs bean))
_args}) = Args (m (Regs bean))
_args

-- | For debugging purposes, 'Constructor's remember the 'CallStack'
-- of when they were created.
getConstructorCallStack :: Constructor m bean -> CallStack
getConstructorCallStack :: forall (m :: * -> *) bean. Constructor m bean -> CallStack
getConstructorCallStack (Constructor {CallStack
_constructorCallStack :: forall (m :: * -> *) bean. Constructor m bean -> CallStack
_constructorCallStack :: CallStack
_constructorCallStack}) = CallStack
_constructorCallStack

-- | For debugging purposes, 'SomeRecipe's remember the 'CallStack'
-- of when they were created.
getRecipeCallStack :: SomeRecipe m -> CallStack
getRecipeCallStack :: forall (m :: * -> *). SomeRecipe m -> CallStack
getRecipeCallStack (SomeRecipe {CallStack
_recipeCallStack :: forall (m :: * -> *). SomeRecipe m -> CallStack
_recipeCallStack :: CallStack
_recipeCallStack}) = CallStack
_recipeCallStack

-- | The set of all 'TypeRep' keys of the map.
keysSet :: Cauldron m -> Set TypeRep
keysSet :: forall (m :: * -> *). Cauldron m -> Set TypeRep
keysSet Cauldron {Map TypeRep (SomeRecipe m)
recipeMap :: forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeRecipe m)
recipeMap :: Map TypeRep (SomeRecipe m)
recipeMap} = Map TypeRep (SomeRecipe m) -> Set TypeRep
forall k a. Map k a -> Set k
Map.keysSet Map TypeRep (SomeRecipe m)
recipeMap

-- | Restrict a 'Cauldron' to only those 'TypeRep's found in a 'Set'.
restrictKeys :: Cauldron m -> Set TypeRep -> Cauldron m
restrictKeys :: forall (m :: * -> *). Cauldron m -> Set TypeRep -> Cauldron m
restrictKeys Cauldron {Map TypeRep (SomeRecipe m)
recipeMap :: forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeRecipe m)
recipeMap :: Map TypeRep (SomeRecipe m)
recipeMap} Set TypeRep
trs = Cauldron {recipeMap :: Map TypeRep (SomeRecipe m)
recipeMap = Map TypeRep (SomeRecipe m)
-> Set TypeRep -> Map TypeRep (SomeRecipe m)
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map TypeRep (SomeRecipe m)
recipeMap Set TypeRep
trs}

-- $simplifygraph
--
-- 'DependencyGraph's can get complex and difficult to intepret because they
-- include bean decorators and secondary beans, details in which we many not be
-- interested.
--
-- These functions help simplify 'DependencyGraph's before passing them to
-- 'writeAsDot'. They can be composed between themselves.

-- $secondarybeans
--
-- There is an exception to the 'Cauldron' rule that each bean type can only
-- be produced by a single 'Recipe' in the 'Cauldron'.
--
-- 'Constructor's can produce, besides their \"primary\" bean result,
-- \"secondary\" beans that are not reflected in the 'Constructor' signature.
-- Multiple constructors across different 'Recipe's can produce secondary beans of the
-- same type.
--
-- Secondary beans are a bit special, in that:
--
-- * The value that is \"seen"\ by a 'Constructor' that depends on a secondary bean
--   is the aggregation of /all/ values produced for that bean in the 'Cauldron'. This
--   means that secondary beans must have 'Monoid' instances, to enable aggregation.
--
-- * When calculating build plan steps for a 'Cauldron', 'Constructor's that depend on a
--   secondary bean come after /all/ of the 'Constructor's that produce that secondary bean.
--
-- * Secondary beans can't be decorated.
--
-- * A bean type can't be primary and secondary at the same time. See 'DoubleDutyBeansError'.
--
-- What are secondary beans useful for?
--
-- * Exposing some uniform control or inspection interface for certain beans.
--
-- * Registering tasks or workers that must be run after application initialization.
--
-- The simplest way of registering secondary beans is to pass an 'Args' value returning a tuple
-- to the 'val' (for pure constructors) or 'eff' (for effectful constructors) functions. Components
-- of the tuple other than the rightmost component are considered secondary beans:
--
-- >>> :{
-- con :: Constructor Identity String
-- con = val $ pure (Sum @Int, All False, "foo")
-- effCon :: Constructor IO String
-- effCon = eff $ pure $ pure @IO (Sum @Int, All False, "foo")
-- :}
--
-- Example of how secondary bean values are accumulated:
--
-- >>> :{
-- data U = U deriving Show
-- data V = V deriving Show
-- makeU :: (Sum Int, U)
-- makeU = (Sum 1, U)
-- makeV :: U -> (Sum Int, V)
-- makeV = \_ -> (Sum 7, V)
-- newtype W = W (Sum Int) deriving Show -- depends on the secondary bean
-- :}
--
-- >>> :{
-- do
--   let cauldron :: Cauldron Identity
--       cauldron = [
--           recipe @U $ val $ wire makeU,
--           recipe @V $ val $ wire makeV,
--           recipe @W $ val $ wire W
--         ]
--   Identity beans <- either throwIO pure $ cook forbidDepCycles cauldron
--   pure $ taste @W beans
-- :}
-- Just (W (Sum {getSum = 8}))

-- $setup
-- >>> :set -XBlockArguments
-- >>> :set -XOverloadedLists
-- >>> :set -Wno-incomplete-uni-patterns
-- >>> import Data.Functor.Identity
-- >>> import Data.Function ((&))
-- >>> import Data.Monoid
-- >>> import Data.Either (either)
-- >>> import Control.Exception (throwIO)