1
{-# LANGUAGE BlockArguments #-}
2
{-# LANGUAGE DataKinds #-}
3
{-# LANGUAGE DeriveAnyClass #-}
4
{-# LANGUAGE DerivingStrategies #-}
5
{-# LANGUAGE DerivingVia #-}
6
{-# LANGUAGE FunctionalDependencies #-}
7
{-# LANGUAGE GADTs #-}
8
{-# LANGUAGE LambdaCase #-}
9
{-# LANGUAGE TypeFamilies #-}
10
{-# LANGUAGE ViewPatterns #-}
11
{-# LANGUAGE NoFieldSelectors #-}
12
13
-- | This is a library for performing dependency injection. It's an alternative
14
-- to manually wiring your functions and passing all required parameters
15
-- explicitly. Instead of that, you throw your functions into a 'Cauldron', which wires
16
-- them for you, guiding itself by the types.
17
--
18
-- Wiring errors are detected at runtime, not at compile time.
19
--
20
-- 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,
21
-- and only there: the components we are wiring together need not be aware that the library exists.
22
--
23
-- These extensions, while not required, play well with the library:
24
--
25
-- @
26
-- {-# LANGUAGE ApplicativeDo #-} -- For building complex values in the Args applicative.
27
-- {-# LANGUAGE OverloadedLists #-} -- For avoiding explicit calls to fromRecipeList and fromDecoList
28
-- @
29
--
30
-- An example of using a 'Cauldron' to wire the constructors of dummy @A@, @B@, @C@ datatypes:
31
--
32
-- >>> :{
33
-- data A = A deriving Show
34
-- data B = B deriving Show
35
-- data C = C deriving Show
36
-- makeA :: A
37
-- makeA = A
38
-- makeB :: A -> B
39
-- makeB = \_ -> B
40
-- makeC :: A -> B -> IO C
41
-- makeC = \_ _ -> pure C
42
-- :}
43
--
44
-- >>> :{
45
-- do
46
--   let cauldron :: Cauldron IO
47
--       cauldron = [
48
--           recipe @A $ val $ wire makeA,
49
--           recipe @B $ val $ wire makeB,
50
--           recipe @C $ eff $ wire makeC -- we use eff because the constructor has IO effects
51
--         ]
52
--   action <- either throwIO pure $ cook forbidDepCycles cauldron
53
--   beans <- action
54
--   pure $ taste @C beans
55
-- :}
56
-- Just C
57
module Cauldron
58
  ( -- * Filling the cauldron
59
    Cauldron,
60
    empty,
61
    insert,
62
    adjust,
63
    delete,
64
    keysSet,
65
    restrictKeys,
66
    fromRecipeList,
67
    toRecipeMap,
68
    hoistCauldron,
69
    hoistCauldron',
70
71
    -- * Recipes
72
    Recipe (..),
73
    ToRecipe,
74
    fromDecoList,
75
    (Data.Sequence.|>),
76
    (Data.Sequence.<|),
77
    hoistRecipe,
78
    hoistRecipe',
79
80
    -- ** How decorators work
81
    -- $decos
82
83
    -- ** Hiding a 'Recipe''s bean type
84
    SomeRecipe,
85
    recipe,
86
    withRecipe,
87
    getRecipeCallStack,
88
89
    -- * Constructors
90
    -- $constructors
91
    Constructor,
92
    val_,
93
    val,
94
    val',
95
    eff_,
96
    ioEff_,
97
    eff,
98
    ioEff,
99
    eff',
100
    wire,
101
    getConstructorArgs,
102
    getConstructorCallStack,
103
    hoistConstructor,
104
    hoistConstructor',
105
106
    -- ** Registering secondary beans
107
    -- $secondarybeans
108
109
    -- * Cooking the beans
110
    cook,
111
    cookNonEmpty,
112
    cookTree,
113
114
    -- ** How loopy can we get?
115
    Fire,
116
    forbidDepCycles,
117
    allowSelfDeps,
118
    allowDepCycles,
119
120
    -- ** Tasting the results
121
    Beans,
122
    taste,
123
124
    -- ** When things go wrong
125
    RecipeError (..),
126
    MissingDependencies (..),
127
    DoubleDutyBeans (..),
128
    DependencyCycle (..),
129
    prettyRecipeError,
130
    prettyRecipeErrorLines,
131
132
    -- ** Visualizing dependencies between beans.
133
    getDependencyGraph,
134
    DependencyGraph,
135
    writeAsDot,
136
    defaultStyle,
137
    setVertexName,
138
    BeanConstructionStep (..),
139
    toAdjacencyMap,
140
141
    -- *** Simplifying the dep graph
142
    -- $simplifygraph
143
    removeSecondaryBeans,
144
    removeDecos,
145
    collapseToPrimaryBeans,
146
  )
147
where
148
149
import Algebra.Graph.AdjacencyMap (AdjacencyMap)
150
import Algebra.Graph.AdjacencyMap qualified as Graph
151
import Algebra.Graph.AdjacencyMap.Algorithm qualified as Graph
152
import Algebra.Graph.Export.Dot qualified as Dot
153
import Cauldron.Args
154
import Cauldron.Beans (SomeMonoidTypeRep (..))
155
import Cauldron.Beans qualified
156
import Control.Exception (Exception (..))
157
import Control.Monad.Fix
158
import Control.Monad.IO.Class
159
import Data.Bifunctor (first)
160
import Data.ByteString qualified
161
import Data.Dynamic
162
import Data.Foldable qualified
163
import Data.Function ((&))
164
import Data.Functor ((<&>))
165
import Data.Functor.Identity (Identity (..))
166
import Data.Kind
167
import Data.List qualified
168
import Data.List.NonEmpty (NonEmpty)
169
import Data.List.NonEmpty qualified
170
import Data.Map.Strict (Map)
171
import Data.Map.Strict qualified as Map
172
import Data.Maybe (fromJust)
173
import Data.Semigroup qualified
174
import Data.Sequence (Seq)
175
import Data.Sequence qualified
176
import Data.Set (Set)
177
import Data.Set qualified as Set
178
import Data.Text qualified
179
import Data.Text.Encoding qualified
180
import Data.Tree
181
import Data.Type.Equality (testEquality)
182
import Data.Typeable
183
import GHC.Exception (CallStack, prettyCallStackLines)
184
import GHC.IsList
185
import GHC.Stack (HasCallStack, callStack, withFrozenCallStack)
186
import Type.Reflection qualified
187
188
-- | A map of bean recipes, indexed by the 'TypeRep' of the bean each recipe
189
-- ultimately produces. Only one recipe is allowed for each bean type.
190
-- Parameterized by the monad @m@ in which the recipe 'Constructor's might have
191
-- effects.
192
type Cauldron :: (Type -> Type) -> Type
193
newtype Cauldron m where
194
  Cauldron :: {recipeMap :: Map TypeRep (SomeRecipe m)} -> Cauldron m
195
196
empty :: Cauldron m
197
empty = Cauldron Map.empty
198
199
-- | Union of two 'Cauldron's, right-biased: prefers 'Recipe's from the /right/ cauldron when
200
-- both contain the same key. (Note that 'Data.Map.Map' is left-biased.)
201
instance Semigroup (Cauldron m) where
202
  Cauldron {recipeMap = r1} <> Cauldron {recipeMap = r2} = Cauldron do Map.unionWith (flip const) r1 r2
203
204
instance Monoid (Cauldron m) where
205
  mempty = Cauldron Map.empty
206
207
instance IsList (Cauldron m) where
208
  type Item (Cauldron m) = SomeRecipe m
209
  toList (Cauldron {recipeMap}) = Map.elems recipeMap
210
  fromList = fromRecipeList
211
212
-- | Change the monad used by the 'Recipe's in the 'Cauldron'.
213
hoistCauldron :: (forall x. m x -> n x) -> Cauldron m -> Cauldron n
214
hoistCauldron f (Cauldron {recipeMap}) = Cauldron {recipeMap = hoistSomeRecipe f <$> recipeMap}
215
216
-- | More general form of 'hoistCauldron' that lets you modify the 'Args'
217
-- inside all the 'Recipe's in the 'Cauldron'. See 'hoistRecipe''.
218
hoistCauldron' ::
219
  -- | Transformation to apply to the base constructor of each recipe.
220
  (forall x. (Typeable x) => Args (m (Regs x)) -> Args (n (Regs x))) ->
221
  -- | Transformation to apply to each decorator. Takes the decorator index as parameter.
222
  (forall x. (Typeable x) => Int -> Args (m (Regs x)) -> Args (n (Regs x))) ->
223
  Cauldron m ->
224
  Cauldron n
225
hoistCauldron' f fds Cauldron {recipeMap} =
226
  Cauldron
227
    { recipeMap = Map.map (hoistSomeRecipe' f fds) recipeMap
228
    }
229
230
-- | In order to put recipes producing different bean types into a container, we
231
-- need to hide each recipe's bean type. This wrapper allows that.
232
type SomeRecipe :: (Type -> Type) -> Type
233
data SomeRecipe m where
234
  SomeRecipe :: (Typeable bean) => {_recipeCallStack :: CallStack, _recipe :: Recipe m bean} -> SomeRecipe m
235
236
-- | Build a 'SomeRecipe' from a 'Recipe' or a 'Constructor'. See 'ToRecipe'.
237
--
238
-- Useful in combination with 'fromRecipeList'.
239
recipe ::
240
  forall {recipelike} {m} bean.
241
  (ToRecipe recipelike, Typeable bean, HasCallStack) =>
242
  -- | A 'Recipe' or a 'Constructor'.
243
  recipelike m bean ->
244
  SomeRecipe m
245
recipe theRecipe = withFrozenCallStack do
246
  SomeRecipe callStack (toRecipe theRecipe)
247
248
-- | Access the 'Recipe' inside a 'SomeRecipe'.
249
withRecipe :: forall {m} r. (forall bean. (Typeable bean) => Recipe m bean -> r) -> SomeRecipe m -> r
250
withRecipe f (SomeRecipe {_recipe}) = f _recipe
251
252
getRecipeRep :: SomeRecipe m -> TypeRep
253
getRecipeRep = withRecipe go
254
  where
255
    go :: forall bean m. (Typeable bean) => Recipe m bean -> TypeRep
256
    go _ = typeRep (Proxy @bean)
257
258
fromRecipeList :: [SomeRecipe m] -> Cauldron m
259
fromRecipeList =
260
  foldMap \sr -> Cauldron {recipeMap = Map.singleton (getRecipeRep sr) sr}
261
262
toRecipeMap :: Cauldron m -> Map TypeRep (SomeRecipe m)
263
toRecipeMap Cauldron {recipeMap} = recipeMap
264
265
hoistSomeRecipe :: (forall x. m x -> n x) -> SomeRecipe m -> SomeRecipe n
266
hoistSomeRecipe f r@SomeRecipe {_recipe} = r {_recipe = hoistRecipe f _recipe}
267
268
hoistSomeRecipe' ::
269
  forall m n.
270
  (forall x. (Typeable x) => Args (m (Regs x)) -> Args (n (Regs x))) ->
271
  (forall x. (Typeable x) => Int -> Args (m (Regs x)) -> Args (n (Regs x))) ->
272
  SomeRecipe m ->
273
  SomeRecipe n
274
hoistSomeRecipe' f fds sr = withRecipe go sr
275
  where
276
    go :: forall bean. (Typeable bean) => Recipe m bean -> SomeRecipe n
277
    go r = sr {_recipe = hoistRecipe' (f @bean) (fds @bean) r}
278
279
-- | Instructions for how to build a value of type @bean@ while possibly
280
-- performing actions in the monad @m@.
281
--
282
-- Because the instructions aren't really run until the 'Cauldron' is 'cook'ed,
283
-- they can be modified with functions like 'adjust', in order to change the
284
-- base bean 'Constructor', or add or remove decorators.
285
type Recipe :: (Type -> Type) -> Type -> Type
286
data Recipe m bean = Recipe
287
  { -- | How to build the bean itself.
288
    bean :: Constructor m bean,
289
    -- | A 'Data.Sequence.Sequence' of decorators that will wrap the bean. There might be no decorators.
290
    --
291
    -- See 'fromDecoList', 'Data.Sequence.|>' and 'Data.Sequence.<|'.
292
    decos :: Seq (Constructor m bean)
293
  }
294
295
fromDecoList :: [Constructor m bean] -> Seq (Constructor m bean)
296
fromDecoList = Data.Sequence.fromList
297
298
-- | Convenience typeclass that allows passing either 'Recipe's or 'Constructor's
299
-- to the 'insert' and 'recipe' functions.
300
type ToRecipe :: ((Type -> Type) -> Type -> Type) -> Constraint
301
class ToRecipe recipelike where
302
  toRecipe :: recipelike m bean -> Recipe m bean
303
304
-- | Simply identity.
305
instance ToRecipe Recipe where
306
  toRecipe = id
307
308
-- | 'Constructor' is converted to a 'Recipe' without decorators.
309
instance ToRecipe Constructor where
310
  toRecipe bean = Recipe {bean, decos = Data.Sequence.empty}
311
312
-- | Change the monad used by the bean\'s main 'Constructor' and its decos.
313
hoistRecipe :: (forall x. m x -> n x) -> Recipe m bean -> Recipe n bean
314
hoistRecipe f (Recipe {bean, decos}) =
315
  Recipe
316
    { bean = hoistConstructor f bean,
317
      decos = hoistConstructor f <$> decos
318
    }
319
320
-- | More general form of 'hoistRecipe' that enables precise control over the inner `Args`
321
-- of each constructor in the 'Recipe'.
322
hoistRecipe' ::
323
  -- | Transformation to apply to the base constructor.
324
  (Args (m (Regs bean)) -> Args (n (Regs bean))) ->
325
  -- | Transformation to apply to each decorator. Takes the decorator index as parameter.
326
  (Int -> Args (m (Regs bean)) -> Args (n (Regs bean))) ->
327
  Recipe m bean ->
328
  Recipe n bean
329
hoistRecipe' f fds (Recipe {bean, decos}) =
330
  Recipe
331
    { bean = hoistConstructor' f bean,
332
      decos = Data.Sequence.mapWithIndex (\i deco -> hoistConstructor' (fds i) deco) decos
333
    }
334
335
-- $decos
336
--
337
-- Decorators are 'Constructor's which, instead constructing the original
338
-- version of a bean, they modify it in some way (but without changing its
339
-- type). Because they modify the bean, typically decorators will take the bean
340
-- as an argument.
341
--
342
-- Decorators can have other dependencies beyond the modified bean.
343
--
344
-- When the bean is a record-of-functions, decorators can be used to
345
-- add behaviors like caching and logging to the functions.
346
--
347
-- The order of the decorators in the sequence is the order in which they modify
348
-- the underlying bean. First decorator wraps first, last decorator wraps last.
349
--
350
-- >>> :{
351
-- newtype Foo = Foo { sayFoo :: IO () }
352
-- makeFoo :: Foo
353
-- makeFoo = Foo { sayFoo = putStrLn "foo" }
354
-- makeFooDeco1 :: Foo -> Foo
355
-- makeFooDeco1 Foo { sayFoo } = Foo { sayFoo = putStrLn "deco1 enter" >> sayFoo >> putStrLn "deco1 exit" }
356
-- makeFooDeco2 :: Foo -> IO Foo
357
-- makeFooDeco2 Foo { sayFoo } = putStrLn "deco2 init" >> pure Foo { sayFoo = putStrLn "deco2 enter" >> sayFoo >> putStrLn "deco2 exit" }
358
-- :}
359
--
360
-- >>> :{
361
-- do
362
--   let cauldron :: Cauldron IO
363
--       cauldron = [
364
--           recipe @Foo $ Recipe {
365
--             bean = val $ wire makeFoo,
366
--             decos = [
367
--                  val $ wire makeFooDeco1,
368
--                  eff $ wire makeFooDeco2
369
--               ]
370
--           }
371
--         ]
372
--   action <- either throwIO pure $ cook forbidDepCycles cauldron
373
--   beans <- action
374
--   let Just Foo {sayFoo} = taste beans
375
--   sayFoo
376
-- :}
377
-- deco2 init
378
-- deco2 enter
379
-- deco1 enter
380
-- foo
381
-- deco1 exit
382
-- deco2 exit
383
384
-- $constructors
385
--
386
-- Bean-producing and bean-decorating functions need to be coaxed into 'Constructor's in order to be used in 'Cauldron's.
387
388
data ConstructorReps where
389
  ConstructorReps ::
390
    { beanRep :: TypeRep,
391
      argReps :: Set TypeRep,
392
      regReps :: Map TypeRep Dynamic
393
    } ->
394
    ConstructorReps
395
396
-- | Put a 'Recipe' into the 'Cauldron'.
397
--
398
-- Only one recipe is allowed for each bean type, so 'insert' for a
399
-- bean will overwrite any previous recipe for that bean.
400
insert ::
401
  forall {recipelike} {m} (bean :: Type).
402
  (Typeable bean, ToRecipe recipelike, HasCallStack) =>
403
  -- | A 'Recipe' or a 'Constructor'.
404
  recipelike m bean ->
405
  Cauldron m ->
406
  Cauldron m
407
insert recipelike Cauldron {recipeMap} = withFrozenCallStack do
408
  let rep = typeRep (Proxy @bean)
409
  Cauldron {recipeMap = Map.insert rep (SomeRecipe callStack (toRecipe recipelike)) recipeMap}
410
411
-- | Tweak a 'Recipe' inside the 'Cauldron', if the recipe exists.
412
adjust ::
413
  forall {m} bean.
414
  (Typeable bean) =>
415
  (Recipe m bean -> Recipe m bean) ->
416
  Cauldron m ->
417
  Cauldron m
418
adjust f (Cauldron {recipeMap}) = withFrozenCallStack do
419
  let rep = typeRep (Proxy @bean)
420
  Cauldron
421
    { recipeMap =
422
        recipeMap
423
          & Map.adjust
424
            do
425
              \r@SomeRecipe {_recipe = _recipe :: Recipe m a} ->
426
                case testEquality (Type.Reflection.typeRep @bean) (Type.Reflection.typeRep @a) of
427
                  Nothing -> error "should never happen"
428
                  Just Refl -> r {_recipe = f _recipe}
429
            rep
430
    }
431
432
delete ::
433
  forall m.
434
  TypeRep ->
435
  Cauldron m ->
436
  Cauldron m
437
delete tr Cauldron {recipeMap} =
438
  Cauldron {recipeMap = Map.delete tr recipeMap}
439
440
-- | Strategy for dealing with dependency cycles.
441
--
442
-- (The name is admittedly uninformative; the culinary metaphor was stretched too far.)
443
data Fire m = Fire
444
  { shouldOmitDependency :: (BeanConstructionStep, BeanConstructionStep) -> Bool,
445
    followPlanCauldron ::
446
      Cauldron m ->
447
      Set TypeRep ->
448
      Beans ->
449
      Plan ->
450
      m Beans
451
  }
452
453
removeBeanFromArgs :: ConstructorReps -> ConstructorReps
454
removeBeanFromArgs ConstructorReps {argReps, regReps, beanRep} =
455
  ConstructorReps {argReps = Set.delete beanRep argReps, regReps, beanRep}
456
457
-- | Forbid any kind of cyclic dependencies between beans. This is probably what you want.
458
forbidDepCycles :: (Monad m) => Fire m
459
forbidDepCycles =
460
  Fire
461
    { shouldOmitDependency = \_ -> False,
462
      followPlanCauldron = \cauldron _secondaryBeanReps initial plan ->
463
        Data.Foldable.foldlM
464
          do followPlanStep (\_ -> id) (\_ -> id) cauldron mempty
465
          initial
466
          plan
467
    }
468
469
-- | Allow /direct/ self-dependencies.
470
--
471
-- A bean constructor might depend on itself. This can be useful for having
472
-- decorated self-invocations, because the version of the bean received as
473
-- argument comes \"from the future\" and is already decorated.
474
--
475
-- Note that a 'MonadFix' instance is required of the initialization monad.
476
--
477
-- __BEWARE__: Pattern-matching too eagerly on a \"bean from the future\" during
478
-- construction will cause infinite loops or, if you are lucky, throw
479
-- 'Control.Exception.FixIOException's.
480
allowSelfDeps :: (MonadFix m) => Fire m
481
allowSelfDeps =
482
  Fire
483
    { shouldOmitDependency = \case
484
        (BarePrimaryBean bean, PrimaryBean anotherBean) | bean == anotherBean -> True
485
        _ -> False,
486
      followPlanCauldron = \cauldron _secondaryBeanReps initial plan ->
487
        mfix do
488
          \final ->
489
            Data.Foldable.foldlM
490
              do followPlanStep Cauldron.Beans.delete (\_ -> id) cauldron final
491
              initial
492
              plan
493
    }
494
495
-- | Allow /any/ kind of dependency cycles.
496
--
497
-- Usually comes in handy for creating serializers / deserializers for mutually
498
-- dependent types.
499
--
500
-- Note that a 'MonadFix' instance is required of the initialization monad.
501
--
502
-- __BEWARE__: Pattern-matching too eagerly on argument beans during
503
-- construction will cause infinite loops or, if you are lucky, throw
504
-- 'Control.Exception.FixIOException's.
505
allowDepCycles :: (MonadFix m) => Fire m
506
allowDepCycles =
507
  Fire
508
    { shouldOmitDependency = \case
509
        (BarePrimaryBean _, PrimaryBean _) -> True
510
        (PrimaryBeanDeco _ _, PrimaryBean _) -> True
511
        _ -> False,
512
      followPlanCauldron = \cauldron secondaryBeanReps initial plan -> do
513
        let makeBareView _ = (`Cauldron.Beans.restrictKeys` secondaryBeanReps)
514
        let makeDecoView tr = (`Cauldron.Beans.restrictKeys` (Set.insert tr secondaryBeanReps))
515
        mfix do
516
          \final ->
517
            Data.Foldable.foldlM
518
              do followPlanStep makeBareView makeDecoView cauldron final
519
              initial
520
              plan
521
    }
522
523
-- https://discord.com/channels/280033776820813825/280036215477239809/1147832555828162594
524
-- https://github.com/ghc-proposals/ghc-proposals/pull/126#issuecomment-1363403330
525
526
-- | This function DOESN'T return the bean rep itself in the argreps.
527
constructorReps :: forall {m} bean. (Typeable bean) => Constructor m bean -> ConstructorReps
528
constructorReps (getConstructorArgs -> c) =
529
  ConstructorReps
530
    { beanRep = typeRep (Proxy @bean),
531
      argReps = getArgsReps c,
532
      regReps =
533
        c
534
          & getRegsReps
535
          & Set.map (\mtr@(SomeMonoidTypeRep tr) -> Data.Semigroup.Arg (Type.Reflection.SomeTypeRep tr) (toDyn (Cauldron.Beans.someMonoidTypeRepMempty mtr)))
536
          & Map.fromArgSet
537
    }
538
539
type Plan = [BeanConstructionStep]
540
541
-- | A step in the construction of a bean value.
542
data BeanConstructionStep
543
  = -- | Undecorated bean.
544
    BarePrimaryBean TypeRep
545
  | -- | Apply the decorator with the given index. Comes after the 'BarePrimaryBean' and all 'PrimaryBeanDeco's with a lower index value.
546
    PrimaryBeanDeco TypeRep Int
547
  | -- | Final, fully decorated version of a bean. If there are no decorators, comes directly after 'BarePrimaryBean'.
548
    PrimaryBean TypeRep
549
  | -- | Beans that are secondary registrations of a 'Constructor' and which are aggregated monoidally.
550
    SecondaryBean TypeRep
551
  deriving stock (Show, Eq, Ord)
552
553
-- | Build the beans using the recipeMap stored in the 'Cauldron'.
554
--
555
-- Any secondary beans that are registered by constructors are aggregated
556
-- monoidally.
557
cook ::
558
  forall m.
559
  (Monad m) =>
560
  Fire m ->
561
  Cauldron m ->
562
  Either RecipeError (m Beans)
563
cook fire cauldron =
564
  fmap @(Either RecipeError) (fmap @m rootLabel) $
565
    cookTree (Node (fire, cauldron) [])
566
567
-- | Cook a nonempty list of 'Cauldron's.
568
--
569
-- 'Cauldron's later in the list can see the beans in all previous 'Cauldron's,
570
-- but not vice versa.
571
--
572
-- Beans in a 'Cauldron' have priority over the same beans in previous 'Cauldron's.
573
cookNonEmpty ::
574
  forall m.
575
  (Monad m) =>
576
  NonEmpty (Fire m, Cauldron m) ->
577
  Either RecipeError (m (NonEmpty Beans))
578
cookNonEmpty nonemptyCauldronList = do
579
  fmap @(Either RecipeError) (fmap @m unsafeTreeToNonEmpty) $
580
    cookTree (nonEmptyToTree nonemptyCauldronList)
581
582
-- | Cook a hierarchy of 'Cauldron's.
583
--
584
-- 'Cauldron's down in the branches can see the beans of their ancestor
585
-- 'Cauldron's, but not vice versa.
586
--
587
-- Beans in a 'Cauldron' have priority over the same beans in ancestor 'Cauldron's.
588
cookTree ::
589
  forall m.
590
  (Monad m) =>
591
  Tree (Fire m, Cauldron m) ->
592
  Either RecipeError (m (Tree Beans))
593
cookTree (treecipes) = do
594
  accumMap <- first DoubleDutyBeansError do checkNoDoubleDutyBeans (snd <$> treecipes)
595
  () <- first MissingDependenciesError do checkMissingDeps (Map.keysSet accumMap) (snd <$> treecipes)
596
  treeplan <- first DependencyCycleError do buildPlans (Map.keysSet accumMap) treecipes
597
  Right $ followPlan (fromDynList (Data.Foldable.toList accumMap)) (treeplan)
598
599
newtype DoubleDutyBeans = DoubleDutyBeans (Map TypeRep (CallStack, CallStack))
600
  deriving stock (Show)
601
602
-- | Get a graph of dependencies between 'BeanConstructionStep's. The graph can
603
-- be obtained even if the 'Cauldron' can't be 'cook'ed successfully.
604
getDependencyGraph :: Cauldron m -> DependencyGraph
605
getDependencyGraph cauldron =
606
  let (accumMap, _) = cauldronRegs cauldron
607
      (_, deps) = buildDepsCauldron (Map.keysSet accumMap) cauldron
608
   in DependencyGraph {graph = Graph.edges deps}
609
610
checkNoDoubleDutyBeans ::
611
  Tree (Cauldron m) ->
612
  Either DoubleDutyBeans (Map TypeRep Dynamic)
613
checkNoDoubleDutyBeans treecipes = do
614
  let (accumMap, beanSet) = cauldronTreeRegs treecipes
615
  let common = Map.intersectionWith (,) (fst <$> accumMap) beanSet
616
  if not (Map.null common)
617
    then Left $ DoubleDutyBeans common
618
    else Right $ snd <$> accumMap
619
620
cauldronTreeRegs :: Tree (Cauldron m) -> (Map TypeRep (CallStack, Dynamic), Map TypeRep CallStack)
621
cauldronTreeRegs = foldMap cauldronRegs
622
623
cauldronRegs :: Cauldron m -> (Map TypeRep (CallStack, Dynamic), Map TypeRep CallStack)
624
cauldronRegs Cauldron {recipeMap} =
625
  Map.foldMapWithKey
626
    do \rep aRecipe -> (recipeRegs aRecipe, Map.singleton rep (getRecipeCallStack aRecipe))
627
    recipeMap
628
629
-- | Returns the accumulators, not the main bean
630
recipeRegs :: SomeRecipe m -> Map TypeRep (CallStack, Dynamic)
631
recipeRegs (SomeRecipe _ (Recipe {bean, decos})) = do
632
  let extractRegReps c = (getConstructorCallStack c,) <$> (\ConstructorReps {regReps} -> regReps) (constructorReps c)
633
  extractRegReps bean
634
    <> foldMap extractRegReps decos
635
636
data MissingDependencies = MissingDependencies CallStack TypeRep (Set TypeRep)
637
  deriving stock (Show)
638
639
checkMissingDeps ::
640
  -- | accums
641
  Set TypeRep ->
642
  Tree (Cauldron m) ->
643
  Either MissingDependencies ()
644
checkMissingDeps accums treecipes = do
645
  let decoratedTreecipes = decorate (Map.empty, treecipes)
646
      missing =
647
        decoratedTreecipes <&> \(available, requested) ->
648
          do checkMissingDepsCauldron accums (Map.keysSet available) requested
649
  sequence_ missing
650
  where
651
    decorate ::
652
      (Map TypeRep (SomeRecipe m), Tree (Cauldron m)) ->
653
      Tree (Map TypeRep (SomeRecipe m), Cauldron m)
654
    decorate = unfoldTree
655
      do
656
        \(acc, Node (current@Cauldron {recipeMap}) rest) ->
657
          let -- current level has priority
658
              newAcc = recipeMap `Map.union` acc
659
              newSeeds = do
660
                z <- rest
661
                [(newAcc, z)]
662
           in ((newAcc, current), newSeeds)
663
664
checkMissingDepsCauldron ::
665
  -- | accums
666
  Set TypeRep ->
667
  -- | available at this level
668
  Set TypeRep ->
669
  Cauldron m ->
670
  Either MissingDependencies ()
671
checkMissingDepsCauldron accums available cauldron =
672
  Data.Foldable.for_ (demandsByConstructorsInCauldron cauldron) \(stack, tr, demanded) ->
673
    let missing = Set.filter (`Set.notMember` (available `Set.union` accums)) demanded
674
     in if Set.null missing
675
          then Right ()
676
          else Left $ MissingDependencies stack tr missing
677
678
demandsByConstructorsInCauldron :: Cauldron m -> [(CallStack, TypeRep, Set TypeRep)]
679
demandsByConstructorsInCauldron Cauldron {recipeMap} = do
680
  (tr, SomeRecipe _ (Recipe {bean, decos})) <- Map.toList recipeMap
681
  ( let ConstructorReps {argReps = beanArgReps} = constructorReps bean
682
     in [(getConstructorCallStack bean, tr, beanArgReps)]
683
    )
684
    ++ do
685
      decoCon <- Data.Foldable.toList decos
686
      let ConstructorReps {argReps = decoArgReps} = constructorReps decoCon
687
       in [(getConstructorCallStack decoCon, tr, decoArgReps)]
688
689
newtype DependencyCycle = DependencyCycle (NonEmpty (BeanConstructionStep, Maybe CallStack))
690
  deriving stock (Show)
691
692
buildPlans :: Set TypeRep -> Tree (Fire m, Cauldron m) -> Either DependencyCycle (Tree (Plan, Fire m, Cauldron m))
693
buildPlans secondary = traverse \(fire@Fire {shouldOmitDependency}, cauldron) -> do
694
  let (locations, deps) = buildDepsCauldron secondary cauldron
695
  -- We may omit some dependency edges to allow for cyclic dependencies.
696
  let graph = Graph.edges $ filter (not . shouldOmitDependency) deps
697
  case Graph.topSort graph of
698
    Left recipeCycle ->
699
      Left $ DependencyCycle $ recipeCycle <&> \step -> (step, Map.lookup step locations)
700
    Right (reverse -> plan) -> do
701
      Right (plan, fire, cauldron)
702
703
buildDepsCauldron :: Set TypeRep -> Cauldron m -> (Map BeanConstructionStep CallStack, [(BeanConstructionStep, BeanConstructionStep)])
704
buildDepsCauldron secondary Cauldron {recipeMap} = do
705
  -- Are we depending on a primary bean, or on a monoidally aggregated secondary bean?
706
  -- I wonder if we could make this more uniform, it's kind of annoying to have to make this decision here...
707
  let makeTargetStep :: TypeRep -> BeanConstructionStep
708
      makeTargetStep rep =
709
        if rep `Set.member` secondary
710
          then SecondaryBean rep
711
          else PrimaryBean rep
712
  recipeMap
713
    & Map.foldMapWithKey
714
      \beanRep
715
       SomeRecipe
716
         { _recipeCallStack,
717
           _recipe =
718
             Recipe
719
               { bean = bean :: Constructor m bean,
720
                 decos
721
               }
722
         } ->
723
          do
724
            let bareBean = BarePrimaryBean beanRep
725
                boiledBean = PrimaryBean beanRep
726
                decoSteps = do
727
                  (decoIndex, decoCon) <- zip [0 :: Int ..] (Data.Foldable.toList decos)
728
                  [(PrimaryBeanDeco beanRep decoIndex, decoCon)]
729
                beanDeps = do
730
                  constructorEdges makeTargetStep bareBean (constructorReps bean)
731
                decoDeps = do
732
                  (decoStep, decoCon) <- decoSteps
733
                  -- We remove the bean because from the args becase, in the
734
                  -- case of decos, we want to depend on the in-the-making
735
                  -- version of the bean, not the completed bean.
736
                  constructorEdges makeTargetStep decoStep (removeBeanFromArgs do constructorReps decoCon)
737
                innerSteps = bareBean Data.List.NonEmpty.:| (fst <$> decoSteps) ++ [boiledBean]
738
                innerDeps =
739
                  -- This explicit dependency between the completed bean and its
740
                  -- "bare" undecorated form is not strictly required. It will
741
                  -- always exist in an indirect manner, through the decorators.
742
                  -- But it might be useful when rendering the dep graph.
743
                  (PrimaryBean beanRep, BarePrimaryBean beanRep)
744
                    :
745
                    -- The dep chain of completed bean -> decorators -> bare bean.
746
                    zip (Data.List.NonEmpty.tail innerSteps) (Data.List.NonEmpty.toList innerSteps)
747
            ( Map.fromList $
748
                [ (bareBean, getConstructorCallStack bean),
749
                  (boiledBean, _recipeCallStack)
750
                ]
751
                  ++ do
752
                    (decoStep, decoCon) <- decoSteps
753
                    [(decoStep, getConstructorCallStack decoCon)],
754
              beanDeps ++ decoDeps ++ innerDeps
755
              )
756
757
constructorEdges ::
758
  (TypeRep -> BeanConstructionStep) ->
759
  BeanConstructionStep ->
760
  ConstructorReps ->
761
  [(BeanConstructionStep, BeanConstructionStep)]
762
constructorEdges makeTargetStep item (ConstructorReps {argReps, regReps}) =
763
  -- consumers depend on their args
764
  ( do
765
      argRep <- Set.toList argReps
766
      let argStep = makeTargetStep argRep
767
      [(item, argStep)]
768
  )
769
    ++
770
    -- secondary beans depend on their producers
771
    ( do
772
        (regRep, _) <- Map.toList regReps
773
        let repStep = SecondaryBean regRep
774
        [(repStep, item)]
775
    )
776
777
followPlan ::
778
  (Monad m) =>
779
  Beans ->
780
  (Tree (Plan, Fire m, Cauldron m)) ->
781
  m (Tree Beans)
782
followPlan initialBeans treecipes =
783
  let secondaryBeanReps = Cauldron.Beans.keysSet initialBeans
784
   in unfoldTreeM
785
        ( \(previousStageBeans, Node (plan, Fire {followPlanCauldron}, cauldron) rest) -> do
786
            currentStageBeans <- followPlanCauldron cauldron secondaryBeanReps previousStageBeans plan
787
            pure (currentStageBeans, (,) currentStageBeans <$> rest)
788
        )
789
        (initialBeans, treecipes)
790
791
followPlanStep ::
792
  (Monad m) =>
793
  (TypeRep -> Beans -> Beans) ->
794
  (TypeRep -> Beans -> Beans) ->
795
  Cauldron m ->
796
  Beans ->
797
  Beans ->
798
  BeanConstructionStep ->
799
  m Beans
800
followPlanStep makeBareView makeDecoView Cauldron {recipeMap} final super item =
801
  case item of
802
    BarePrimaryBean rep -> case fromJust do Map.lookup rep recipeMap of
803
      SomeRecipe {_recipe = Recipe {bean}} -> do
804
        let ConstructorReps {beanRep} = constructorReps bean
805
        -- We delete the beanRep before running the bean,
806
        -- because if we have a self-dependency, we don't want to use the bean
807
        -- from a previous context (if it exists) we want the bean from final.
808
        -- There is a test for this.
809
        inserter <- followConstructor bean final (makeBareView beanRep super)
810
        pure do inserter super
811
    PrimaryBeanDeco rep index -> case fromJust do Map.lookup rep recipeMap of
812
      SomeRecipe {_recipe = Recipe {decos}} -> do
813
        let deco = decos `Data.Sequence.index` index
814
        let ConstructorReps {beanRep} = constructorReps deco
815
        -- Unlike before, we don't delete the beanRep before running the constructor.
816
        inserter <- followConstructor deco final (makeDecoView beanRep super)
817
        pure do inserter super
818
    -- \| We do nothing here, the work has been done in previous 'BarePrimaryBean' and
819
    -- 'PrimaryBeanDeco' steps.
820
    PrimaryBean {} -> pure super
821
    -- \| We do nothing here, secondary beans are built as a byproduct
822
    -- of primary beans and decorators.
823
    SecondaryBean {} -> pure super
824
825
-- | Build a bean out of already built beans.
826
-- This can only work without blowing up if there aren't dependecy cycles
827
-- and the order of construction respects the depedencies!
828
followConstructor ::
829
  (Monad m, Typeable bean) =>
830
  Constructor m bean ->
831
  Beans ->
832
  Beans ->
833
  m (Beans -> Beans)
834
followConstructor c final super = do
835
  (regs, bean) <- runConstructor [super, final] c
836
  pure \bs ->
837
    Cauldron.Beans.unionBeansMonoidally (getRegsReps (getConstructorArgs c)) bs regs
838
      & Cauldron.Beans.insert bean
839
840
-- | Sometimes the 'cook'ing process goes wrong.
841
data RecipeError
842
  = -- | A 'Constructor' depends on beans that can't be found either in the current 'Cauldron' or its ancestors.
843
    MissingDependenciesError MissingDependencies
844
  | -- | Beans that work both as primary beans and as secondary beans
845
    -- are disallowed.
846
    DoubleDutyBeansError DoubleDutyBeans
847
  | -- | Dependency cycles are disallowed by some 'Fire's.
848
    DependencyCycleError DependencyCycle
849
  deriving stock (Show)
850
851
instance Exception RecipeError where
852
  displayException = prettyRecipeError
853
854
prettyRecipeError :: RecipeError -> String
855
prettyRecipeError = Data.List.intercalate "\n" . prettyRecipeErrorLines
856
857
prettyRecipeErrorLines :: RecipeError -> [String]
858
prettyRecipeErrorLines = \case
859
  MissingDependenciesError
860
    (MissingDependencies constructorCallStack constructorResultRep missingDependenciesReps) ->
861
      [ "This constructor for a value of type "
862
          ++ show constructorResultRep
863
          ++ ":"
864
      ]
865
        ++ (("\t" ++) <$> prettyCallStackLines constructorCallStack)
866
        ++ [ "is missing the following dependencies:"
867
           ]
868
        ++ do
869
          rep <- Data.Foldable.toList missingDependenciesReps
870
          ["- " ++ show rep]
871
  DoubleDutyBeansError (DoubleDutyBeans doubleDutyMap) ->
872
    [ "The following beans work both as primary beans and secondary beans:"
873
    ]
874
      ++ ( flip Map.foldMapWithKey doubleDutyMap \rep (secCS, primCS) ->
875
             [ "- " ++ show rep ++ " is a secondary bean in this constructor:"
876
             ]
877
               ++ (("\t" ++) <$> prettyCallStackLines secCS)
878
               ++ [ "  and a primary bean in this recipe:"
879
                  ]
880
               ++ (("\t" ++) <$> prettyCallStackLines primCS)
881
         )
882
  DependencyCycleError (DependencyCycle theCycle) ->
883
    [ "Forbidden dependency cycle between bean construction steps:"
884
    ]
885
      ++ ( flip foldMap theCycle \(step, mstack) ->
886
             [ "- " ++ case step of
887
                 BarePrimaryBean rep -> "Bare bean " ++ show rep
888
                 PrimaryBeanDeco rep i -> "Decorator " ++ show i ++ " for bean " ++ show rep
889
                 PrimaryBean rep -> "Complete bean " ++ show rep
890
                 SecondaryBean rep -> "Secondary bean " ++ show rep
891
             ]
892
               ++ case mstack of
893
                 Nothing -> []
894
                 Just stack -> (("\t" ++) <$> prettyCallStackLines stack)
895
         )
896
897
-- | An edge means that the source depends on the target.
898
--
899
-- The dependencies of each bean are given separatedly from its decorators.
900
newtype DependencyGraph = DependencyGraph {graph :: AdjacencyMap BeanConstructionStep}
901
  deriving newtype (Show, Eq, Ord, Semigroup, Monoid)
902
903
-- | Conversion to a graph type
904
-- from the
905
-- [algebraic-graphs](https://hackage.haskell.org/package/algebraic-graphs-0.7/docs/Algebra-Graph-AdjacencyMap.html)
906
-- library for further processing.
907
toAdjacencyMap :: DependencyGraph -> AdjacencyMap BeanConstructionStep
908
toAdjacencyMap DependencyGraph {graph} = graph
909
910
-- | Remove all vertices and edges related to secondary beans.
911
removeSecondaryBeans :: DependencyGraph -> DependencyGraph
912
removeSecondaryBeans DependencyGraph {graph} =
913
  DependencyGraph {graph = Graph.induce (\case SecondaryBean {} -> False; _ -> True) graph}
914
915
-- | Remove all vertices and edges related to bean decorators.
916
removeDecos :: DependencyGraph -> DependencyGraph
917
removeDecos DependencyGraph {graph} =
918
  DependencyGraph {graph = Graph.induce (\case PrimaryBeanDeco {} -> False; _ -> True) graph}
919
920
-- | Unifies 'PrimaryBean's with their respective 'BarePrimaryBean's and 'PrimaryBeanDeco's.
921
--
922
-- Also removes any self-loops.
923
collapseToPrimaryBeans :: DependencyGraph -> DependencyGraph
924
collapseToPrimaryBeans DependencyGraph {graph} = do
925
  let simplified =
926
        Graph.gmap
927
          ( \case
928
              BarePrimaryBean rep -> PrimaryBean rep
929
              PrimaryBeanDeco rep _ -> PrimaryBean rep
930
              other -> other
931
          )
932
          graph
933
      -- Is there a simpler way to removoe self-loops?
934
      vertices = Graph.vertexList simplified
935
      edges = Graph.edgeList simplified
936
      edgesWithoutSelfLoops =
937
        filter
938
          ( \case
939
              (PrimaryBean source, PrimaryBean target) -> if source == target then False else True
940
              _ -> True
941
          )
942
          edges
943
  DependencyGraph {graph = Graph.vertices vertices `Graph.overlay` Graph.edges edgesWithoutSelfLoops}
944
945
-- | See the [DOT format](https://graphviz.org/doc/info/lang.html).
946
writeAsDot :: Dot.Style BeanConstructionStep Data.Text.Text -> FilePath -> DependencyGraph -> IO ()
947
writeAsDot style filepath DependencyGraph {graph} = do
948
  let dot = Dot.export style graph
949
  Data.ByteString.writeFile filepath (Data.Text.Encoding.encodeUtf8 dot)
950
951
-- | Default DOT rendering style to use with 'writeAsDot'.
952
-- When a 'RecipeError' exists, is highlights the problematic 'BeanConstructionStep's.
953
defaultStyle :: Maybe RecipeError -> Dot.Style BeanConstructionStep Data.Text.Text
954
defaultStyle merr =
955
  -- https://graphviz.org/docs/attr-types/style/
956
  -- https://hackage.haskell.org/package/algebraic-graphs-0.7/docs/Algebra-Graph-Export-Dot.html
957
  (Dot.defaultStyle defaultStepToText)
958
    { Dot.vertexAttributes = \step -> case merr of
959
        Nothing -> []
960
        Just (MissingDependenciesError (MissingDependencies _ _ missing)) ->
961
          case step of
962
            PrimaryBean rep
963
              | Set.member rep missing ->
964
                  [ Data.Text.pack "style" Dot.:= Data.Text.pack "dashed",
965
                    Data.Text.pack "color" Dot.:= Data.Text.pack "red"
966
                  ]
967
            _ -> []
968
        Just (DoubleDutyBeansError (DoubleDutyBeans (Map.keysSet -> bs))) ->
969
          case step of
970
            PrimaryBean rep
971
              | Set.member rep bs ->
972
                  [ Data.Text.pack "style" Dot.:= Data.Text.pack "bold",
973
                    Data.Text.pack "color" Dot.:= Data.Text.pack "green"
974
                  ]
975
            SecondaryBean rep
976
              | Set.member rep bs ->
977
                  [ Data.Text.pack "style" Dot.:= Data.Text.pack "bold",
978
                    Data.Text.pack "color" Dot.:= Data.Text.pack "green"
979
                  ]
980
            _ -> []
981
        Just (DependencyCycleError (DependencyCycle (Set.fromList . Data.Foldable.toList . fmap fst -> cycleStepSet))) ->
982
          if Set.member step cycleStepSet
983
            then
984
              [ Data.Text.pack "style" Dot.:= Data.Text.pack "bold",
985
                Data.Text.pack "color" Dot.:= Data.Text.pack "blue"
986
              ]
987
            else []
988
    }
989
990
-- | Change the default way of how 'BeanConstructionStep's are rendered to text.
991
setVertexName :: (BeanConstructionStep -> Data.Text.Text) -> Dot.Style BeanConstructionStep Data.Text.Text -> Dot.Style BeanConstructionStep Data.Text.Text
992
setVertexName vertexName style = style {Dot.vertexName}
993
994
defaultStepToText :: BeanConstructionStep -> Data.Text.Text
995
defaultStepToText =
996
  let p rep = Data.Text.pack do show rep
997
   in \case
998
        BarePrimaryBean rep -> p rep <> Data.Text.pack "#bare"
999
        PrimaryBeanDeco rep index -> p rep <> Data.Text.pack ("#deco#" ++ show index)
1000
        PrimaryBean rep -> p rep
1001
        SecondaryBean rep -> p rep <> Data.Text.pack "#agg"
1002
1003
nonEmptyToTree :: NonEmpty a -> Tree a
1004
nonEmptyToTree = \case
1005
  a Data.List.NonEmpty.:| [] -> Node a []
1006
  a Data.List.NonEmpty.:| (b : rest) -> Node a [nonEmptyToTree (b Data.List.NonEmpty.:| rest)]
1007
1008
unsafeTreeToNonEmpty :: Tree a -> NonEmpty a
1009
unsafeTreeToNonEmpty = \case
1010
  Node a [] -> a Data.List.NonEmpty.:| []
1011
  Node a [b] -> Data.List.NonEmpty.cons a (unsafeTreeToNonEmpty b)
1012
  _ -> error "tree not list-shaped"
1013
1014
-- | A way of building value of type @bean@, potentially requiring some
1015
-- dependencies, potentially returning some secondary beans
1016
-- along the primary @bean@ result, and also potentially requiring some
1017
-- initialization effect in a monad @m@.
1018
--
1019
-- Note that only the type of the primary @bean@ is reflected in the
1020
-- 'Constructor' type. Those of the dependencies and secondary beans are not.
1021
--
1022
-- A typical initialization monad will be 'IO', used for example to create
1023
-- mutable references that the bean will use internally. Sometimes the
1024
-- constructor will allocate resources with bracket-like operations, and in that
1025
-- case a monad like 'Cauldron.Managed.Managed' might be needed instead.
1026
data Constructor m bean = Constructor
1027
  { _constructorCallStack :: CallStack,
1028
    _args :: Args (m (Regs bean))
1029
  }
1030
1031
-- | Create a 'Constructor' from an 'Args' value that returns a 'bean'.
1032
--
1033
-- Usually, the 'Args' value will be created by 'wire'ing a constructor function.
1034
val_ :: forall bean m. (Applicative m, HasCallStack) => Args bean -> Constructor m bean
1035
val_ x = Constructor callStack $ fmap (pure . pure) x
1036
1037
-- | Like 'val_', but examines the @nested@ value returned by the 'Args' looking
1038
-- for (potentially nested) tuples.  All tuple components except the
1039
-- rightmost-innermost one are registered as secondary beans (if they have
1040
-- 'Monoid' instances, otherwise 'val' won't compile).
1041
val :: forall {nested} bean m. (Registrable nested bean, Applicative m, HasCallStack) => Args nested -> Constructor m bean
1042
val x = withFrozenCallStack (val' $ fmap runIdentity $ register $ fmap Identity x)
1043
1044
-- | Like 'val', but uses an alternative form of registering secondary beans.
1045
-- Less 'Registrable' typeclass magic, but more verbose. Likely not what you want.
1046
val' :: forall bean m. (Applicative m, HasCallStack) => Args (Regs bean) -> Constructor m bean
1047
val' x = Constructor callStack $ fmap pure x
1048
1049
-- | Create a 'Constructor' from an 'Args' value that returns an initialization
1050
-- effect that produces 'bean'.
1051
--
1052
-- Usually, the 'Args' value will be created by 'wire'ing an effectul constructor function.
1053
eff_ :: forall bean m. (Functor m, HasCallStack) => Args (m bean) -> Constructor m bean
1054
eff_ x = Constructor callStack $ fmap (fmap pure) x
1055
1056
-- | Like 'eff_', but lifts 'IO' constructor effects into a general 'MonadIO'.
1057
ioEff_ :: forall bean m. (MonadIO m, HasCallStack) => Args (IO bean) -> Constructor m bean
1058
ioEff_ args = withFrozenCallStack (hoistConstructor liftIO (eff_ args))
1059
1060
-- | Like 'eff_', but examines the @nested@ value produced by the action
1061
-- returned by the 'Args' looking for (potentially nested) tuples.  All tuple
1062
-- components except the rightmost-innermost one are registered as secondary
1063
-- beans (if they have 'Monoid' instances, otherwise 'eff' won't compile).
1064
eff :: forall {nested} bean m. (Registrable nested bean, Monad m, HasCallStack) => Args (m nested) -> Constructor m bean
1065
eff x = withFrozenCallStack (eff' $ register x)
1066
1067
-- | Like 'eff', but lifts 'IO' constructor effects into a general 'MonadIO'.
1068
ioEff :: forall {nested} bean m. (Registrable nested bean, MonadIO m, HasCallStack) => Args (IO nested) -> Constructor m bean
1069
ioEff args = withFrozenCallStack (hoistConstructor liftIO (eff args))
1070
1071
-- | Like 'eff', but uses an alternative form of registering secondary beans.
1072
-- Less 'Registrable' typeclass magic, but more verbose. Likely not what you want.
1073
eff' :: forall bean m. (HasCallStack) => Args (m (Regs bean)) -> Constructor m bean
1074
eff' = Constructor callStack
1075
1076
runConstructor :: (Monad m) => [Beans] -> Constructor m bean -> m (Beans, bean)
1077
runConstructor bss (Constructor {_args}) = do
1078
  regs <- _args & runArgs (Data.Foldable.asum (taste <$> bss))
1079
  pure (runRegs (getRegsReps _args) regs)
1080
1081
-- | Change the monad in which the 'Constructor'\'s effects take place.
1082
hoistConstructor :: (forall x. m x -> n x) -> Constructor m bean -> Constructor n bean
1083
hoistConstructor f c@Constructor {_args} = c {_args = fmap f _args}
1084
1085
-- | More general form of 'hoistConstructor' that enables precise control over the inner `Args`.
1086
hoistConstructor' :: (Args (m (Regs bean)) -> Args (n (Regs bean))) -> Constructor m bean -> Constructor n bean
1087
hoistConstructor' f c@Constructor {_args} = c {_args = f _args}
1088
1089
-- | Get the inner 'Args' value for the 'Constructor', typically for inspecting
1090
-- 'TypeRep's of its arguments/registrations.
1091
getConstructorArgs :: Constructor m bean -> Args (m (Regs bean))
1092
getConstructorArgs (Constructor {_args}) = _args
1093
1094
-- | For debugging purposes, 'Constructor's remember the 'CallStack'
1095
-- of when they were created.
1096
getConstructorCallStack :: Constructor m bean -> CallStack
1097
getConstructorCallStack (Constructor {_constructorCallStack}) = _constructorCallStack
1098
1099
-- | For debugging purposes, 'SomeRecipe's remember the 'CallStack'
1100
-- of when they were created.
1101
getRecipeCallStack :: SomeRecipe m -> CallStack
1102
getRecipeCallStack (SomeRecipe {_recipeCallStack}) = _recipeCallStack
1103
1104
-- | The set of all 'TypeRep' keys of the map.
1105
keysSet :: Cauldron m -> Set TypeRep
1106
keysSet Cauldron {recipeMap} = Map.keysSet recipeMap
1107
1108
-- | Restrict a 'Cauldron' to only those 'TypeRep's found in a 'Set'.
1109
restrictKeys :: Cauldron m -> Set TypeRep -> Cauldron m
1110
restrictKeys Cauldron {recipeMap} trs = Cauldron {recipeMap = Map.restrictKeys recipeMap trs}
1111
1112
-- $simplifygraph
1113
--
1114
-- 'DependencyGraph's can get complex and difficult to intepret because they
1115
-- include bean decorators and secondary beans, details in which we many not be
1116
-- interested.
1117
--
1118
-- These functions help simplify 'DependencyGraph's before passing them to
1119
-- 'writeAsDot'. They can be composed between themselves.
1120
1121
-- $secondarybeans
1122
--
1123
-- There is an exception to the 'Cauldron' rule that each bean type can only
1124
-- be produced by a single 'Recipe' in the 'Cauldron'.
1125
--
1126
-- 'Constructor's can produce, besides their \"primary\" bean result,
1127
-- \"secondary\" beans that are not reflected in the 'Constructor' signature.
1128
-- Multiple constructors across different 'Recipe's can produce secondary beans of the
1129
-- same type.
1130
--
1131
-- Secondary beans are a bit special, in that:
1132
--
1133
-- * The value that is \"seen"\ by a 'Constructor' that depends on a secondary bean
1134
--   is the aggregation of /all/ values produced for that bean in the 'Cauldron'. This
1135
--   means that secondary beans must have 'Monoid' instances, to enable aggregation.
1136
--
1137
-- * When calculating build plan steps for a 'Cauldron', 'Constructor's that depend on a
1138
--   secondary bean come after /all/ of the 'Constructor's that produce that secondary bean.
1139
--
1140
-- * Secondary beans can't be decorated.
1141
--
1142
-- * A bean type can't be primary and secondary at the same time. See 'DoubleDutyBeansError'.
1143
--
1144
-- What are secondary beans useful for?
1145
--
1146
-- * Exposing some uniform control or inspection interface for certain beans.
1147
--
1148
-- * Registering tasks or workers that must be run after application initialization.
1149
--
1150
-- The simplest way of registering secondary beans is to pass an 'Args' value returning a tuple
1151
-- to the 'val' (for pure constructors) or 'eff' (for effectful constructors) functions. Components
1152
-- of the tuple other than the rightmost component are considered secondary beans:
1153
--
1154
-- >>> :{
1155
-- con :: Constructor Identity String
1156
-- con = val $ pure (Sum @Int, All False, "foo")
1157
-- effCon :: Constructor IO String
1158
-- effCon = eff $ pure $ pure @IO (Sum @Int, All False, "foo")
1159
-- :}
1160
--
1161
-- Example of how secondary bean values are accumulated:
1162
--
1163
-- >>> :{
1164
-- data U = U deriving Show
1165
-- data V = V deriving Show
1166
-- makeU :: (Sum Int, U)
1167
-- makeU = (Sum 1, U)
1168
-- makeV :: U -> (Sum Int, V)
1169
-- makeV = \_ -> (Sum 7, V)
1170
-- newtype W = W (Sum Int) deriving Show -- depends on the secondary bean
1171
-- :}
1172
--
1173
-- >>> :{
1174
-- do
1175
--   let cauldron :: Cauldron Identity
1176
--       cauldron = [
1177
--           recipe @U $ val $ wire makeU,
1178
--           recipe @V $ val $ wire makeV,
1179
--           recipe @W $ val $ wire W
1180
--         ]
1181
--   Identity beans <- either throwIO pure $ cook forbidDepCycles cauldron
1182
--   pure $ taste @W beans
1183
-- :}
1184
-- Just (W (Sum {getSum = 8}))
1185
1186
-- $setup
1187
-- >>> :set -XBlockArguments
1188
-- >>> :set -XOverloadedLists
1189
-- >>> :set -Wno-incomplete-uni-patterns
1190
-- >>> import Data.Functor.Identity
1191
-- >>> import Data.Function ((&))
1192
-- >>> import Data.Monoid
1193
-- >>> import Data.Either (either)
1194
-- >>> import Control.Exception (throwIO)