{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# 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.
--
-- >>> :{
-- 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 =
--         emptyCauldron
--         & insert @A do makeBean do pack value makeA
--         & insert @B do makeBean do pack value makeB
--         & insert @C do makeBean do pack effect makeC
--       Right (_ :: DependencyGraph, action) = cook forbidDepCycles cauldron
--   beans <- action
--   pure do taste @C beans
-- :}
-- Just C
module Cauldron
  ( -- * Filling the cauldron
    Cauldron,
    emptyCauldron,
    insert,
    adjust,
    delete,
    hoistCauldron,

    -- * Beans
    Bean (..),
    makeBean,
    setConstructor,
    setDecos,
    overDecos,
    hoistBean,

    -- ** Decorators
    -- $decos
    Decos,
    emptyDecos,
    fromConstructors,
    addOuter,
    addInner,
    hoistDecos,

    -- ** Constructors
    -- $constructors
    Constructor,
    pack,
    pack0,
    pack1,
    pack2,
    pack3,
    hoistConstructor,
    Packer (..),
    value,
    effect,

    -- *** Registering secondary beans
    -- $registrations
    valueWith,
    effectWith,
    Regs,
    regs0,
    regs1,
    regs2,
    regs3,

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

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

    -- ** Tasting the results
    BoiledBeans,
    taste,
    BadBeans (..),
    PathToCauldron,

    -- ** Drawing deps
    DependencyGraph,
    exportToDot,
    defaultStepToText,
    BeanConstructionStep (..),
    removeSecondaryBeans,
    removeDecos,
    collapsePrimaryBeans,
    toAdjacencyMap,
  )
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 Control.Applicative
import Control.Monad.Fix
import Data.Bifunctor (first)
import Data.ByteString qualified
import Data.Dynamic
import Data.Foldable qualified
import Data.Functor (($>), (<&>))
import Data.Functor.Compose
import Data.Functor.Contravariant
import Data.Kind
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.Monoid (Endo (..))
import Data.SOP (All, And, K (..))
import Data.SOP.NP
import Data.Sequence (Seq)
import Data.Sequence qualified as Seq
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.Exts (IsList (..))
import Multicurryable
import Type.Reflection qualified

-- | A map of 'Bean' recipes. Parameterized by the monad @m@ in which the 'Bean'
-- 'Constructor's might have effects.
newtype Cauldron m where
  Cauldron :: {forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeBean m)
recipes :: Map TypeRep (SomeBean m)} -> Cauldron m

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

instance Monoid (Cauldron m) where
  mempty :: Cauldron m
mempty = Map TypeRep (SomeBean m) -> Cauldron m
forall (m :: * -> *). Map TypeRep (SomeBean m) -> Cauldron m
Cauldron do Map.empty

emptyCauldron :: Cauldron m
emptyCauldron :: forall (m :: * -> *). Cauldron m
emptyCauldron = Cauldron m
forall a. Monoid a => a
mempty

-- | Change the monad used by the beans 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 (SomeBean m)
recipes :: forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeBean m)
recipes :: Map TypeRep (SomeBean m)
recipes}) = Cauldron {recipes :: Map TypeRep (SomeBean n)
recipes = (forall x. m x -> n x) -> SomeBean m -> SomeBean n
forall (m :: * -> *) (n :: * -> *).
(forall x. m x -> n x) -> SomeBean m -> SomeBean n
hoistSomeBean m x -> n x
forall x. m x -> n x
f (SomeBean m -> SomeBean n)
-> Map TypeRep (SomeBean m) -> Map TypeRep (SomeBean n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map TypeRep (SomeBean m)
recipes}

data SomeBean m where
  SomeBean :: (Typeable bean) => Bean m bean -> SomeBean m

hoistSomeBean :: (forall x. m x -> n x) -> SomeBean m -> SomeBean n
hoistSomeBean :: forall (m :: * -> *) (n :: * -> *).
(forall x. m x -> n x) -> SomeBean m -> SomeBean n
hoistSomeBean forall x. m x -> n x
f (SomeBean Bean m bean
bean) = Bean n bean -> SomeBean n
forall args (m :: * -> *).
Typeable args =>
Bean m args -> SomeBean m
SomeBean do (forall x. m x -> n x) -> Bean m bean -> Bean n bean
forall (m :: * -> *) (n :: * -> *) bean.
(forall x. m x -> n x) -> Bean m bean -> Bean n bean
hoistBean m x -> n x
forall x. m x -> n x
f Bean m bean
bean

-- | A bean recipe, to be inserted into a 'Cauldron'.
data Bean m bean where
  Bean ::
    { -- | How to build the bean itself.
      forall (m :: * -> *) bean. Bean m bean -> Constructor m bean
constructor :: Constructor m bean,
      -- | How to build the decorators that wrap the bean. There might be no decorators.
      forall (m :: * -> *) bean. Bean m bean -> Decos m bean
decos :: Decos m bean
    } ->
    Bean m bean

-- | Change the monad used by the bean\'s 'Constructor' and its 'Decos'.
hoistBean :: (forall x. m x -> n x) -> Bean m bean -> Bean n bean
hoistBean :: forall (m :: * -> *) (n :: * -> *) bean.
(forall x. m x -> n x) -> Bean m bean -> Bean n bean
hoistBean forall x. m x -> n x
f (Bean {Constructor m bean
constructor :: forall (m :: * -> *) bean. Bean m bean -> Constructor m bean
constructor :: Constructor m bean
constructor, Decos m bean
decos :: forall (m :: * -> *) bean. Bean m bean -> Decos m bean
decos :: Decos m bean
decos}) =
  Bean
    { constructor :: Constructor n bean
constructor = (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,
      decos :: Decos n bean
decos = (forall x. m x -> n x) -> Decos m bean -> Decos n bean
forall (m :: * -> *) (n :: * -> *) bean.
(forall x. m x -> n x) -> Decos m bean -> Decos n bean
hoistDecos m x -> n x
forall x. m x -> n x
f Decos m bean
decos
    }

-- | A 'Bean' without decorators, having only the main constructor.
makeBean :: Constructor m a -> Bean m a
makeBean :: forall (m :: * -> *) a. Constructor m a -> Bean m a
makeBean Constructor m a
constructor = Bean {Constructor m a
constructor :: Constructor m a
constructor :: Constructor m a
constructor, decos :: Decos m a
decos = Decos m a
forall a. Monoid a => a
mempty}

-- $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, logging... to the functions.
--
--
-- >>> :{
-- 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 =
--         emptyCauldron
--         & insert @Foo
--           Bean {
--             constructor = pack value makeFoo,
--             decos = fromConstructors [
--                  pack value makeFooDeco1,
--                  pack effect makeFooDeco2
--               ]
--           }
--       Right (_ :: DependencyGraph, action) = cook forbidDepCycles cauldron
--   beans <- action
--   let Just Foo {sayFoo} = taste beans
--   sayFoo
-- :}
-- deco2 init
-- deco2 enter
-- deco1 enter
-- foo
-- deco1 exit
-- deco2 exit

-- | A list of 'Constructor's for the decorators of some 'Bean'.
--
-- 'Constructor's for a decorator will have the @bean@ itself among their
-- arguments. That @bean@ argument will be either the \"bare\" undecorated
-- bean (for the first decorator) or the result of applying the previous
-- decorator in the list.
--
-- Decorators can have other dependencies besides the @bean@.
newtype Decos m bean where
  Decos :: {forall (m :: * -> *) bean. Decos m bean -> Seq (Constructor m bean)
decoCons :: Seq (Constructor m bean)} -> Decos m bean
  deriving newtype (NonEmpty (Decos m bean) -> Decos m bean
Decos m bean -> Decos m bean -> Decos m bean
(Decos m bean -> Decos m bean -> Decos m bean)
-> (NonEmpty (Decos m bean) -> Decos m bean)
-> (forall b. Integral b => b -> Decos m bean -> Decos m bean)
-> Semigroup (Decos m bean)
forall b. Integral b => b -> Decos m bean -> Decos m bean
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall (m :: * -> *) bean. NonEmpty (Decos m bean) -> Decos m bean
forall (m :: * -> *) bean.
Decos m bean -> Decos m bean -> Decos m bean
forall (m :: * -> *) bean b.
Integral b =>
b -> Decos m bean -> Decos m bean
$c<> :: forall (m :: * -> *) bean.
Decos m bean -> Decos m bean -> Decos m bean
<> :: Decos m bean -> Decos m bean -> Decos m bean
$csconcat :: forall (m :: * -> *) bean. NonEmpty (Decos m bean) -> Decos m bean
sconcat :: NonEmpty (Decos m bean) -> Decos m bean
$cstimes :: forall (m :: * -> *) bean b.
Integral b =>
b -> Decos m bean -> Decos m bean
stimes :: forall b. Integral b => b -> Decos m bean -> Decos m bean
Semigroup, Semigroup (Decos m bean)
Decos m bean
Semigroup (Decos m bean) =>
Decos m bean
-> (Decos m bean -> Decos m bean -> Decos m bean)
-> ([Decos m bean] -> Decos m bean)
-> Monoid (Decos m bean)
[Decos m bean] -> Decos m bean
Decos m bean -> Decos m bean -> Decos m bean
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall (m :: * -> *) bean. Semigroup (Decos m bean)
forall (m :: * -> *) bean. Decos m bean
forall (m :: * -> *) bean. [Decos m bean] -> Decos m bean
forall (m :: * -> *) bean.
Decos m bean -> Decos m bean -> Decos m bean
$cmempty :: forall (m :: * -> *) bean. Decos m bean
mempty :: Decos m bean
$cmappend :: forall (m :: * -> *) bean.
Decos m bean -> Decos m bean -> Decos m bean
mappend :: Decos m bean -> Decos m bean -> Decos m bean
$cmconcat :: forall (m :: * -> *) bean. [Decos m bean] -> Decos m bean
mconcat :: [Decos m bean] -> Decos m bean
Monoid)

instance IsList (Decos m bean) where
  type Item (Decos m bean) = Constructor m bean
  fromList :: [Item (Decos m bean)] -> Decos m bean
fromList [Item (Decos m bean)]
decos = Seq (Constructor m bean) -> Decos m bean
forall (m :: * -> *) bean. Seq (Constructor m bean) -> Decos m bean
Decos do [Item (Seq (Constructor m bean))] -> Seq (Constructor m bean)
forall l. IsList l => [Item l] -> l
GHC.Exts.fromList [Item (Seq (Constructor m bean))]
[Item (Decos m bean)]
decos
  toList :: Decos m bean -> [Item (Decos m bean)]
toList (Decos {Seq (Constructor m bean)
decoCons :: forall (m :: * -> *) bean. Decos m bean -> Seq (Constructor m bean)
decoCons :: Seq (Constructor m bean)
decoCons}) = Seq (Constructor m bean) -> [Item (Seq (Constructor m bean))]
forall l. IsList l => l -> [Item l]
GHC.Exts.toList Seq (Constructor m bean)
decoCons

-- | Empty list of decorators.
emptyDecos :: Decos m bean
emptyDecos :: forall (m :: * -> *) bean. Decos m bean
emptyDecos = Decos m bean
forall a. Monoid a => a
mempty

-- | Change the monad used by the decorators.
hoistDecos :: (forall x. m x -> n x) -> Decos m bean -> Decos n bean
hoistDecos :: forall (m :: * -> *) (n :: * -> *) bean.
(forall x. m x -> n x) -> Decos m bean -> Decos n bean
hoistDecos forall x. m x -> n x
f (Decos {Seq (Constructor m bean)
decoCons :: forall (m :: * -> *) bean. Decos m bean -> Seq (Constructor m bean)
decoCons :: Seq (Constructor m bean)
decoCons}) = Decos {decoCons :: Seq (Constructor n bean)
decoCons = (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)
decoCons}

setConstructor :: Constructor m bean -> Bean m bean -> Bean m bean
setConstructor :: forall (m :: * -> *) bean.
Constructor m bean -> Bean m bean -> Bean m bean
setConstructor Constructor m bean
constructor (Bean {Decos m bean
decos :: forall (m :: * -> *) bean. Bean m bean -> Decos m bean
decos :: Decos m bean
decos}) = Bean {Constructor m bean
constructor :: Constructor m bean
constructor :: Constructor m bean
constructor, Decos m bean
decos :: Decos m bean
decos :: Decos m bean
decos}

setDecos :: Decos m bean -> Bean m bean -> Bean m bean
setDecos :: forall (m :: * -> *) bean.
Decos m bean -> Bean m bean -> Bean m bean
setDecos Decos m bean
decos (Bean {Constructor m bean
constructor :: forall (m :: * -> *) bean. Bean m bean -> Constructor m bean
constructor :: Constructor m bean
constructor}) = Bean {Constructor m bean
constructor :: Constructor m bean
constructor :: Constructor m bean
constructor, Decos m bean
decos :: Decos m bean
decos :: Decos m bean
decos}

overDecos :: (Decos m bean -> Decos m bean) -> Bean m bean -> Bean m bean
overDecos :: forall (m :: * -> *) bean.
(Decos m bean -> Decos m bean) -> Bean m bean -> Bean m bean
overDecos Decos m bean -> Decos m bean
f (Bean {Constructor m bean
constructor :: forall (m :: * -> *) bean. Bean m bean -> Constructor m bean
constructor :: Constructor m bean
constructor, Decos m bean
decos :: forall (m :: * -> *) bean. Bean m bean -> Decos m bean
decos :: Decos m bean
decos}) = Bean {Constructor m bean
constructor :: Constructor m bean
constructor :: Constructor m bean
constructor, decos :: Decos m bean
decos = Decos m bean -> Decos m bean
f Decos m bean
decos}

-- | Add a new decorator that modifies the bean /after/ all existing decorators.
--
-- This means the behaviours it adds to the bean\'s methods will be applied
-- /first/ when entering the method.
addOuter :: Constructor m bean -> Decos m bean -> Decos m bean
addOuter :: forall (m :: * -> *) bean.
Constructor m bean -> Decos m bean -> Decos m bean
addOuter Constructor m bean
con (Decos {Seq (Constructor m bean)
decoCons :: forall (m :: * -> *) bean. Decos m bean -> Seq (Constructor m bean)
decoCons :: Seq (Constructor m bean)
decoCons}) = Seq (Constructor m bean) -> Decos m bean
forall (m :: * -> *) bean. Seq (Constructor m bean) -> Decos m bean
Decos do Seq (Constructor m bean)
decoCons Seq (Constructor m bean)
-> Constructor m bean -> Seq (Constructor m bean)
forall a. Seq a -> a -> Seq a
Seq.|> Constructor m bean
con

-- | Add a new decorator that modifies the bean /before/ all existing
-- decorators.
--
-- This means the behaviours it adds to the bean\'s methods will be applied
-- /last/, just before entering the base bean's method.
--
-- Usually 'addOuter' is preferrable.
addInner :: Constructor m bean -> Decos m bean -> Decos m bean
addInner :: forall (m :: * -> *) bean.
Constructor m bean -> Decos m bean -> Decos m bean
addInner Constructor m bean
con (Decos {Seq (Constructor m bean)
decoCons :: forall (m :: * -> *) bean. Decos m bean -> Seq (Constructor m bean)
decoCons :: Seq (Constructor m bean)
decoCons}) = Seq (Constructor m bean) -> Decos m bean
forall (m :: * -> *) bean. Seq (Constructor m bean) -> Decos m bean
Decos do Constructor m bean
con Constructor m bean
-> Seq (Constructor m bean) -> Seq (Constructor m bean)
forall a. a -> Seq a -> Seq a
Seq.<| Seq (Constructor m bean)
decoCons

-- | Build the decorators from a list of 'Constructor's, first innermost,
-- last outermost.
fromConstructors ::
  [Constructor m bean] ->
  Decos m bean
fromConstructors :: forall (m :: * -> *) bean. [Constructor m bean] -> Decos m bean
fromConstructors [Constructor m bean]
cons = Seq (Constructor m bean) -> Decos m bean
forall (m :: * -> *) bean. Seq (Constructor m bean) -> Decos m bean
Decos do [Constructor m bean] -> Seq (Constructor m bean)
forall a. [a] -> Seq a
Seq.fromList [Constructor m bean]
cons

-- $constructors
--
-- The bean-producing or bean-decorating functions that we want to wire need to be
-- coaxed into a 'Constructor' value before creating a 'Bean' recipe and adding it to the 'Cauldron'.
--
-- If your aren't dealing with secondary beans, don't sweat it: use @pack value@ for pure
-- constructors functions and @pack effect@ for effectful ones. That should be enough.

-- | A way of building some @bean@ value, 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 a
-- constructor will allocate resources with bracket-like operations, and in that
-- case a monad like 'Managed' might be needed instead.
data Constructor m bean where
  Constructor ::
    (All Typeable args, All (Typeable `And` Monoid) regs) =>
    { ()
constructor_ :: Args args (m (Regs regs bean))
    } ->
    Constructor m bean

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

-- | 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 (Constructor {Args args (m (Regs regs bean))
constructor_ :: ()
constructor_ :: Args args (m (Regs regs bean))
constructor_}) = Args args (n (Regs regs bean)) -> Constructor n bean
forall (args :: [*]) (regs :: [*]) (m :: * -> *) bean.
(All Typeable args, All (And Typeable Monoid) regs) =>
Args args (m (Regs regs bean)) -> Constructor m bean
Constructor do (m (Regs regs bean) -> n (Regs regs bean))
-> Args args (m (Regs regs bean)) -> Args args (n (Regs regs bean))
forall a b. (a -> b) -> Args args a -> Args args b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap m (Regs regs bean) -> n (Regs regs bean)
forall x. m x -> n x
f Args args (m (Regs regs bean))
constructor_

-- | Put a recipe for a 'Bean' into the 'Cauldron'.
--
-- Only one recipe is allowed for each different @bean@ type, so 'insert' for a
-- @bean@ will overwrite previous recipes for that type.
insert ::
  forall (bean :: Type) m.
  (Typeable bean) =>
  Bean m bean ->
  Cauldron m ->
  Cauldron m
insert :: forall bean (m :: * -> *).
Typeable bean =>
Bean m bean -> Cauldron m -> Cauldron m
insert Bean m bean
recipe Cauldron {Map TypeRep (SomeBean m)
recipes :: forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeBean m)
recipes :: Map TypeRep (SomeBean m)
recipes} = 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 {recipes :: Map TypeRep (SomeBean m)
recipes = TypeRep
-> SomeBean m
-> Map TypeRep (SomeBean m)
-> Map TypeRep (SomeBean m)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeRep
rep (Bean m bean -> SomeBean m
forall args (m :: * -> *).
Typeable args =>
Bean m args -> SomeBean m
SomeBean Bean m bean
recipe) Map TypeRep (SomeBean m)
recipes}

-- | Tweak an already existing 'Bean' recipe.
adjust ::
  forall bean m.
  (Typeable bean) =>
  (Bean m bean -> Bean m bean) ->
  Cauldron m ->
  Cauldron m
adjust :: forall bean (m :: * -> *).
Typeable bean =>
(Bean m bean -> Bean m bean) -> Cauldron m -> Cauldron m
adjust Bean m bean -> Bean m bean
f (Cauldron {Map TypeRep (SomeBean m)
recipes :: forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeBean m)
recipes :: Map TypeRep (SomeBean m)
recipes}) = 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
    { recipes :: Map TypeRep (SomeBean m)
recipes =
        (SomeBean m -> SomeBean m)
-> TypeRep -> Map TypeRep (SomeBean m) -> Map TypeRep (SomeBean m)
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust
          do
            \(SomeBean (Bean m bean
r :: Bean 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 -> [Char] -> SomeBean m
forall a. HasCallStack => [Char] -> a
error [Char]
"should never happen"
                Just bean :~: bean
Refl -> Bean m bean -> SomeBean m
forall args (m :: * -> *).
Typeable args =>
Bean m args -> SomeBean m
SomeBean (Bean m bean -> Bean m bean
f Bean m bean
Bean m bean
r)
          TypeRep
rep
          Map TypeRep (SomeBean m)
recipes
    }

delete ::
  forall bean m.
  (Typeable bean) =>
  Cauldron m ->
  Cauldron m
delete :: forall {k} (bean :: k) (m :: * -> *).
Typeable bean =>
Cauldron m -> Cauldron m
delete Cauldron {Map TypeRep (SomeBean m)
recipes :: forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeBean m)
recipes :: Map TypeRep (SomeBean m)
recipes} =
  Cauldron {recipes :: Map TypeRep (SomeBean m)
recipes = TypeRep -> Map TypeRep (SomeBean m) -> Map TypeRep (SomeBean m)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (Proxy bean -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall (t :: k). Proxy t
forall {k} (t :: k). Proxy t
Proxy @bean)) Map TypeRep (SomeBean m)
recipes}

-- | Strategy for dealing with dependency cycles.
--
-- (Terrible uninformative name caused by a metaphor stretched too far.)
data Fire m = Fire
  { forall (m :: * -> *).
Fire m -> (BeanConstructionStep, BeanConstructionStep) -> Bool
shouldOmitDependency :: (BeanConstructionStep, BeanConstructionStep) -> Bool,
    forall (m :: * -> *).
Fire m -> Cauldron m -> BoiledBeans -> Plan -> m BoiledBeans
followPlanCauldron ::
      Cauldron m ->
      BoiledBeans ->
      Plan ->
      m BoiledBeans
  }

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}

-- | 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. (__BEWARE__:
-- Pattern-matching too eagerly on this \"bean from the future\" during
-- construction will cause infinite loops.)
--
-- Note that a 'MonadFix' instance is required of the initialization monad.
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 -> BoiledBeans -> Plan -> m BoiledBeans
followPlanCauldron = \Cauldron m
cauldron BoiledBeans
initial Plan
plan ->
        (BoiledBeans -> m BoiledBeans) -> m BoiledBeans
forall a. (a -> m a) -> m a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix do
          \BoiledBeans
final ->
            (BoiledBeans -> BeanConstructionStep -> m BoiledBeans)
-> BoiledBeans -> Plan -> m BoiledBeans
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
Data.Foldable.foldlM
              do Cauldron m
-> BoiledBeans
-> BoiledBeans
-> BeanConstructionStep
-> m BoiledBeans
forall (m :: * -> *).
Monad m =>
Cauldron m
-> BoiledBeans
-> BoiledBeans
-> BeanConstructionStep
-> m BoiledBeans
followPlanStep Cauldron m
cauldron BoiledBeans
final
              BoiledBeans
initial
              Plan
plan
    }

-- | 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 -> BoiledBeans -> Plan -> m BoiledBeans
followPlanCauldron = \Cauldron m
cauldron BoiledBeans
initial Plan
plan ->
        (BoiledBeans -> BeanConstructionStep -> m BoiledBeans)
-> BoiledBeans -> Plan -> m BoiledBeans
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
Data.Foldable.foldlM
          do Cauldron m
-> BoiledBeans
-> BoiledBeans
-> BeanConstructionStep
-> m BoiledBeans
forall (m :: * -> *).
Monad m =>
Cauldron m
-> BoiledBeans
-> BoiledBeans
-> BeanConstructionStep
-> m BoiledBeans
followPlanStep Cauldron m
cauldron BoiledBeans {beans :: Map TypeRep Dynamic
beans = Map TypeRep Dynamic
forall k a. Map k a
Map.empty}
          BoiledBeans
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 :: (Typeable bean) => Constructor m bean -> ConstructorReps
constructorReps :: forall bean (m :: * -> *).
Typeable bean =>
Constructor m bean -> ConstructorReps
constructorReps Constructor {constructor_ :: ()
constructor_ = (Args args (m (Regs regs bean))
_ :: Args args (m (Regs accums bean)))} =
  ConstructorReps
    { TypeRep
beanRep :: TypeRep
beanRep :: TypeRep
beanRep,
      argReps :: Set TypeRep
argReps =
        do
          [TypeRep] -> Set TypeRep
forall a. Ord a => [a] -> Set a
Set.fromList do
            NP (K TypeRep) args -> [TypeRep]
forall {k} a (xs :: [k]). NP (K a) xs -> [a]
collapse_NP do
              forall {k} (c :: k -> Constraint) (xs :: [k])
       (proxy :: (k -> Constraint) -> *) (f :: k -> *).
All c xs =>
proxy c -> (forall (a :: k). c a => f a) -> NP f xs
forall (c :: * -> Constraint) (xs :: [*])
       (proxy :: (* -> Constraint) -> *) (f :: * -> *).
All c xs =>
proxy c -> (forall a. c a => f a) -> NP f xs
cpure_NP @_ @args
                do forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @Typeable
                K TypeRep a
forall a. Typeable a => K TypeRep a
forall {k} (a :: k). Typeable a => K TypeRep a
typeRepHelper,
      regReps :: Map TypeRep Dynamic
regReps =
        [(TypeRep, Dynamic)] -> Map TypeRep Dynamic
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList do
          NP (K (TypeRep, Dynamic)) regs -> [(TypeRep, Dynamic)]
forall {k} a (xs :: [k]). NP (K a) xs -> [a]
collapse_NP do
            forall {k} (c :: k -> Constraint) (xs :: [k])
       (proxy :: (k -> Constraint) -> *) (f :: k -> *).
All c xs =>
proxy c -> (forall (a :: k). c a => f a) -> NP f xs
forall (c :: * -> Constraint) (xs :: [*])
       (proxy :: (* -> Constraint) -> *) (f :: * -> *).
All c xs =>
proxy c -> (forall a. c a => f a) -> NP f xs
cpure_NP @_ @accums
              do forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @(Typeable `And` Monoid)
              K (TypeRep, Dynamic) a
forall a. And Typeable Monoid a => K (TypeRep, Dynamic) a
typeRepHelper'
    }
  where
    typeRepHelper :: forall a. (Typeable a) => K TypeRep a
    typeRepHelper :: forall {k} (a :: k). Typeable a => K TypeRep a
typeRepHelper = TypeRep -> K TypeRep a
forall k a (b :: k). a -> K a b
K (Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall (t :: k). Proxy t
forall {k} (t :: k). Proxy t
Proxy @a))
    typeRepHelper' :: forall a. ((Typeable `And` Monoid) a) => K (TypeRep, Dynamic) a
    typeRepHelper' :: forall a. And Typeable Monoid a => K (TypeRep, Dynamic) a
typeRepHelper' = (TypeRep, Dynamic) -> K (TypeRep, Dynamic) a
forall k a (b :: k). a -> K a b
K (Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a), forall a. Typeable a => a -> Dynamic
toDyn @a a
forall a. Monoid a => a
mempty)
    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)

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 -> [Char]
(Int -> BeanConstructionStep -> ShowS)
-> (BeanConstructionStep -> [Char])
-> (Plan -> ShowS)
-> Show BeanConstructionStep
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BeanConstructionStep -> ShowS
showsPrec :: Int -> BeanConstructionStep -> ShowS
$cshow :: BeanConstructionStep -> [Char]
show :: BeanConstructionStep -> [Char]
$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)

-- | The successful result of 'cook'ing a 'Cauldron'. Can't do a lot with them other than to 'taste' them.
newtype BoiledBeans where
  BoiledBeans :: {BoiledBeans -> Map TypeRep Dynamic
beans :: Map TypeRep Dynamic} -> BoiledBeans

-- | Build the beans using the recipes stored in the 'Cauldron'.
cook ::
  forall m.
  (Monad m) =>
  Fire m ->
  Cauldron m ->
  Either BadBeans (DependencyGraph, m BoiledBeans)
cook :: forall (m :: * -> *).
Monad m =>
Fire m
-> Cauldron m -> Either BadBeans (DependencyGraph, m BoiledBeans)
cook Fire m
fire Cauldron m
cauldron = do
  let result :: Either BadBeans (Tree DependencyGraph, m (Tree BoiledBeans))
result = Tree (Fire m, Cauldron m)
-> Either BadBeans (Tree DependencyGraph, m (Tree BoiledBeans))
forall (m :: * -> *).
Monad m =>
Tree (Fire m, Cauldron m)
-> Either BadBeans (Tree DependencyGraph, m (Tree BoiledBeans))
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) [])
  Either BadBeans (Tree DependencyGraph, m (Tree BoiledBeans))
result Either BadBeans (Tree DependencyGraph, m (Tree BoiledBeans))
-> ((Tree DependencyGraph, m (Tree BoiledBeans))
    -> (DependencyGraph, m BoiledBeans))
-> Either BadBeans (DependencyGraph, m BoiledBeans)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Tree DependencyGraph
tg, m (Tree BoiledBeans)
m) -> (Tree DependencyGraph -> DependencyGraph
forall a. Tree a -> a
rootLabel Tree DependencyGraph
tg, Tree BoiledBeans -> BoiledBeans
forall a. Tree a -> a
rootLabel (Tree BoiledBeans -> BoiledBeans)
-> m (Tree BoiledBeans) -> m BoiledBeans
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Tree BoiledBeans)
m)

-- | Cook a 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 BadBeans (NonEmpty DependencyGraph, m (NonEmpty BoiledBeans))
cookNonEmpty :: forall (m :: * -> *).
Monad m =>
NonEmpty (Fire m, Cauldron m)
-> Either
     BadBeans (NonEmpty DependencyGraph, m (NonEmpty BoiledBeans))
cookNonEmpty NonEmpty (Fire m, Cauldron m)
nonemptyCauldronList = do
  let result :: Either BadBeans (Tree DependencyGraph, m (Tree BoiledBeans))
result = Tree (Fire m, Cauldron m)
-> Either BadBeans (Tree DependencyGraph, m (Tree BoiledBeans))
forall (m :: * -> *).
Monad m =>
Tree (Fire m, Cauldron m)
-> Either BadBeans (Tree DependencyGraph, m (Tree BoiledBeans))
cookTree (NonEmpty (Fire m, Cauldron m) -> Tree (Fire m, Cauldron m)
forall a. NonEmpty a -> Tree a
nonEmptyToTree NonEmpty (Fire m, Cauldron m)
nonemptyCauldronList)
  Either BadBeans (Tree DependencyGraph, m (Tree BoiledBeans))
result Either BadBeans (Tree DependencyGraph, m (Tree BoiledBeans))
-> ((Tree DependencyGraph, m (Tree BoiledBeans))
    -> (NonEmpty DependencyGraph, m (NonEmpty BoiledBeans)))
-> Either
     BadBeans (NonEmpty DependencyGraph, m (NonEmpty BoiledBeans))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Tree DependencyGraph
ng, m (Tree BoiledBeans)
m) -> (Tree DependencyGraph -> NonEmpty DependencyGraph
forall a. Tree a -> NonEmpty a
unsafeTreeToNonEmpty Tree DependencyGraph
ng, Tree BoiledBeans -> NonEmpty BoiledBeans
forall a. Tree a -> NonEmpty a
unsafeTreeToNonEmpty (Tree BoiledBeans -> NonEmpty BoiledBeans)
-> m (Tree BoiledBeans) -> m (NonEmpty BoiledBeans)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Tree BoiledBeans)
m)

-- | 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 BadBeans (Tree DependencyGraph, m (Tree BoiledBeans))
cookTree :: forall (m :: * -> *).
Monad m =>
Tree (Fire m, Cauldron m)
-> Either BadBeans (Tree DependencyGraph, m (Tree BoiledBeans))
cookTree (Tree (Fire m, Cauldron m)
treecipes) = do
  accumMap <- (Set TypeRep -> BadBeans)
-> Either (Set TypeRep) (Map TypeRep Dynamic)
-> Either BadBeans (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 Set TypeRep -> BadBeans
DoubleDutyBeans do Tree (Cauldron m) -> Either (Set TypeRep) (Map TypeRep Dynamic)
forall (m :: * -> *).
Tree (Cauldron m) -> Either (Set TypeRep) (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 (uncurry MissingDependencies) do checkMissingDeps (Map.keysSet accumMap) (snd <$> treecipes)
  treeplan <- first DependencyCycle do buildPlans (Map.keysSet accumMap) treecipes
  Right
    ( treeplan <&> \(AdjacencyMap BeanConstructionStep
graph, (Plan, Fire m, Cauldron m)
_) -> DependencyGraph {AdjacencyMap BeanConstructionStep
graph :: AdjacencyMap BeanConstructionStep
graph :: AdjacencyMap BeanConstructionStep
graph},
      followPlan (BoiledBeans accumMap) (snd <$> treeplan)
    )

checkNoDoubleDutyBeans ::
  Tree (Cauldron m) ->
  Either (Set TypeRep) (Map TypeRep Dynamic)
checkNoDoubleDutyBeans :: forall (m :: * -> *).
Tree (Cauldron m) -> Either (Set TypeRep) (Map TypeRep Dynamic)
checkNoDoubleDutyBeans Tree (Cauldron m)
treecipes = do
  let (Map TypeRep Dynamic
accumMap, Set TypeRep
beanSet) = Tree (Cauldron m) -> (Map TypeRep Dynamic, Set TypeRep)
forall (m :: * -> *).
Tree (Cauldron m) -> (Map TypeRep Dynamic, Set TypeRep)
cauldronTreeRegs Tree (Cauldron m)
treecipes
  let common :: Set TypeRep
common = Set TypeRep -> Set TypeRep -> Set TypeRep
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection (Map TypeRep Dynamic -> Set TypeRep
forall k a. Map k a -> Set k
Map.keysSet Map TypeRep Dynamic
accumMap) Set TypeRep
beanSet
  if Bool -> Bool
not (Set TypeRep -> Bool
forall a. Set a -> Bool
Set.null Set TypeRep
common)
    then Set TypeRep -> Either (Set TypeRep) (Map TypeRep Dynamic)
forall a b. a -> Either a b
Left Set TypeRep
common
    else Map TypeRep Dynamic -> Either (Set TypeRep) (Map TypeRep Dynamic)
forall a b. b -> Either a b
Right Map TypeRep Dynamic
accumMap

-- | Will always be @[]@ when using 'cook'; identifies a 'Cauldron' in a hierarchy of 'Cauldron's when
-- using 'cookNonEmpty' or 'cookTree'.
type PathToCauldron = [Int]

cauldronTreeRegs :: Tree (Cauldron m) -> (Map TypeRep Dynamic, Set TypeRep)
cauldronTreeRegs :: forall (m :: * -> *).
Tree (Cauldron m) -> (Map TypeRep Dynamic, Set TypeRep)
cauldronTreeRegs = (Cauldron m -> (Map TypeRep Dynamic, Set TypeRep))
-> Tree (Cauldron m) -> (Map TypeRep Dynamic, Set TypeRep)
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 Dynamic, Set TypeRep)
forall (m :: * -> *).
Cauldron m -> (Map TypeRep Dynamic, Set TypeRep)
cauldronRegs

cauldronRegs :: Cauldron m -> (Map TypeRep Dynamic, Set TypeRep)
cauldronRegs :: forall (m :: * -> *).
Cauldron m -> (Map TypeRep Dynamic, Set TypeRep)
cauldronRegs Cauldron {Map TypeRep (SomeBean m)
recipes :: forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeBean m)
recipes :: Map TypeRep (SomeBean m)
recipes} =
  (TypeRep -> SomeBean m -> (Map TypeRep Dynamic, Set TypeRep))
-> Map TypeRep (SomeBean m) -> (Map TypeRep Dynamic, Set TypeRep)
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey
    do \TypeRep
rep SomeBean m
recipe -> (SomeBean m -> Map TypeRep Dynamic
forall (m :: * -> *). SomeBean m -> Map TypeRep Dynamic
recipeRegs SomeBean m
recipe, TypeRep -> Set TypeRep
forall a. a -> Set a
Set.singleton TypeRep
rep)
    Map TypeRep (SomeBean m)
recipes

-- | Returns the accumulators, not the main bean
recipeRegs :: SomeBean m -> Map TypeRep Dynamic
recipeRegs :: forall (m :: * -> *). SomeBean m -> Map TypeRep Dynamic
recipeRegs (SomeBean (Bean {Constructor m bean
constructor :: forall (m :: * -> *) bean. Bean m bean -> Constructor m bean
constructor :: Constructor m bean
constructor, decos :: forall (m :: * -> *) bean. Bean m bean -> Decos m bean
decos = Decos {Seq (Constructor m bean)
decoCons :: forall (m :: * -> *) bean. Decos m bean -> Seq (Constructor m bean)
decoCons :: Seq (Constructor m bean)
decoCons}})) = do
  let extractRegReps :: Constructor m bean -> Map TypeRep Dynamic
extractRegReps = (.regReps) (ConstructorReps -> Map TypeRep Dynamic)
-> (Constructor m bean -> ConstructorReps)
-> Constructor m bean
-> Map TypeRep Dynamic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constructor m bean -> ConstructorReps
forall bean (m :: * -> *).
Typeable bean =>
Constructor m bean -> ConstructorReps
constructorReps
  Constructor m bean -> Map TypeRep Dynamic
forall {m :: * -> *}. Constructor m bean -> Map TypeRep Dynamic
extractRegReps Constructor m bean
constructor
    Map TypeRep Dynamic -> Map TypeRep Dynamic -> Map TypeRep Dynamic
forall a. Semigroup a => a -> a -> a
<> (Constructor m bean -> Map TypeRep Dynamic)
-> Seq (Constructor m bean) -> Map TypeRep 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 Dynamic
forall {m :: * -> *}. Constructor m bean -> Map TypeRep Dynamic
extractRegReps Seq (Constructor m bean)
decoCons

checkMissingDeps ::
  -- | accums
  Set TypeRep ->
  Tree (Cauldron m) ->
  Either (PathToCauldron, Map TypeRep (Set TypeRep)) ()
checkMissingDeps :: forall (m :: * -> *).
Set TypeRep
-> Tree (Cauldron m)
-> Either (PathToCauldron, Map TypeRep (Set TypeRep)) ()
checkMissingDeps Set TypeRep
accums Tree (Cauldron m)
treecipes = do
  let decoratedTreecipes :: Tree (PathToCauldron, Map TypeRep PathToCauldron, Cauldron m)
decoratedTreecipes = (PathToCauldron, Map TypeRep PathToCauldron, Tree (Cauldron m))
-> Tree (PathToCauldron, Map TypeRep PathToCauldron, Cauldron m)
forall (m :: * -> *).
(PathToCauldron, Map TypeRep PathToCauldron, Tree (Cauldron m))
-> Tree (PathToCauldron, Map TypeRep PathToCauldron, Cauldron m)
decorate ([], Map TypeRep PathToCauldron
forall k a. Map k a
Map.empty, Tree (Cauldron m)
treecipes)
      missing :: Tree (Either (PathToCauldron, Map TypeRep (Set TypeRep)) ())
missing = (\(PathToCauldron
key, Map TypeRep PathToCauldron
available, Cauldron m
requested) -> (Map TypeRep (Set TypeRep)
 -> (PathToCauldron, Map TypeRep (Set TypeRep)))
-> Either (Map TypeRep (Set TypeRep)) ()
-> Either (PathToCauldron, Map TypeRep (Set TypeRep)) ()
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 (PathToCauldron
key,) do Set TypeRep
-> Set TypeRep
-> Cauldron m
-> Either (Map TypeRep (Set TypeRep)) ()
forall (m :: * -> *).
Set TypeRep
-> Set TypeRep
-> Cauldron m
-> Either (Map TypeRep (Set TypeRep)) ()
checkMissingDepsCauldron Set TypeRep
accums (Map TypeRep PathToCauldron -> Set TypeRep
forall k a. Map k a -> Set k
Map.keysSet Map TypeRep PathToCauldron
available) Cauldron m
requested) ((PathToCauldron, Map TypeRep PathToCauldron, Cauldron m)
 -> Either (PathToCauldron, Map TypeRep (Set TypeRep)) ())
-> Tree (PathToCauldron, Map TypeRep PathToCauldron, Cauldron m)
-> Tree (Either (PathToCauldron, Map TypeRep (Set TypeRep)) ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tree (PathToCauldron, Map TypeRep PathToCauldron, Cauldron m)
decoratedTreecipes
  Tree (Either (PathToCauldron, Map TypeRep (Set TypeRep)) ())
-> Either (PathToCauldron, Map TypeRep (Set TypeRep)) ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ Tree (Either (PathToCauldron, Map TypeRep (Set TypeRep)) ())
missing
  where
    decorate ::
      (PathToCauldron, Map TypeRep PathToCauldron, Tree (Cauldron m)) ->
      Tree (PathToCauldron, Map TypeRep PathToCauldron, Cauldron m)
    decorate :: forall (m :: * -> *).
(PathToCauldron, Map TypeRep PathToCauldron, Tree (Cauldron m))
-> Tree (PathToCauldron, Map TypeRep PathToCauldron, Cauldron m)
decorate = ((PathToCauldron, Map TypeRep PathToCauldron, Tree (Cauldron m))
 -> ((PathToCauldron, Map TypeRep PathToCauldron, Cauldron m),
     [(PathToCauldron, Map TypeRep PathToCauldron, Tree (Cauldron m))]))
-> (PathToCauldron, Map TypeRep PathToCauldron, Tree (Cauldron m))
-> Tree (PathToCauldron, Map TypeRep PathToCauldron, Cauldron m)
forall b a. (b -> (a, [b])) -> b -> Tree a
unfoldTree
      do
        \(PathToCauldron
key, Map TypeRep PathToCauldron
acc, Node (current :: Cauldron m
current@Cauldron {Map TypeRep (SomeBean m)
recipes :: forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeBean m)
recipes :: Map TypeRep (SomeBean m)
recipes}) [Tree (Cauldron m)]
rest) ->
          let -- current level has priority
              newAcc :: Map TypeRep PathToCauldron
newAcc = (Map TypeRep (SomeBean m)
recipes Map TypeRep (SomeBean m)
-> PathToCauldron -> Map TypeRep PathToCauldron
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> PathToCauldron
key) Map TypeRep PathToCauldron
-> Map TypeRep PathToCauldron -> Map TypeRep PathToCauldron
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map TypeRep PathToCauldron
acc
              newSeeds :: [(PathToCauldron, Map TypeRep PathToCauldron, Tree (Cauldron m))]
newSeeds = do
                (i, z) <- PathToCauldron -> [Tree (Cauldron m)] -> [(Int, Tree (Cauldron m))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [Tree (Cauldron m)]
rest
                let newKey = PathToCauldron
key PathToCauldron -> PathToCauldron -> PathToCauldron
forall a. [a] -> [a] -> [a]
++ [Int
i]
                [(newKey, newAcc, z)]
           in ((PathToCauldron
key, Map TypeRep PathToCauldron
newAcc, Cauldron m
current), [(PathToCauldron, Map TypeRep PathToCauldron, Tree (Cauldron m))]
newSeeds)

checkMissingDepsCauldron ::
  -- | accums
  Set TypeRep ->
  -- | available at this level
  Set TypeRep ->
  Cauldron m ->
  Either (Map TypeRep (Set TypeRep)) ()
checkMissingDepsCauldron :: forall (m :: * -> *).
Set TypeRep
-> Set TypeRep
-> Cauldron m
-> Either (Map TypeRep (Set TypeRep)) ()
checkMissingDepsCauldron Set TypeRep
accums Set TypeRep
available Cauldron {Map TypeRep (SomeBean m)
recipes :: forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeBean m)
recipes :: Map TypeRep (SomeBean m)
recipes} = do
  let missingMap :: Map TypeRep (Set TypeRep)
missingMap = ((SomeBean m -> Maybe (Set TypeRep))
-> Map TypeRep (SomeBean m) -> Map TypeRep (Set TypeRep)
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
`Map.mapMaybe` Map TypeRep (SomeBean m)
recipes) \SomeBean m
someBean -> do
        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) do SomeBean m -> Set TypeRep
forall (m :: * -> *). SomeBean m -> Set TypeRep
demanded SomeBean m
someBean
        if Set TypeRep -> Bool
forall a. Set a -> Bool
Set.null Set TypeRep
missing
          then Maybe (Set TypeRep)
forall a. Maybe a
Nothing
          else Set TypeRep -> Maybe (Set TypeRep)
forall a. a -> Maybe a
Just Set TypeRep
missing
  if Bool -> Bool
not (Map TypeRep (Set TypeRep) -> Bool
forall k a. Map k a -> Bool
Map.null Map TypeRep (Set TypeRep)
missingMap)
    then Map TypeRep (Set TypeRep) -> Either (Map TypeRep (Set TypeRep)) ()
forall a b. a -> Either a b
Left Map TypeRep (Set TypeRep)
missingMap
    else () -> Either (Map TypeRep (Set TypeRep)) ()
forall a b. b -> Either a b
Right ()
  where
    demanded :: SomeBean m -> Set TypeRep
    demanded :: forall (m :: * -> *). SomeBean m -> Set TypeRep
demanded (SomeBean Bean {Constructor m bean
constructor :: forall (m :: * -> *) bean. Bean m bean -> Constructor m bean
constructor :: Constructor m bean
constructor, decos :: forall (m :: * -> *) bean. Bean m bean -> Decos m bean
decos = Decos {Seq (Constructor m bean)
decoCons :: forall (m :: * -> *) bean. Decos m bean -> Seq (Constructor m bean)
decoCons :: Seq (Constructor m bean)
decoCons}}) =
      ( [TypeRep] -> Set TypeRep
forall a. Ord a => [a] -> Set a
Set.fromList do
          let ConstructorReps {argReps :: ConstructorReps -> Set TypeRep
argReps = Set TypeRep
beanArgReps} = Constructor m bean -> ConstructorReps
forall bean (m :: * -> *).
Typeable bean =>
Constructor m bean -> ConstructorReps
constructorReps Constructor m bean
constructor
          Set TypeRep -> [TypeRep]
forall a. Set a -> [a]
Set.toList Set TypeRep
beanArgReps [TypeRep] -> [TypeRep] -> [TypeRep]
forall a. [a] -> [a] -> [a]
++ do
            decoCon <- 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)
decoCons
            let ConstructorReps {argReps = decoArgReps} = constructorReps decoCon
            Set.toList decoArgReps
      )
        Set TypeRep -> Set TypeRep -> Set TypeRep
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set TypeRep
accums

buildPlans :: Set TypeRep -> Tree (Fire m, Cauldron m) -> Either (NonEmpty BeanConstructionStep) (Tree (AdjacencyMap BeanConstructionStep, (Plan, Fire m, Cauldron m)))
buildPlans :: forall (m :: * -> *).
Set TypeRep
-> Tree (Fire m, Cauldron m)
-> Either
     (NonEmpty BeanConstructionStep)
     (Tree
        (AdjacencyMap BeanConstructionStep, (Plan, Fire m, Cauldron m)))
buildPlans Set TypeRep
secondary = ((Fire m, Cauldron m)
 -> Either
      (NonEmpty BeanConstructionStep)
      (AdjacencyMap BeanConstructionStep, (Plan, Fire m, Cauldron m)))
-> Tree (Fire m, Cauldron m)
-> Either
     (NonEmpty BeanConstructionStep)
     (Tree
        (AdjacencyMap BeanConstructionStep, (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 deps :: [(BeanConstructionStep, BeanConstructionStep)]
deps = ((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) do Set TypeRep
-> Cauldron m -> [(BeanConstructionStep, BeanConstructionStep)]
forall (m :: * -> *).
Set TypeRep
-> Cauldron m -> [(BeanConstructionStep, BeanConstructionStep)]
buildDepsCauldron Set TypeRep
secondary Cauldron m
cauldron
  let graph :: AdjacencyMap BeanConstructionStep
graph = [(BeanConstructionStep, BeanConstructionStep)]
-> AdjacencyMap BeanConstructionStep
forall a. Ord a => [(a, a)] -> AdjacencyMap a
Graph.edges [(BeanConstructionStep, BeanConstructionStep)]
deps
  case AdjacencyMap BeanConstructionStep
-> Either (NonEmpty BeanConstructionStep) Plan
forall a. Ord a => AdjacencyMap a -> Either (Cycle a) [a]
Graph.topSort AdjacencyMap BeanConstructionStep
graph of
    Left NonEmpty BeanConstructionStep
recipeCycle ->
      NonEmpty BeanConstructionStep
-> Either
     (NonEmpty BeanConstructionStep)
     (AdjacencyMap BeanConstructionStep, (Plan, Fire m, Cauldron m))
forall a b. a -> Either a b
Left NonEmpty BeanConstructionStep
recipeCycle
    Right (Plan -> Plan
forall a. [a] -> [a]
reverse -> Plan
plan) -> do
      let completeGraph :: AdjacencyMap BeanConstructionStep
completeGraph = [(BeanConstructionStep, BeanConstructionStep)]
-> AdjacencyMap BeanConstructionStep
forall a. Ord a => [(a, a)] -> AdjacencyMap a
Graph.edges [(BeanConstructionStep, BeanConstructionStep)]
deps
      (AdjacencyMap BeanConstructionStep, (Plan, Fire m, Cauldron m))
-> Either
     (NonEmpty BeanConstructionStep)
     (AdjacencyMap BeanConstructionStep, (Plan, Fire m, Cauldron m))
forall a b. b -> Either a b
Right (AdjacencyMap BeanConstructionStep
completeGraph, (Plan
plan, Fire m
fire, Cauldron m
cauldron))

buildDepsCauldron :: Set TypeRep -> Cauldron m -> [(BeanConstructionStep, BeanConstructionStep)]
buildDepsCauldron :: forall (m :: * -> *).
Set TypeRep
-> Cauldron m -> [(BeanConstructionStep, BeanConstructionStep)]
buildDepsCauldron Set TypeRep
secondary Cauldron {Map TypeRep (SomeBean m)
recipes :: forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeBean m)
recipes :: Map TypeRep (SomeBean m)
recipes} = do
  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
  (((TypeRep
  -> SomeBean m -> [(BeanConstructionStep, BeanConstructionStep)])
 -> Map TypeRep (SomeBean m)
 -> [(BeanConstructionStep, BeanConstructionStep)])
-> Map TypeRep (SomeBean m)
-> (TypeRep
    -> SomeBean m -> [(BeanConstructionStep, BeanConstructionStep)])
-> [(BeanConstructionStep, BeanConstructionStep)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (TypeRep
 -> SomeBean m -> [(BeanConstructionStep, BeanConstructionStep)])
-> Map TypeRep (SomeBean m)
-> [(BeanConstructionStep, BeanConstructionStep)]
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey)
    Map TypeRep (SomeBean m)
recipes
    \TypeRep
beanRep
     ( SomeBean
         ( Bean
             { constructor :: forall (m :: * -> *) bean. Bean m bean -> Constructor m bean
constructor = Constructor m bean
constructor :: Constructor m bean,
               decos :: forall (m :: * -> *) bean. Bean m bean -> Decos m bean
decos = Decos {Seq (Constructor m bean)
decoCons :: forall (m :: * -> *) bean. Decos m bean -> Seq (Constructor m bean)
decoCons :: Seq (Constructor m bean)
decoCons}
             }
           )
       ) -> do
        let bareBean :: BeanConstructionStep
bareBean = TypeRep -> BeanConstructionStep
BarePrimaryBean TypeRep
beanRep
            boiledBean :: BeanConstructionStep
boiledBean = TypeRep -> BeanConstructionStep
PrimaryBean TypeRep
beanRep
            decos :: [(BeanConstructionStep, Constructor m bean)]
decos = do
              (decoIndex, decoCon) <- PathToCauldron
-> [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)
decoCons)
              [(PrimaryBeanDeco beanRep decoIndex, decoCon)]
            beanDeps :: [(BeanConstructionStep, BeanConstructionStep)]
beanDeps = do
              (TypeRep -> BeanConstructionStep)
-> BeanConstructionStep
-> ConstructorReps
-> [(BeanConstructionStep, BeanConstructionStep)]
constructorEdges TypeRep -> BeanConstructionStep
makeTargetStep BeanConstructionStep
bareBean (do Constructor m bean -> ConstructorReps
forall bean (m :: * -> *).
Typeable bean =>
Constructor m bean -> ConstructorReps
constructorReps Constructor m bean
constructor)
            decoDeps :: [(BeanConstructionStep, BeanConstructionStep)]
decoDeps = do
              (decoBean, decoCon) <- [(BeanConstructionStep, Constructor m bean)]
decos
              constructorEdges makeTargetStep decoBean (removeBeanFromArgs do constructorReps decoCon)
            full :: NonEmpty BeanConstructionStep
full = BeanConstructionStep
bareBean BeanConstructionStep -> Plan -> NonEmpty 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)]
decos) Plan -> Plan -> Plan
forall a. [a] -> [a] -> [a]
++ [BeanConstructionStep
boiledBean]
            innerDeps :: [(BeanConstructionStep, BeanConstructionStep)]
innerDeps = Plan -> Plan -> [(BeanConstructionStep, BeanConstructionStep)]
forall a b. [a] -> [b] -> [(a, b)]
zip (NonEmpty BeanConstructionStep -> Plan
forall a. NonEmpty a -> [a]
Data.List.NonEmpty.tail NonEmpty BeanConstructionStep
full) (NonEmpty BeanConstructionStep -> Plan
forall a. NonEmpty a -> [a]
Data.List.NonEmpty.toList NonEmpty BeanConstructionStep
full)
        [(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) =>
  BoiledBeans ->
  (Tree (Plan, Fire m, Cauldron m)) ->
  m (Tree BoiledBeans)
followPlan :: forall (m :: * -> *).
Monad m =>
BoiledBeans
-> Tree (Plan, Fire m, Cauldron m) -> m (Tree BoiledBeans)
followPlan BoiledBeans
initial Tree (Plan, Fire m, Cauldron m)
treecipes =
  ((BoiledBeans, Tree (Plan, Fire m, Cauldron m))
 -> m (BoiledBeans,
       [(BoiledBeans, Tree (Plan, Fire m, Cauldron m))]))
-> (BoiledBeans, Tree (Plan, Fire m, Cauldron m))
-> m (Tree BoiledBeans)
forall (m :: * -> *) b a.
Monad m =>
(b -> m (a, [b])) -> b -> m (Tree a)
unfoldTreeM
    ( \(BoiledBeans
initial', Node (Plan
plan, Fire {Cauldron m -> BoiledBeans -> Plan -> m BoiledBeans
followPlanCauldron :: forall (m :: * -> *).
Fire m -> Cauldron m -> BoiledBeans -> Plan -> m BoiledBeans
followPlanCauldron :: Cauldron m -> BoiledBeans -> Plan -> m BoiledBeans
followPlanCauldron}, Cauldron m
cauldron) [Tree (Plan, Fire m, Cauldron m)]
rest) -> do
        newInitial' <- Cauldron m -> BoiledBeans -> Plan -> m BoiledBeans
followPlanCauldron Cauldron m
cauldron BoiledBeans
initial' Plan
plan
        pure (newInitial', (,) newInitial' <$> rest)
    )
    (BoiledBeans
initial, Tree (Plan, Fire m, Cauldron m)
treecipes)

followPlanStep ::
  (Monad m) =>
  Cauldron m ->
  BoiledBeans ->
  BoiledBeans ->
  BeanConstructionStep ->
  m BoiledBeans
followPlanStep :: forall (m :: * -> *).
Monad m =>
Cauldron m
-> BoiledBeans
-> BoiledBeans
-> BeanConstructionStep
-> m BoiledBeans
followPlanStep Cauldron {Map TypeRep (SomeBean m)
recipes :: forall (m :: * -> *). Cauldron m -> Map TypeRep (SomeBean m)
recipes :: Map TypeRep (SomeBean m)
recipes} (BoiledBeans Map TypeRep Dynamic
final) (BoiledBeans Map TypeRep Dynamic
super) BeanConstructionStep
item =
  Map TypeRep Dynamic -> BoiledBeans
BoiledBeans (Map TypeRep Dynamic -> BoiledBeans)
-> m (Map TypeRep Dynamic) -> m BoiledBeans
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case BeanConstructionStep
item of
    BarePrimaryBean TypeRep
rep -> case Maybe (SomeBean m) -> SomeBean m
forall a. HasCallStack => Maybe a -> a
fromJust do TypeRep -> Map TypeRep (SomeBean m) -> Maybe (SomeBean m)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TypeRep
rep Map TypeRep (SomeBean m)
recipes of
      SomeBean (Bean {Constructor m bean
constructor :: forall (m :: * -> *) bean. Bean m bean -> Constructor m bean
constructor :: Constructor m bean
constructor}) -> do
        let ConstructorReps {TypeRep
beanRep :: ConstructorReps -> TypeRep
beanRep :: TypeRep
beanRep} = Constructor m bean -> ConstructorReps
forall bean (m :: * -> *).
Typeable bean =>
Constructor m bean -> ConstructorReps
constructorReps Constructor m bean
constructor
        -- We delete the beanRep before running the constructor,
        -- 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.
        (super', bean) <- Constructor m bean
-> Map TypeRep Dynamic
-> Map TypeRep Dynamic
-> m (Map TypeRep Dynamic, bean)
forall (m :: * -> *) bean.
Monad m =>
Constructor m bean
-> Map TypeRep Dynamic
-> Map TypeRep Dynamic
-> m (Map TypeRep Dynamic, bean)
followConstructor Constructor m bean
constructor Map TypeRep Dynamic
final (TypeRep -> Map TypeRep Dynamic -> Map TypeRep Dynamic
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete TypeRep
beanRep Map TypeRep Dynamic
super)
        pure do Map.insert beanRep (toDyn bean) super'
    PrimaryBeanDeco TypeRep
rep Int
index -> case Maybe (SomeBean m) -> SomeBean m
forall a. HasCallStack => Maybe a -> a
fromJust do TypeRep -> Map TypeRep (SomeBean m) -> Maybe (SomeBean m)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TypeRep
rep Map TypeRep (SomeBean m)
recipes of
      SomeBean (Bean {decos :: forall (m :: * -> *) bean. Bean m bean -> Decos m bean
decos = Decos {Seq (Constructor m bean)
decoCons :: forall (m :: * -> *) bean. Decos m bean -> Seq (Constructor m bean)
decoCons :: Seq (Constructor m bean)
decoCons}}) -> do
        let decoCon :: Constructor m bean
decoCon = Maybe (Constructor m bean) -> Constructor m bean
forall a. HasCallStack => Maybe a -> a
fromJust do Int -> Seq (Constructor m bean) -> Maybe (Constructor m bean)
forall a. Int -> Seq a -> Maybe a
Seq.lookup Int
index Seq (Constructor m bean)
decoCons
        let ConstructorReps {TypeRep
beanRep :: ConstructorReps -> TypeRep
beanRep :: TypeRep
beanRep} = Constructor m bean -> ConstructorReps
forall bean (m :: * -> *).
Typeable bean =>
Constructor m bean -> ConstructorReps
constructorReps Constructor m bean
decoCon
        -- Unlike before, we don't delete the beanRep before running the constructor.
        (super', bean) <- Constructor m bean
-> Map TypeRep Dynamic
-> Map TypeRep Dynamic
-> m (Map TypeRep Dynamic, bean)
forall (m :: * -> *) bean.
Monad m =>
Constructor m bean
-> Map TypeRep Dynamic
-> Map TypeRep Dynamic
-> m (Map TypeRep Dynamic, bean)
followConstructor Constructor m bean
decoCon Map TypeRep Dynamic
final Map TypeRep Dynamic
super
        pure do Map.insert beanRep (toDyn bean) super'
    -- \| We do nothing here, the work has been done in previous 'BarePrimaryBean' and
    -- 'PrimaryBeanDeco' steps.
    PrimaryBean TypeRep
_ -> Map TypeRep Dynamic -> m (Map TypeRep Dynamic)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map TypeRep Dynamic
super
    -- \| We do nothing here, secondary beans are built as a byproduct
    -- of primary beans and decorators.
    SecondaryBean TypeRep
_ -> Map TypeRep Dynamic -> m (Map TypeRep Dynamic)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map TypeRep Dynamic
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) =>
  Constructor m bean ->
  Map TypeRep Dynamic ->
  Map TypeRep Dynamic ->
  m (Map TypeRep Dynamic, bean)
followConstructor :: forall (m :: * -> *) bean.
Monad m =>
Constructor m bean
-> Map TypeRep Dynamic
-> Map TypeRep Dynamic
-> m (Map TypeRep Dynamic, bean)
followConstructor Constructor {constructor_ :: ()
constructor_ = Args {NP I args -> m (Regs regs bean)
runArgs :: NP I args -> m (Regs regs bean)
runArgs :: forall (args :: [*]) r. Args args r -> NP I args -> r
runArgs}} Map TypeRep Dynamic
final Map TypeRep Dynamic
super = do
  let Extractor {Map TypeRep Dynamic -> Map TypeRep Dynamic -> NP I args
runExtractor :: Map TypeRep Dynamic -> Map TypeRep Dynamic -> NP I args
runExtractor :: forall a.
Extractor a -> Map TypeRep Dynamic -> Map TypeRep Dynamic -> a
runExtractor} = NP Extractor args -> Extractor (NP I args)
forall (xs :: [*]) (f :: * -> *).
(SListI xs, Applicative f) =>
NP f xs -> f (NP I xs)
sequence_NP do Proxy Typeable
-> (forall a. Typeable a => Extractor a) -> NP Extractor args
forall {k} (c :: k -> Constraint) (xs :: [k])
       (proxy :: (k -> Constraint) -> *) (f :: k -> *).
All c xs =>
proxy c -> (forall (a :: k). c a => f a) -> NP f xs
cpure_NP (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @Typeable) Extractor a
forall a. Typeable a => Extractor a
makeExtractor
      args :: NP I args
args = Map TypeRep Dynamic -> Map TypeRep Dynamic -> NP I args
runExtractor Map TypeRep Dynamic
final Map TypeRep Dynamic
super
  results <- NP I args -> m (Regs regs bean)
runArgs NP I args
args
  case results of
    Regs NP I regs
regs bean
bean -> do
      let inserters :: Endo (Map TypeRep Dynamic)
inserters = Proxy (And Typeable Monoid)
-> (forall a.
    And Typeable Monoid a =>
    I a -> Endo (Map TypeRep Dynamic))
-> NP I regs
-> Endo (Map TypeRep Dynamic)
forall {k} (c :: k -> Constraint) (xs :: [k]) m
       (proxy :: (k -> Constraint) -> *) (f :: k -> *).
(All c xs, Monoid m) =>
proxy c -> (forall (a :: k). c a => f a -> m) -> NP f xs -> m
cfoldMap_NP (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @(Typeable `And` Monoid)) I a -> Endo (Map TypeRep Dynamic)
forall a.
And Typeable Monoid a =>
I a -> Endo (Map TypeRep Dynamic)
makeRegInserter NP I regs
regs
      (Map TypeRep Dynamic, bean) -> m (Map TypeRep Dynamic, bean)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Endo (Map TypeRep Dynamic)
-> Map TypeRep Dynamic -> Map TypeRep Dynamic
forall a. Endo a -> a -> a
appEndo Endo (Map TypeRep Dynamic)
inserters Map TypeRep Dynamic
super, bean
bean)

newtype Extractor a where
  Extractor :: {forall a.
Extractor a -> Map TypeRep Dynamic -> Map TypeRep Dynamic -> a
runExtractor :: Map TypeRep Dynamic -> Map TypeRep Dynamic -> a} -> Extractor a
  deriving ((forall a b. (a -> b) -> Extractor a -> Extractor b)
-> (forall a b. a -> Extractor b -> Extractor a)
-> Functor Extractor
forall a b. a -> Extractor b -> Extractor a
forall a b. (a -> b) -> Extractor a -> Extractor b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Extractor a -> Extractor b
fmap :: forall a b. (a -> b) -> Extractor a -> Extractor b
$c<$ :: forall a b. a -> Extractor b -> Extractor a
<$ :: forall a b. a -> Extractor b -> Extractor a
Functor, Functor Extractor
Functor Extractor =>
(forall a. a -> Extractor a)
-> (forall a b. Extractor (a -> b) -> Extractor a -> Extractor b)
-> (forall a b c.
    (a -> b -> c) -> Extractor a -> Extractor b -> Extractor c)
-> (forall a b. Extractor a -> Extractor b -> Extractor b)
-> (forall a b. Extractor a -> Extractor b -> Extractor a)
-> Applicative Extractor
forall a. a -> Extractor a
forall a b. Extractor a -> Extractor b -> Extractor a
forall a b. Extractor a -> Extractor b -> Extractor b
forall a b. Extractor (a -> b) -> Extractor a -> Extractor b
forall a b c.
(a -> b -> c) -> Extractor a -> Extractor b -> Extractor c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Extractor a
pure :: forall a. a -> Extractor a
$c<*> :: forall a b. Extractor (a -> b) -> Extractor a -> Extractor b
<*> :: forall a b. Extractor (a -> b) -> Extractor a -> Extractor b
$cliftA2 :: forall a b c.
(a -> b -> c) -> Extractor a -> Extractor b -> Extractor c
liftA2 :: forall a b c.
(a -> b -> c) -> Extractor a -> Extractor b -> Extractor c
$c*> :: forall a b. Extractor a -> Extractor b -> Extractor b
*> :: forall a b. Extractor a -> Extractor b -> Extractor b
$c<* :: forall a b. Extractor a -> Extractor b -> Extractor a
<* :: forall a b. Extractor a -> Extractor b -> Extractor a
Applicative) via ((->) (Map TypeRep Dynamic) `Compose` ((->) (Map TypeRep Dynamic)))

makeExtractor :: forall a. (Typeable a) => Extractor a
makeExtractor :: forall a. Typeable a => Extractor a
makeExtractor =
  let runExtractor :: Map TypeRep Dynamic -> Map TypeRep Dynamic -> a
runExtractor Map TypeRep Dynamic
final Map TypeRep Dynamic
super =
        Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust do forall bean. Typeable bean => Map TypeRep Dynamic -> Maybe bean
taste' @a Map TypeRep Dynamic
super Maybe a -> Maybe a -> Maybe a
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall bean. Typeable bean => Map TypeRep Dynamic -> Maybe bean
taste' @a Map TypeRep Dynamic
final
   in Extractor {Map TypeRep Dynamic -> Map TypeRep Dynamic -> a
runExtractor :: Map TypeRep Dynamic -> Map TypeRep Dynamic -> a
runExtractor :: Map TypeRep Dynamic -> Map TypeRep Dynamic -> a
runExtractor}

makeRegInserter :: forall a. ((Typeable `And` Monoid) a) => I a -> Endo (Map TypeRep Dynamic)
makeRegInserter :: forall a.
And Typeable Monoid a =>
I a -> Endo (Map TypeRep Dynamic)
makeRegInserter (I a
a) =
  let appEndo :: Map TypeRep Dynamic -> Map TypeRep Dynamic
appEndo Map TypeRep Dynamic
dynMap = do
        let reg :: a
reg = Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust do forall bean. Typeable bean => Map TypeRep Dynamic -> Maybe bean
taste' @a Map TypeRep Dynamic
dynMap
            dyn :: Dynamic
dyn = a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn (a
reg a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
a)
        TypeRep -> Dynamic -> Map TypeRep Dynamic -> Map TypeRep Dynamic
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Dynamic -> TypeRep
dynTypeRep Dynamic
dyn) Dynamic
dyn Map TypeRep Dynamic
dynMap
   in Endo {Map TypeRep Dynamic -> Map TypeRep Dynamic
appEndo :: Map TypeRep Dynamic -> Map TypeRep Dynamic
appEndo :: Map TypeRep Dynamic -> Map TypeRep Dynamic
appEndo}

-- | Return the resulting @bean@, if present.
taste :: forall bean. (Typeable bean) => BoiledBeans -> Maybe bean
taste :: forall bean. Typeable bean => BoiledBeans -> Maybe bean
taste BoiledBeans {Map TypeRep Dynamic
beans :: BoiledBeans -> Map TypeRep Dynamic
beans :: Map TypeRep Dynamic
beans} = Map TypeRep Dynamic -> Maybe bean
forall bean. Typeable bean => Map TypeRep Dynamic -> Maybe bean
taste' Map TypeRep Dynamic
beans

taste' :: forall bean. (Typeable bean) => Map TypeRep Dynamic -> Maybe bean
taste' :: forall bean. Typeable bean => Map TypeRep Dynamic -> Maybe bean
taste' Map TypeRep Dynamic
beans = 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)
  dyn <- TypeRep -> Map TypeRep Dynamic -> Maybe Dynamic
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TypeRep
rep Map TypeRep Dynamic
beans
  fromDynamic @bean dyn

-- | Sometimes the 'cook'ing process goes wrong.
data BadBeans
  = -- | The 'Cauldron' identified by 'PathToCauldron' has beans
    -- that depend on beans that can't be found either in the current 'Cauldron' or its ancestors.
    MissingDependencies PathToCauldron (Map TypeRep (Set TypeRep))
  | -- | Beans that work both as primary beans and as secondary beans
    -- are disallowed.
    DoubleDutyBeans (Set TypeRep)
  | -- | Dependency cycles are disallowed by some 'Fire's.
    DependencyCycle (NonEmpty BeanConstructionStep)
  deriving stock (Int -> BadBeans -> ShowS
[BadBeans] -> ShowS
BadBeans -> [Char]
(Int -> BadBeans -> ShowS)
-> (BadBeans -> [Char]) -> ([BadBeans] -> ShowS) -> Show BadBeans
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BadBeans -> ShowS
showsPrec :: Int -> BadBeans -> ShowS
$cshow :: BadBeans -> [Char]
show :: BadBeans -> [Char]
$cshowList :: [BadBeans] -> ShowS
showList :: [BadBeans] -> ShowS
Show)

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

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

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}

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.
collapsePrimaryBeans :: DependencyGraph -> DependencyGraph
collapsePrimaryBeans :: DependencyGraph -> DependencyGraph
collapsePrimaryBeans 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).
exportToDot :: (BeanConstructionStep -> Data.Text.Text) -> FilePath -> DependencyGraph -> IO ()
exportToDot :: (BeanConstructionStep -> Text)
-> [Char] -> DependencyGraph -> IO ()
exportToDot BeanConstructionStep -> Text
prettyRep [Char]
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
          do (BeanConstructionStep -> Text) -> Style BeanConstructionStep Text
forall s a. Monoid s => (a -> s) -> Style a s
Dot.defaultStyle BeanConstructionStep -> Text
prettyRep
          AdjacencyMap BeanConstructionStep
graph
  [Char] -> ByteString -> IO ()
Data.ByteString.writeFile [Char]
filepath (Text -> ByteString
Data.Text.Encoding.encodeUtf8 Text
dot)

defaultStepToText :: BeanConstructionStep -> Data.Text.Text
defaultStepToText :: BeanConstructionStep -> Text
defaultStepToText =
  let p :: a -> Text
p a
rep = [Char] -> Text
Data.Text.pack do a -> [Char]
forall a. Show a => a -> [Char]
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
<> [Char] -> Text
Data.Text.pack [Char]
"#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
<> [Char] -> Text
Data.Text.pack ([Char]
"#deco#" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
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
<> [Char] -> Text
Data.Text.pack [Char]
"#sec"

newtype Args args r = Args {forall (args :: [*]) r. Args args r -> NP I args -> r
runArgs :: NP I args -> r}
  deriving newtype ((forall a b. (a -> b) -> Args args a -> Args args b)
-> (forall a b. a -> Args args b -> Args args a)
-> Functor (Args args)
forall (args :: [*]) a b. a -> Args args b -> Args args a
forall (args :: [*]) a b. (a -> b) -> Args args a -> Args args b
forall a b. a -> Args args b -> Args args a
forall a b. (a -> b) -> Args args a -> Args args b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (args :: [*]) a b. (a -> b) -> Args args a -> Args args b
fmap :: forall a b. (a -> b) -> Args args a -> Args args b
$c<$ :: forall (args :: [*]) a b. a -> Args args b -> Args args a
<$ :: forall a b. a -> Args args b -> Args args a
Functor, Functor (Args args)
Functor (Args args) =>
(forall a. a -> Args args a)
-> (forall a b. Args args (a -> b) -> Args args a -> Args args b)
-> (forall a b c.
    (a -> b -> c) -> Args args a -> Args args b -> Args args c)
-> (forall a b. Args args a -> Args args b -> Args args b)
-> (forall a b. Args args a -> Args args b -> Args args a)
-> Applicative (Args args)
forall (args :: [*]). Functor (Args args)
forall (args :: [*]) a. a -> Args args a
forall (args :: [*]) a b. Args args a -> Args args b -> Args args a
forall (args :: [*]) a b. Args args a -> Args args b -> Args args b
forall (args :: [*]) a b.
Args args (a -> b) -> Args args a -> Args args b
forall (args :: [*]) a b c.
(a -> b -> c) -> Args args a -> Args args b -> Args args c
forall a. a -> Args args a
forall a b. Args args a -> Args args b -> Args args a
forall a b. Args args a -> Args args b -> Args args b
forall a b. Args args (a -> b) -> Args args a -> Args args b
forall a b c.
(a -> b -> c) -> Args args a -> Args args b -> Args args c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall (args :: [*]) a. a -> Args args a
pure :: forall a. a -> Args args a
$c<*> :: forall (args :: [*]) a b.
Args args (a -> b) -> Args args a -> Args args b
<*> :: forall a b. Args args (a -> b) -> Args args a -> Args args b
$cliftA2 :: forall (args :: [*]) a b c.
(a -> b -> c) -> Args args a -> Args args b -> Args args c
liftA2 :: forall a b c.
(a -> b -> c) -> Args args a -> Args args b -> Args args c
$c*> :: forall (args :: [*]) a b. Args args a -> Args args b -> Args args b
*> :: forall a b. Args args a -> Args args b -> Args args b
$c<* :: forall (args :: [*]) a b. Args args a -> Args args b -> Args args a
<* :: forall a b. Args args a -> Args args b -> Args args a
Applicative, Applicative (Args args)
Applicative (Args args) =>
(forall a b. Args args a -> (a -> Args args b) -> Args args b)
-> (forall a b. Args args a -> Args args b -> Args args b)
-> (forall a. a -> Args args a)
-> Monad (Args args)
forall (args :: [*]). Applicative (Args args)
forall (args :: [*]) a. a -> Args args a
forall (args :: [*]) a b. Args args a -> Args args b -> Args args b
forall (args :: [*]) a b.
Args args a -> (a -> Args args b) -> Args args b
forall a. a -> Args args a
forall a b. Args args a -> Args args b -> Args args b
forall a b. Args args a -> (a -> Args args b) -> Args args b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (args :: [*]) a b.
Args args a -> (a -> Args args b) -> Args args b
>>= :: forall a b. Args args a -> (a -> Args args b) -> Args args b
$c>> :: forall (args :: [*]) a b. Args args a -> Args args b -> Args args b
>> :: forall a b. Args args a -> Args args b -> Args args b
$creturn :: forall (args :: [*]) a. a -> Args args a
return :: forall a. a -> Args args a
Monad)

argsN ::
  forall (args :: [Type]) r curried.
  (MulticurryableF args r curried (IsFunction curried)) =>
  curried ->
  Args args r
argsN :: forall (args :: [*]) r curried.
MulticurryableF args r curried (IsFunction curried) =>
curried -> Args args r
argsN = (NP I args -> r) -> Args args r
forall (args :: [*]) r. (NP I args -> r) -> Args args r
Args ((NP I args -> r) -> Args args r)
-> (curried -> NP I args -> r) -> curried -> Args args r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. curried -> NP I args -> r
curried -> UncurriedArgs (->) args -> r
forall (f :: * -> * -> *) (items :: [*]) a curried.
Multicurryable f items a curried =>
curried -> f (UncurriedArgs f items) a
multiuncurry

-- $registrations
--
-- 'Constructor's produce a single primary bean, but sometimes they might also
-- \"register\" a number of secondary beans.
--
-- These secondary beans
-- must have 'Monoid' instances and, unlike the primary bean, can be produced by
-- more that one 'Constructor'. Their values are aggregated across all the 'Constructor's
-- that produce them. The final aggregated value can be depended upon by other 'Constructor's
-- as if it were a normal bean.
--
-- The 'Regs' type is used to represent the main bean along with the secondary
-- beans that it registers. Because usually we'll be working with functions that
-- do not use the 'Regs' type, a 'Packer' must be used to coax the \"tip\" of
-- the constructor function into the required shape expected by 'Constructor'.
--
-- >>> :{
-- data A = A deriving Show
-- data B = B deriving Show
-- data C = C (Sum Int) deriving Show
-- makeA :: (Sum Int, A)
-- makeA = (Sum 1, A)
-- makeB :: A -> IO (Sum Int, B)
-- makeB = \_ -> pure (Sum 2, B)
-- makeC :: Sum Int -> C
-- makeC = \theSum -> C theSum
-- :}
--
--
-- >>> :{
-- do
--   let cauldron :: Cauldron IO
--       cauldron =
--         emptyCauldron
--         & insert @A do makeBean do pack (valueWith \(s, a) -> regs1 s a) makeA
--         & insert @B do makeBean do pack (effectWith \(s, b) -> regs1 s b) makeB
--         & insert @C do makeBean do pack value makeC
--       Right (_ :: DependencyGraph, action) = cook forbidDepCycles cauldron
--   beans <- action
--   pure do taste @C beans
-- :}
-- Just (C (Sum {getSum = 3}))

-- | Auxiliary type which contains a primary bean along with zero or more
-- secondary beans. The secondary beans must have
-- 'Monoid' instances.
data Regs (regs :: [Type]) bean = Regs (NP I regs) bean
  deriving ((forall a b. (a -> b) -> Regs regs a -> Regs regs b)
-> (forall a b. a -> Regs regs b -> Regs regs a)
-> Functor (Regs regs)
forall (regs :: [*]) a b. a -> Regs regs b -> Regs regs a
forall (regs :: [*]) a b. (a -> b) -> Regs regs a -> Regs regs b
forall a b. a -> Regs regs b -> Regs regs a
forall a b. (a -> b) -> Regs regs a -> Regs regs b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (regs :: [*]) a b. (a -> b) -> Regs regs a -> Regs regs b
fmap :: forall a b. (a -> b) -> Regs regs a -> Regs regs b
$c<$ :: forall (regs :: [*]) a b. a -> Regs regs b -> Regs regs a
<$ :: forall a b. a -> Regs regs b -> Regs regs a
Functor)

-- | A primary @bean@ without secondary beans.
regs0 :: bean -> Regs '[] bean
regs0 :: forall bean. bean -> Regs '[] bean
regs0 bean
bean = NP I '[] -> bean -> Regs '[] bean
forall (regs :: [*]) bean. NP I regs -> bean -> Regs regs bean
Regs NP I '[]
forall {k} (a :: k -> *). NP a '[]
Nil bean
bean

-- | A primary @bean@ with one secondary bean.
regs1 :: reg1 -> bean -> Regs '[reg1] bean
regs1 :: forall reg1 bean. reg1 -> bean -> Regs '[reg1] bean
regs1 reg1
reg1 bean
bean = NP I '[reg1] -> bean -> Regs '[reg1] bean
forall (regs :: [*]) bean. NP I regs -> bean -> Regs regs bean
Regs (reg1 -> I reg1
forall a. a -> I a
I reg1
reg1 I reg1 -> NP I '[] -> NP I '[reg1]
forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP I '[]
forall {k} (a :: k -> *). NP a '[]
Nil) bean
bean

-- | A primary @bean@ with two secondary beans.
regs2 :: reg1 -> reg2 -> bean -> Regs '[reg1, reg2] bean
regs2 :: forall reg1 reg2 bean.
reg1 -> reg2 -> bean -> Regs '[reg1, reg2] bean
regs2 reg1
reg1 reg2
reg2 bean
bean = NP I '[reg1, reg2] -> bean -> Regs '[reg1, reg2] bean
forall (regs :: [*]) bean. NP I regs -> bean -> Regs regs bean
Regs (reg1 -> I reg1
forall a. a -> I a
I reg1
reg1 I reg1 -> NP I '[reg2] -> NP I '[reg1, reg2]
forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* reg2 -> I reg2
forall a. a -> I a
I reg2
reg2 I reg2 -> NP I '[] -> NP I '[reg2]
forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP I '[]
forall {k} (a :: k -> *). NP a '[]
Nil) bean
bean

-- | A primary @bean@ with three secondary beans.
regs3 :: reg1 -> reg2 -> reg3 -> bean -> Regs '[reg1, reg2, reg3] bean
regs3 :: forall reg1 reg2 reg3 bean.
reg1 -> reg2 -> reg3 -> bean -> Regs '[reg1, reg2, reg3] bean
regs3 reg1
reg1 reg2
reg2 reg3
reg3 bean
bean = NP I '[reg1, reg2, reg3] -> bean -> Regs '[reg1, reg2, reg3] bean
forall (regs :: [*]) bean. NP I regs -> bean -> Regs regs bean
Regs (reg1 -> I reg1
forall a. a -> I a
I reg1
reg1 I reg1 -> NP I '[reg2, reg3] -> NP I '[reg1, reg2, reg3]
forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* reg2 -> I reg2
forall a. a -> I a
I reg2
reg2 I reg2 -> NP I '[reg3] -> NP I '[reg2, reg3]
forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* reg3 -> I reg3
forall a. a -> I a
I reg3
reg3 I reg3 -> NP I '[] -> NP I '[reg3]
forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP I '[]
forall {k} (a :: k -> *). NP a '[]
Nil) bean
bean

-- | Applies a transformation to the tip of a curried function, coaxing
-- it into the shape expected by a 'Constructor', which includes information
-- about which is the primary bean and which are the secondary ones.
--
-- * For pure constructors without registrations, try 'value'.
--
-- * For effectful constructors without registrations, try 'effect'.
--
-- More complex cases might require 'valueWith', 'effectWith', or working with
-- the 'Packer' constructor itself.
newtype Packer m regs bean r = Packer (r -> m (Regs regs bean))

runPacker :: Packer m regs bean r -> r -> m (Regs regs bean)
runPacker :: forall (m :: * -> *) (regs :: [*]) bean r.
Packer m regs bean r -> r -> m (Regs regs bean)
runPacker (Packer r -> m (Regs regs bean)
f) = r -> m (Regs regs bean)
f

instance Contravariant (Packer m regs bean) where
  contramap :: forall a' a.
(a' -> a) -> Packer m regs bean a -> Packer m regs bean a'
contramap a' -> a
f (Packer a -> m (Regs regs bean)
p) = (a' -> m (Regs regs bean)) -> Packer m regs bean a'
forall (m :: * -> *) (regs :: [*]) bean r.
(r -> m (Regs regs bean)) -> Packer m regs bean r
Packer (a -> m (Regs regs bean)
p (a -> m (Regs regs bean)) -> (a' -> a) -> a' -> m (Regs regs bean)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a' -> a
f)

-- | For pure constructors that return the @bean@ directly, and do not register
-- secondary beans.
value :: (Applicative m) => Packer m '[] bean bean
value :: forall (m :: * -> *) bean. Applicative m => Packer m '[] bean bean
value = (bean -> m (Regs '[] bean)) -> Packer m '[] bean bean
forall (m :: * -> *) (regs :: [*]) bean r.
(r -> m (Regs regs bean)) -> Packer m regs bean r
Packer \bean
bean -> Regs '[] bean -> m (Regs '[] bean)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure do bean -> Regs '[] bean
forall bean. bean -> Regs '[] bean
regs0 bean
bean

-- | For effectul constructors that return an @m bean@ initialization action,
-- and do not register secondary beans.
effect :: (Applicative m) => Packer m '[] bean (m bean)
effect :: forall (m :: * -> *) bean.
Applicative m =>
Packer m '[] bean (m bean)
effect = (m bean -> m (Regs '[] bean)) -> Packer m '[] bean (m bean)
forall (m :: * -> *) (regs :: [*]) bean r.
(r -> m (Regs regs bean)) -> Packer m regs bean r
Packer \m bean
action -> do (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 bean. bean -> Regs '[] bean
regs0 m bean
action

-- |
-- >>> :{
-- data A = A deriving Show
-- data B = B deriving Show
-- makeB :: A -> (Sum Int, B)
-- makeB = \_ -> (Sum 1, B)
-- constructorB :: Constructor IO B
-- constructorB = pack (valueWith \(s,bean) -> regs1 s bean) makeB
-- :}
valueWith ::
  (Applicative m, All (Typeable `And` Monoid) regs) =>
  -- | Massage the pure value at the tip of the constructor into a 'Regs'.
  (r -> Regs regs bean) ->
  Packer m regs bean r
valueWith :: forall (m :: * -> *) (regs :: [*]) r bean.
(Applicative m, All (And Typeable Monoid) regs) =>
(r -> Regs regs bean) -> Packer m regs bean r
valueWith r -> Regs regs bean
f = (r -> m (Regs regs bean)) -> Packer m regs bean r
forall (m :: * -> *) (regs :: [*]) bean r.
(r -> m (Regs regs bean)) -> Packer m regs bean r
Packer do Regs regs bean -> m (Regs regs bean)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Regs regs bean -> m (Regs regs bean))
-> (r -> Regs regs bean) -> r -> m (Regs regs bean)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> Regs regs bean
f

-- |
-- >>> :{
-- data A = A deriving Show
-- data B = B deriving Show
-- makeB :: A -> IO (Sum Int, B)
-- makeB = \_ -> pure (Sum 1, B)
-- constructorB :: Constructor IO B
-- constructorB = pack (effectWith \(s,bean) -> regs1 s bean) makeB
-- :}
effectWith ::
  (Applicative m, All (Typeable `And` Monoid) regs) =>
  -- | Massage the value returned by the action at the tip of the constructor into a 'Regs'.
  (r -> Regs regs bean) ->
  Packer m regs bean (m r)
effectWith :: forall (m :: * -> *) (regs :: [*]) r bean.
(Applicative m, All (And Typeable Monoid) regs) =>
(r -> Regs regs bean) -> Packer m regs bean (m r)
effectWith r -> Regs regs bean
f = (m r -> m (Regs regs bean)) -> Packer m regs bean (m r)
forall (m :: * -> *) (regs :: [*]) bean r.
(r -> m (Regs regs bean)) -> Packer m regs bean r
Packer do (r -> Regs regs bean) -> m r -> m (Regs regs bean)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap r -> Regs regs bean
f

-- | Take a curried function that constructs a bean, uncurry it recursively and
-- then apply a 'Packer' to its tip, resulting in a 'Constructor'.
--
-- >>> :{
-- data A = A deriving Show
-- data B = B deriving Show
-- data C = C deriving Show
-- makeB :: A -> B
-- makeB = \_ -> B
-- makeC :: A -> B -> IO C
-- makeC = \_ _ -> pure C
-- constructorB :: Constructor IO B
-- constructorB = pack value makeB
-- constructorC :: Constructor IO C
-- constructorC = pack effect makeC
-- :}
--
-- There are 'pack0', 'pack1'... functions which work for specific number of arguments, but
-- the generic 'pack' should work in most cases anyway.
pack ::
  forall (args :: [Type]) r curried regs bean m.
  ( MulticurryableF args r curried (IsFunction curried),
    All Typeable args,
    All (Typeable `And` Monoid) regs
  ) =>
  -- | Fit the outputs of the constructor into the auxiliary 'Regs' type.
  --
  -- See 'regs1' and similar functions.
  Packer m regs bean r ->
  -- | Action returning a function ending in @r@, some datatype containing
  -- @regs@ and @bean@ values.
  curried ->
  Constructor m bean
pack :: forall (args :: [*]) r curried (regs :: [*]) bean (m :: * -> *).
(MulticurryableF args r curried (IsFunction curried),
 All Typeable args, All (And Typeable Monoid) regs) =>
Packer m regs bean r -> curried -> Constructor m bean
pack Packer m regs bean r
packer curried
curried = Args args (m (Regs regs bean)) -> Constructor m bean
forall (args :: [*]) (regs :: [*]) (m :: * -> *) bean.
(All Typeable args, All (And Typeable Monoid) regs) =>
Args args (m (Regs regs bean)) -> Constructor m bean
Constructor do Packer m regs bean r -> r -> m (Regs regs bean)
forall (m :: * -> *) (regs :: [*]) bean r.
Packer m regs bean r -> r -> m (Regs regs bean)
runPacker Packer m regs bean r
packer (r -> m (Regs regs bean))
-> Args args r -> Args args (m (Regs regs bean))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do curried -> Args args r
forall (args :: [*]) r curried.
MulticurryableF args r curried (IsFunction curried) =>
curried -> Args args r
argsN curried
curried

-- | Slightly simpler version of 'pack' for @0@-argument functions.
pack0 ::
  (All (Typeable `And` Monoid) regs) =>
  Packer m regs bean r ->
  -- | @0@-argument constructor
  r ->
  Constructor m bean
pack0 :: forall (regs :: [*]) (m :: * -> *) bean r.
All (And Typeable Monoid) regs =>
Packer m regs bean r -> r -> Constructor m bean
pack0 Packer m regs bean r
packer r
r = Args '[] (m (Regs regs bean)) -> Constructor m bean
forall (args :: [*]) (regs :: [*]) (m :: * -> *) bean.
(All Typeable args, All (And Typeable Monoid) regs) =>
Args args (m (Regs regs bean)) -> Constructor m bean
Constructor do forall (args :: [*]) r. (NP I args -> r) -> Args args r
Args @'[] \NP I '[]
Nil -> Packer m regs bean r -> r -> m (Regs regs bean)
forall (m :: * -> *) (regs :: [*]) bean r.
Packer m regs bean r -> r -> m (Regs regs bean)
runPacker Packer m regs bean r
packer r
r

-- | Slightly simpler version of 'pack' for @1@-argument functions.
pack1 ::
  forall arg1 r m regs bean.
  (Typeable arg1, All (Typeable `And` Monoid) regs) =>
  Packer m regs bean r ->
  -- | @1@-argument constructor
  (arg1 -> r) ->
  Constructor m bean
pack1 :: forall arg1 r (m :: * -> *) (regs :: [*]) bean.
(Typeable arg1, All (And Typeable Monoid) regs) =>
Packer m regs bean r -> (arg1 -> r) -> Constructor m bean
pack1 Packer m regs bean r
packer arg1 -> r
f = Args '[arg1] (m (Regs regs bean)) -> Constructor m bean
forall (args :: [*]) (regs :: [*]) (m :: * -> *) bean.
(All Typeable args, All (And Typeable Monoid) regs) =>
Args args (m (Regs regs bean)) -> Constructor m bean
Constructor do forall (args :: [*]) r. (NP I args -> r) -> Args args r
Args @'[arg1] \(I x
arg1 :* NP I xs
Nil) -> Packer m regs bean r -> r -> m (Regs regs bean)
forall (m :: * -> *) (regs :: [*]) bean r.
Packer m regs bean r -> r -> m (Regs regs bean)
runPacker Packer m regs bean r
packer (arg1 -> r
f arg1
x
arg1)

-- | Slightly simpler version of 'pack' for @2@-argument functions.
pack2 ::
  forall arg1 arg2 r m regs bean.
  (Typeable arg1, Typeable arg2, All (Typeable `And` Monoid) regs) =>
  Packer m regs bean r ->
  -- | @2@-argument constructor
  (arg1 -> arg2 -> r) ->
  Constructor m bean
pack2 :: forall arg1 arg2 r (m :: * -> *) (regs :: [*]) bean.
(Typeable arg1, Typeable arg2, All (And Typeable Monoid) regs) =>
Packer m regs bean r -> (arg1 -> arg2 -> r) -> Constructor m bean
pack2 Packer m regs bean r
packer arg1 -> arg2 -> r
f = Args '[arg1, arg2] (m (Regs regs bean)) -> Constructor m bean
forall (args :: [*]) (regs :: [*]) (m :: * -> *) bean.
(All Typeable args, All (And Typeable Monoid) regs) =>
Args args (m (Regs regs bean)) -> Constructor m bean
Constructor do forall (args :: [*]) r. (NP I args -> r) -> Args args r
Args @[arg1, arg2] \(I x
arg1 :* I x
arg2 :* NP I xs
Nil) -> Packer m regs bean r -> r -> m (Regs regs bean)
forall (m :: * -> *) (regs :: [*]) bean r.
Packer m regs bean r -> r -> m (Regs regs bean)
runPacker Packer m regs bean r
packer (arg1 -> arg2 -> r
f arg1
x
arg1 arg2
x
arg2)

-- | Slightly simpler version of 'pack' for @3@-argument functions.
pack3 ::
  forall arg1 arg2 arg3 r m regs bean.
  (Typeable arg1, Typeable arg2, Typeable arg3, All (Typeable `And` Monoid) regs) =>
  Packer m regs bean r ->
  -- | @3@-argument constructor
  (arg1 -> arg2 -> arg3 -> r) ->
  Constructor m bean
pack3 :: forall arg1 arg2 arg3 r (m :: * -> *) (regs :: [*]) bean.
(Typeable arg1, Typeable arg2, Typeable arg3,
 All (And Typeable Monoid) regs) =>
Packer m regs bean r
-> (arg1 -> arg2 -> arg3 -> r) -> Constructor m bean
pack3 Packer m regs bean r
packer arg1 -> arg2 -> arg3 -> r
f = Args '[arg1, arg2, arg3] (m (Regs regs bean)) -> Constructor m bean
forall (args :: [*]) (regs :: [*]) (m :: * -> *) bean.
(All Typeable args, All (And Typeable Monoid) regs) =>
Args args (m (Regs regs bean)) -> Constructor m bean
Constructor do forall (args :: [*]) r. (NP I args -> r) -> Args args r
Args @[arg1, arg2, arg3] \(I x
arg1 :* I x
arg2 :* I x
arg3 :* NP I xs
Nil) -> Packer m regs bean r -> r -> m (Regs regs bean)
forall (m :: * -> *) (regs :: [*]) bean r.
Packer m regs bean r -> r -> m (Regs regs bean)
runPacker Packer m regs bean r
packer (arg1 -> arg2 -> arg3 -> r
f arg1
x
arg1 arg2
x
arg2 arg3
x
arg3)

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
_ -> [Char] -> NonEmpty a
forall a. HasCallStack => [Char] -> a
error [Char]
"tree not list-shaped"

-- $setup
-- >>> :set -XBlockArguments
-- >>> :set -Wno-incomplete-uni-patterns
-- >>> import Data.Functor.Identity
-- >>> import Data.Function ((&))
-- >>> import Data.Monoid