@@ -1,50 +1,105 @@
1−-- @inline export makeLayer arity=1
21-- @inline export runLayer arity=2
32module Yoga.Om.Layer
43 ( OmLayer
4+ , ParOmLayer
55 , Scope
66 , makeLayer
77 , makeScopedLayer
88 , bracketLayer
99 , acquireRelease
10− , memoized
10+ , fresh
1111 , runLayer
1212 , runScoped
13+ , runScopedWith
1314 , withScoped
15+ , withScopedWith
16+ , scoped
1417 , combineRequirements
18+ , withValue
1519 , provide
1620 , (>->)
17− , class CheckMemoKeys
18− , class CheckMemoKeysList
19− , class CheckKeyNotDuplicated
21+ , recovering
22+ , repeating
23+ , wireLayers
24+ , wireLayersDebug
25+ , class FilterScope
26+ , class FindProvider
27+ , class FindProviderMatch
28+ , class HasLabel
29+ , class EmitEdges
30+ , class DashesFor
31+ , class BoxTop, class BoxMid, class BoxBot
32+ , class RenderDepChildNode
33+ , class IsNotProvided
34+ , class HasDirectMissing, class HasDirectMissingOr
35+ , class FindLayerReqs
36+ , class RenderProviderDeps
37+ , class RenderDepTree
38+ , class FirstProvLabel
39+ , class PrintLayerDispatch
40+ , class PrintLayersRL
41+ , class PrintEdgesRL
42+ , class PrintLayersASCII
43+ , class PrintEdgesASCII
44+ , NotProvided
2045 , class CheckAllProvided
2146 , class CheckAllLabelsExist
2247 , class CheckLabelExists
48+ , class TopoWire, topoWire
49+ , class AllLabelsIn
50+ , class FindReady
51+ , class FindReadyDispatch
2352 ) where
2453
2554import Prelude
2655
56+import Control.Alt (class Alt)
57+import Control.Alt as Alt
58+import Control.Alternative (class Alternative)
59+import Control.Monad.Error.Class (class MonadError, class MonadThrow, catchError, throwError)
60+import Control.Monad.Reader (class MonadAsk, class MonadReader)
61+import Control.Monad.Reader as Reader
62+import Control.Monad.Rec.Class (class MonadRec, Step(..), tailRecM)
63+import Control.Parallel (class Parallel)
64+import Control.Parallel as Parallel
65+import Control.Plus (class Plus)
66+import Control.Plus as Plus
67+import Data.Symbol (class IsSymbol)
68+import Data.Variant (Variant)
2769import Data.Array as Array
2870import Data.Foldable (for_)
2971import Data.Map (Map)
3072import Data.Map as Map
31−import Data.Maybe (Maybe(..))
32−import Data.Symbol (class IsSymbol, reflectSymbol)
73+import Data.Maybe (Maybe(..), maybe)
74+import Data.Nullable (Nullable, toMaybe)
75+import Data.Variant (class VariantMatchCases, onMatch)
3376import Effect (Effect)
3477import Effect.Aff (Aff, bracket)
35−import Effect.Class (liftEffect)
78+import Effect.Aff.Retry (RetryPolicyM, RetryStatus, applyAndDelay, defaultRetryStatus)
79+import Effect.Aff.Class (class MonadAff)
80+import Effect.Aff.Class as Aff
81+import Effect.Class (class MonadEffect, liftEffect)
82+import Effect.Class (class MonadEffect, liftEffect) as Effect
83+import Effect.Exception (Error)
3684import Effect.Ref (Ref)
3785import Effect.Ref as Ref
86+import Effect.Unsafe (unsafePerformEffect)
3887import Prim.Row (class Nub, class Union)
88+import Prim.Row as Row
89+import Type.Proxy (Proxy(..))
3990import Prim.RowList (class RowToList, Cons, Nil, RowList)
40−import Prim.TypeError (class Fail, Above, Quote, Text)
91+import Prim.Boolean (True, False)
92+import Prim.Symbol (class Append, class Cons)
93+import Type.Data.Boolean (class And)
94+import Type.RowList (class RowListAppend)
95+import Prim.TypeError (class Fail, class Warn, Above, Beside, Doc, Quote, Text)
4196import Record as Record
4297import Record.Studio (class Keys)
4398import Type.Equality (class TypeEquals)
44−import Type.Proxy (Proxy(..))
4599import Unsafe.Coerce (unsafeCoerce)
46−import Yoga.Om (Om)
100+import Yoga.Om (Om, ParOm)
47101import Yoga.Om as Om
102+import Yoga.Om.Error (Exception)
48103
49104-- =============================================================================
50105-- Scope — a first-class representation of resource lifetime
@@ -52,10 +107,11 @@ import Yoga.Om as Om
52107
53108-- | A first-class representation of resource lifetime and memoization.
54109-- | Finalizers are registered via `acquireRelease` and run in reverse order
55−-- | when the scope is closed. Memoized layers share results via the cache.
110+-- | when the scope is closed. Layers are automatically memoized by identity
111+-- | within a scope — the same layer value builds only once.
56112newtype Scope = Scope
57113 { finalizers :: Ref (Array (Aff Unit))
58− , cache :: Ref (Map String Dynamic)
114+ , cache :: Ref (Map Int Dynamic)
59115 }
60116
61117-- | Opaque box for cached values, retrieved via `unsafeCoerce`.
@@ -84,21 +140,139 @@ closeScope (Scope s) = do
84140 fins <- liftEffect $ Ref.read s.finalizers
85141 for_ (Array.reverse fins) identity
86142
143+-- =============================================================================
144+-- Unique layer IDs
145+-- =============================================================================
146+
147+foreign import nextId :: Effect Int
148+foreign import tryGetScope :: forall r. Record r -> Nullable Scope
149+
150+-- | Generate a unique layer ID. Uses unsafePerformEffect since layer
151+-- | construction is at module init time (like Scala's `object` identity).
152+-- | This is a function (Unit -> Int) to ensure each call site gets a unique ID.
153+freshId :: Unit -> Int
154+freshId _ = unsafePerformEffect nextId
155+
87156-- =============================================================================
88157-- OmLayer
89158-- =============================================================================
90159
91−-- | A layer that requires dependencies (req), provides services (prov),
92−-- | and tracks memoization keys (memo) to prevent key collisions at compile time.
93−data OmLayer req prov err (memo :: Row Type) = OmLayer (Om (Record req) err (Record prov))
160+-- | A layer that requires dependencies (req), may fail with (err),
161+-- | and produces a value (typically Record prov).
162+-- | Each layer has a unique identity used for automatic memoization within a Scope.
163+data OmLayer req err a = OmLayer Int (Om (Record req) err a)
164+
165+-- =============================================================================
166+-- ParOmLayer — parallel counterpart
167+-- =============================================================================
168+
169+data ParOmLayer req err a = ParOmLayer (ParOm (Record req) err a)
170+
171+-- =============================================================================
172+-- Instances
173+-- =============================================================================
174+
175+instance Functor (OmLayer req err) where
176+ map f layer = OmLayer (freshId unit) (map f (buildLayer layer))
177+
178+instance Apply (OmLayer req err) where
179+ apply f a = OmLayer (freshId unit) (apply (buildLayer f) (buildLayer a))
180+
181+instance Applicative (OmLayer req err) where
182+ pure a = OmLayer (freshId unit) (pure a)
183+
184+instance Bind (OmLayer req err) where
185+ bind layer f = OmLayer (freshId unit) do
186+ a <- buildLayer layer
187+ buildLayer (f a)
188+
189+instance Monad (OmLayer req err)
190+
191+instance MonadEffect (OmLayer req err) where
192+ liftEffect eff = OmLayer (freshId unit) (Effect.liftEffect eff)
193+
194+instance MonadAff (OmLayer req err) where
195+ liftAff aff = OmLayer (freshId unit) (Aff.liftAff aff)
196+
197+instance MonadAsk (Record req) (OmLayer req err) where
198+ ask = OmLayer (freshId unit) Reader.ask
199+
200+instance MonadReader (Record req) (OmLayer req err) where
201+ local f layer = OmLayer (freshId unit) (Reader.local f (buildLayer layer))
202+
203+instance MonadThrow (Variant (Exception err)) (OmLayer req err) where
204+ throwError e = OmLayer (freshId unit) (throwError e)
205+
206+instance MonadError (Variant (Exception err)) (OmLayer req err) where
207+ catchError layer handler = OmLayer (freshId unit) (catchError (buildLayer layer) (\e -> buildLayer (handler e)))
208+
209+instance MonadRec (OmLayer req err) where
210+ tailRecM f a = OmLayer (freshId unit) (tailRecM (\x -> buildLayer (f x)) a)
211+
212+instance Semigroup a => Semigroup (OmLayer req err a) where
213+ append a b = OmLayer (freshId unit) (append (buildLayer a) (buildLayer b))
214+
215+instance Alt (OmLayer req err) where
216+ alt a b = OmLayer (freshId unit) (Alt.alt (buildLayer a) (buildLayer b))
217+
218+instance Plus (OmLayer req err) where
219+ empty = OmLayer (freshId unit) Plus.empty
220+
221+instance Functor (ParOmLayer req err) where
222+ map f (ParOmLayer p) = ParOmLayer (map f p)
223+
224+instance Apply (ParOmLayer req err) where
225+ apply (ParOmLayer f) (ParOmLayer a) = ParOmLayer (apply f a)
226+
227+instance Applicative (ParOmLayer req err) where
228+ pure a = ParOmLayer (pure a)
229+
230+instance Alt (ParOmLayer req err) where
231+ alt (ParOmLayer a) (ParOmLayer b) = ParOmLayer (Alt.alt a b)
232+
233+instance Plus (ParOmLayer req err) where
234+ empty = ParOmLayer Plus.empty
235+
236+instance Alternative (ParOmLayer req err)
237+
238+instance Parallel (ParOmLayer req err) (OmLayer req err) where
239+ parallel (OmLayer _ om) = ParOmLayer (Parallel.parallel om)
240+ sequential (ParOmLayer p) = OmLayer (freshId unit) (Parallel.sequential p)
241+
242+-- =============================================================================
243+-- Automatic memoization
244+-- =============================================================================
245+
246+-- | Wrap an Om computation with cache logic.
247+-- | If a scope is available in the context, checks/populates the cache by layer ID.
248+-- | If no scope is present, runs the computation directly.
249+withCache :: forall req err a. Int -> Om (Record req) err a -> Om (Record req) err a
250+withCache layerId om = do
251+ ctx <- Om.ask
252+ case toMaybe (tryGetScope ctx) of
253+ Nothing -> om
254+ Just (Scope s) -> do
255+ cached <- liftEffect $ Map.lookup layerId <$> Ref.read s.cache
256+ case cached of
257+ Just hit -> pure (fromDynamic hit)
258+ Nothing -> do
259+ prov <- om
260+ liftEffect $ Ref.modify_ (Map.insert layerId (toDynamic prov)) s.cache
261+ pure prov
94262
95263-- =============================================================================
96264-- Layer constructors
97265-- =============================================================================
98266
99267-- | Create a layer from an Om computation.
100−makeLayer :: forall req prov err. Om (Record req) err (Record prov) -> OmLayer req prov err ()
101−makeLayer = OmLayer
268+-- | The layer is automatically memoized within a Scope — the same layer value
269+-- | used in multiple branches of a dependency graph builds only once.
270+makeLayer :: forall req err a. Om (Record req) err a -> OmLayer req err a
271+makeLayer om = OmLayer (freshId unit) om
272+
273+-- | Extract the Om from a layer, wrapped with cache logic.
274+buildLayer :: forall req err a. OmLayer req err a -> Om (Record req) err a
275+buildLayer (OmLayer layerId om) = withCache layerId om
102276
103277-- | Create a scoped layer with acquire/release semantics.
104278-- | The release function runs when the enclosing scope closes.
@@ -107,7 +281,7 @@ makeScopedLayer
107281 :: forall req prov err
108282 . Om { scope :: Scope | req } err (Record prov)
109283 -> (Record prov -> Aff Unit)
110− -> OmLayer (scope :: Scope | req) prov err ()
284+ -> OmLayer (scope :: Scope | req) err (Record prov)
111285makeScopedLayer acquire release = makeLayer do
112286 acquireRelease acquire release
113287
@@ -118,7 +292,7 @@ bracketLayer
118292 . Om { scope :: Scope | req } err resource
119293 -> (resource -> Aff Unit)
120294 -> (resource -> Om { scope :: Scope | req } err (Record prov))
121− -> OmLayer (scope :: Scope | req) prov err ()
295+ -> OmLayer (scope :: Scope | req) err (Record prov)
122296bracketLayer acquire release use = makeLayer do
123297 resource <- acquireRelease acquire (\r -> release r)
124298 use resource
@@ -137,57 +311,11 @@ acquireRelease acquire release = do
137311 addFinalizer scope (release a) # liftEffect
138312 pure a
139313
140−-- | Memoize a layer by a compile-time symbol key.
141−-- | If the same key has already been built in this scope, the cached result
142−-- | is returned without re-running the layer.
143−memoized
144− :: forall sym req prov err memo
145− . IsSymbol sym
146− => Proxy sym
147− -> OmLayer (scope :: Scope | req) prov err memo
148− -> OmLayer (scope :: Scope | req) prov err (sym :: Record prov | memo)
149−memoized _ (OmLayer om) = OmLayer do
150− { scope: Scope s } <- Om.ask
151− let key = reflectSymbol (Proxy :: Proxy sym)
152− cached <- liftEffect $ Map.lookup key <$> Ref.read s.cache
153− case cached of
154− Just hit -> pure (fromDynamic hit)
155− Nothing -> do
156− prov <- om
157− liftEffect $ Ref.modify_ (Map.insert key (toDynamic prov)) s.cache
158− pure prov
159−
160−-- =============================================================================
161−-- Memo key safety — reject duplicate keys with different types
162−-- =============================================================================
163−
164−class CheckMemoKeys (row :: Row Type)
165−
166−instance (RowToList row rl, CheckMemoKeysList rl) => CheckMemoKeys row
167−
168−class CheckMemoKeysList (rl :: RowList Type)
169−
170−instance CheckMemoKeysList Nil
171−
172−instance
173− ( CheckMemoKeysList tail
174− , CheckKeyNotDuplicated label ty tail
175− ) =>
176− CheckMemoKeysList (Cons label ty tail)
177−
178−class CheckKeyNotDuplicated (label :: Symbol) (ty :: Type) (rest :: RowList Type)
179−
180−instance CheckKeyNotDuplicated label ty Nil
181−
182−instance
183− ( TypeEquals ty ty'
184− , CheckKeyNotDuplicated label ty tail
185− ) =>
186− CheckKeyNotDuplicated label ty (Cons label ty' tail)
187−
188−else instance
189− CheckKeyNotDuplicated label ty tail =>
190− CheckKeyNotDuplicated label ty (Cons otherLabel otherTy tail)
314+-- | Create a fresh (non-memoized) copy of a layer.
315+-- | The new layer has a unique identity and will always build independently,
316+-- | even within the same scope.
317+fresh :: forall req err a. OmLayer req err a -> OmLayer req err a
318+fresh (OmLayer _ om) = OmLayer (freshId unit) om
191319
192320-- =============================================================================
193321-- Custom Type Errors for Missing Dependencies
@@ -264,22 +392,27 @@ else instance
264392-- =============================================================================
265393
266394-- | Run a layer with a given context, with custom error if requirements aren't met.
395+-- | `runLayer` requires a closed requirement row. If you have an open layer like
396+-- | `OmLayer (db :: Db | r) err a`, specialize it to a closed row before running
397+-- | it directly.
267398runLayer
268− :: forall req prov err available memo
399+ :: forall req err a available
269400 . CheckAllProvided req available
401+ => Keys req
270402 => Record available
271− -> OmLayer req prov err memo
272− -> Om (Record available) err (Record prov)
273−runLayer _ctx (OmLayer om) = widenCtx om
403+ -> OmLayer req err a
404+ -> Om (Record available) err a
405+runLayer _ctx layer = widenCtx (buildLayer layer)
274406 where
275− widenCtx :: Om (Record req) err (Record prov) -> Om (Record available) err (Record prov)
407+ widenCtx :: Om (Record req) err a -> Om (Record available) err a
276408 widenCtx = unsafeCoerce
277409
278410-- | Build a fully-provided scoped layer, return the provisions.
279411-- | All finalizers run after the provisions are returned.
412+-- | For layers with typed errors, use `runScopedWith`.
280413runScoped
281− :: forall prov memo
282− . OmLayer (scope :: Scope) prov () memo
414+ :: forall prov
415+ . OmLayer (scope :: Scope) () (Record prov)
283416 -> Aff (Record prov)
284417runScoped layer = withScoped layer pure
285418
@@ -287,71 +420,578 @@ runScoped layer = withScoped layer pure
287420-- | A fresh `Scope` is created and closed when the callback completes,
288421-- | running all finalizers in reverse order — whether by success, failure,
289422-- | or interruption.
423+-- | For layers with typed errors, use `withScopedWith`.
290424withScoped
291− :: forall prov a memo
292− . OmLayer (scope :: Scope) prov () memo
425+ :: forall prov a
426+ . OmLayer (scope :: Scope) () (Record prov)
293427 -> (Record prov -> Aff a)
294428 -> Aff a
295−withScoped (OmLayer om) callback = bracket acquire release use
429+withScoped = withScopedWith { exception: throwError }
430+
431+-- | Like `runScoped` but accepts error handlers for layers with typed errors.
432+runScopedWith
433+ :: forall prov r rl err_ err
434+ . RowToList (exception :: Error -> Aff (Record prov) | r) rl
435+ => VariantMatchCases rl err_ (Aff (Record prov))
436+ => Union err_ () (exception :: Error | err)
437+ => { exception :: Error -> Aff (Record prov) | r }
438+ -> OmLayer (scope :: Scope) err (Record prov)
439+ -> Aff (Record prov)
440+runScopedWith handlers layer = withScopedWith handlers layer pure
441+
442+-- | Like `withScoped` but accepts error handlers for layers with typed errors.
443+withScopedWith
444+ :: forall prov a r rl err_ err
445+ . RowToList (exception :: Error -> Aff (Record prov) | r) rl
446+ => VariantMatchCases rl err_ (Aff (Record prov))
447+ => Union err_ () (exception :: Error | err)
448+ => { exception :: Error -> Aff (Record prov) | r }
449+ -> OmLayer (scope :: Scope) err (Record prov)
450+ -> (Record prov -> Aff a)
451+ -> Aff a
452+withScopedWith handlers layer callback = bracket acquire release use
296453 where
297454 acquire = do
298455 scope <- newScope # liftEffect
299− prov <- Om.runOm { scope } { exception: \_ -> pure (unsafeCoerce {}) } om
456+ let om = buildLayer layer
457+ prov <- Om.runOm { scope } handlers om
300458 pure { scope, prov }
301459 release { scope } = closeScope scope
302460 use { prov } = callback prov
303461
462+scoped
463+ :: forall prov a r rl err_ err
464+ . RowToList (exception :: Error -> Aff (Record prov) | r) rl
465+ => VariantMatchCases rl err_ (Aff (Record prov))
466+ => Union err_ () (exception :: Error | err)
467+ => { exception :: Error -> Aff (Record prov) | r }
468+ -> OmLayer (scope :: Scope) err (Record prov)
469+ -> (Record prov -> Aff a)
470+ -> Aff a
471+scoped = withScopedWith
472+
304473-- =============================================================================
305474-- Horizontal composition — combine two layers with automatic deduplication
306475-- =============================================================================
307476
308477combineRequirements
309− :: forall req1 req2 prov1 prov2 err1 err2 memo1 memo2 provMerged provMergedRaw reqMerged reqDeduped memoMerged memoDeduped _req1 _req2 _err1 _err2
478+ :: forall req1 req2 prov1 prov2 err1 err2 provMerged reqMerged reqDeduped errMerged errDeduped _req1 _req2 _err1 _err2
310479 . Union req1 req2 reqMerged
311480 => Nub reqMerged reqDeduped
312481 => Union req1 _req1 reqDeduped
313482 => Union req2 _req2 reqDeduped
314− => Union err1 _err1 ()
315− => Union err2 _err2 ()
316− => Union prov1 prov2 provMergedRaw
317− => Nub provMergedRaw provMerged
318− => Union memo1 memo2 memoMerged
319− => CheckMemoKeys memoMerged
320− => Nub memoMerged memoDeduped
483+ => Union err1 err2 errMerged
484+ => Nub errMerged errDeduped
485+ => Union err1 _err1 errDeduped
486+ => Union err2 _err2 errDeduped
487+ => Union prov1 prov2 provMerged
488+ => Nub provMerged provMerged
321489 => Keys req1
322490 => Keys req2
323− => OmLayer req1 prov1 err1 memo1
324− -> OmLayer req2 prov2 err2 memo2
325− -> OmLayer reqDeduped provMerged () memoDeduped
326−combineRequirements (OmLayer build1) (OmLayer build2) = OmLayer do
327− rec1 <- Om.expand build1
328− rec2 <- Om.expand build2
491+ => OmLayer req1 err1 (Record prov1)
492+ -> OmLayer req2 err2 (Record prov2)
493+ -> OmLayer reqDeduped errDeduped (Record provMerged)
494+combineRequirements layer1 layer2 = OmLayer (freshId unit) do
495+ rec1 <- Om.expand (buildLayer layer1)
496+ rec2 <- Om.expand (buildLayer layer2)
329497 pure (Record.merge rec1 rec2)
330498
499+withValue
500+ :: forall req err prov1 prov2 provMerged
501+ . Union prov1 prov2 provMerged
502+ => Nub provMerged provMerged
503+ => Record prov1
504+ -> OmLayer req err (Record prov2)
505+ -> OmLayer req err (Record provMerged)
506+withValue defaults layer = OmLayer (freshId unit) do
507+ rec <- buildLayer layer
508+ pure (Record.merge defaults rec)
509+
331510-- =============================================================================
332511-- Vertical composition — feed output of one layer into input of another
333512-- =============================================================================
334513
335514provide
336− :: forall req prov1 prov2 err1 err2 req2 reqOut memo1 memo2 memoMerged memoDeduped _req _prov1 _err1 _err2
515+ :: forall req prov1 prov2 err1 err2 req2 reqOut errMerged errDeduped _req _prov1 _err1 _err2
337516 . Union req _req req
338517 => Union prov1 _prov1 prov1
339− => Union err1 _err1 ()
340− => Union err2 _err2 ()
518+ => Union err1 err2 errMerged
519+ => Nub errMerged errDeduped
520+ => Union err1 _err1 errDeduped
521+ => Union err2 _err2 errDeduped
341522 => Union prov1 req reqOut
342523 => Nub reqOut reqOut
343524 => Union req2 _prov1 reqOut
344− => Union memo1 memo2 memoMerged
345− => CheckMemoKeys memoMerged
346− => Nub memoMerged memoDeduped
347525 => Keys req
348526 => Keys prov1
349527 => Keys req2
350− => OmLayer req2 prov2 err2 memo2
351− -> OmLayer req prov1 err1 memo1
352− -> OmLayer req prov2 () memoDeduped
353−provide (OmLayer layer2) (OmLayer layer1) = OmLayer do
354− prov1 <- Om.expand layer1
355− Om.expand layer2 # Om.widenCtx prov1
528+ => OmLayer req2 err2 (Record prov2)
529+ -> OmLayer req err1 (Record prov1)
530+ -> OmLayer req errDeduped (Record prov2)
531+provide l2 l1 = OmLayer (freshId unit) do
532+ prov1 <- Om.expand (buildLayer l1)
533+ Om.expand (buildLayer l2) # Om.widenCtx prov1
356534
357535infixl 9 provide as >->
536+
537+-- =============================================================================
538+-- Retry / Repeat on layers
539+-- =============================================================================
540+
541+recovering
542+ :: forall req err rest a
543+ (handlersRL :: RowList Type)
544+ (handlers :: Row Type)
545+ (handled :: Row Type)
546+ . RowToList handlers handlersRL
547+ => VariantMatchCases handlersRL handled (Om (Record req) err Boolean)
548+ => Union handled rest (exception :: Error | err)
549+ => RetryPolicyM (Om (Record req) err)
550+ -> (RetryStatus -> Record handlers)
551+ -> OmLayer req err a
552+ -> OmLayer req err a
553+recovering policy mkChecks (OmLayer layerId om) =
554+ OmLayer layerId (go defaultRetryStatus)
555+ where
556+ go status =
557+ catchError om (handleErr status)
558+
559+ handleErr status variant = do
560+ let shouldRetry = variant # onMatch (mkChecks status) (\_ -> pure false)
561+ ifM shouldRetry
562+ (applyAndDelay policy status >>= maybe (throwError variant) go)
563+ (throwError variant)
564+
565+repeating
566+ :: forall req err a
567+ . RetryPolicyM (Om (Record req) err)
568+ -> (RetryStatus -> a -> Om (Record req) err Boolean)
569+ -> OmLayer req err a
570+ -> OmLayer req err a
571+repeating policy shouldRepeat (OmLayer layerId om) =
572+ OmLayer layerId (go defaultRetryStatus)
573+ where
574+ go status = do
575+ result <- om
576+ ifM (shouldRepeat status result)
577+ (applyAndDelay policy status >>= maybe (pure result) go)
578+ (pure result)
579+
580+
581+-- =============================================================================
582+-- Topological auto-wiring (order-independent)
583+-- =============================================================================
584+
585+-- | Check if ALL labels in `needles` exist in `haystack`, returning a Boolean.
586+class AllLabelsIn (needles :: RowList Type) (haystack :: RowList Type) (result :: Boolean)
587+ | needles haystack -> result
588+
589+instance AllLabelsIn Nil haystack True
590+
591+instance
592+ ( HasLabel label haystack found
593+ , AllLabelsIn tail haystack tailResult
594+ , And found tailResult result
595+ ) =>
596+ AllLabelsIn (Cons label ty tail) haystack result
597+
598+-- | Dispatch based on whether a layer is ready (deps satisfied).
599+class FindReadyDispatch
600+ (ready :: Boolean)
601+ (sym :: Symbol)
602+ (layer :: Type)
603+ (tail :: RowList Type)
604+ (available :: RowList Type)
605+ (allLayersRL :: RowList Type)
606+ (foundSym :: Symbol)
607+ (foundLayer :: Type)
608+ (rest :: RowList Type)
609+ | ready sym layer tail available allLayersRL -> foundSym foundLayer rest
610+
611+instance FindReadyDispatch True sym layer tail available allLayersRL sym layer tail
612+
613+else instance
614+ FindReady tail available allLayersRL foundSym foundLayer rest' =>
615+ FindReadyDispatch False sym layer tail available allLayersRL foundSym foundLayer (Cons sym layer rest')
616+
617+-- | Scan candidates for the first layer whose requirements are satisfied.
618+class FindReady
619+ (candidates :: RowList Type)
620+ (available :: RowList Type)
621+ (allLayersRL :: RowList Type)
622+ (sym :: Symbol)
623+ (layer :: Type)
624+ (rest :: RowList Type)
625+ | candidates available allLayersRL -> sym layer rest
626+
627+instance
628+ ( PrintLayersASCII allLayersRL graphDoc
629+ , Fail
630+ ( Above (Text "")
631+ ( Above (Text "Dependency not provided!")
632+ ( Above (Text "")
633+ ( Above (Text "No remaining layer has all its dependencies satisfied.")
634+ ( Above (Text "")
635+ ( Above (Text "Dependency graph:") graphDoc
636+ )
637+ )
638+ )
639+ )
640+ )
641+ )
642+ ) =>
643+ FindReady Nil available allLayersRL sym layer rest
644+
645+else instance
646+ ( RowToList req reqRL
647+ , AllLabelsIn reqRL available isReady
648+ , FindReadyDispatch isReady sym (OmLayer req err (Record prov)) tail available allLayersRL foundSym foundLayer rest
649+ ) =>
650+ FindReady (Cons sym (OmLayer req err (Record prov)) tail) available allLayersRL foundSym foundLayer rest
651+
652+-- | Topologically sort and wire layers. Each iteration finds a layer whose
653+-- | dependencies are already satisfied, processes it, and adds its provisions.
654+class TopoWire
655+ (remaining :: RowList Type)
656+ (layers :: Row Type)
657+ (accReq :: Row Type)
658+ (accErr :: Row Type)
659+ (accProv :: Row Type)
660+ (resReq :: Row Type)
661+ (resErr :: Row Type)
662+ (resProv :: Row Type)
663+ | remaining layers accReq accErr accProv -> resReq resErr resProv
664+ where
665+ topoWire
666+ :: Proxy remaining
667+ -> Record layers
668+ -> OmLayer accReq accErr (Record accProv)
669+ -> OmLayer resReq resErr (Record resProv)
670+
671+instance TopoWire Nil layers accReq accErr accProv accReq accErr accProv where
672+ topoWire _ _ acc = acc
673+
674+else instance
675+ ( RowToList layers allLayersRL
676+ , RowToList accProv accProvRL
677+ , RowToList accReq accReqRL
678+ , RowListAppend accProvRL accReqRL availableRL
679+ , FindReady remaining availableRL allLayersRL readySym (OmLayer nextReq nextErr (Record nextProv)) rest
680+ , IsSymbol readySym
681+ , Row.Cons readySym (OmLayer nextReq nextErr (Record nextProv)) _rest layers
682+ -- next's requirements must be subset of (accProv + accReq)
683+ , Union accProv accReq provReqOut
684+ , Nub provReqOut provReqOut
685+ , Union nextReq _nextReqRest provReqOut
686+ , Keys nextReq
687+ , Keys accReq
688+ , Keys accProv
689+ -- merge errors
690+ , Union accErr nextErr errMergedRaw
691+ , Nub errMergedRaw errMerged
692+ , Union accErr _e1 errMerged
693+ , Union nextErr _e2 errMerged
694+ -- merge provisions
695+ , Union accProv nextProv provMerged
696+ , Nub provMerged provMerged
697+ -- recurse
698+ , TopoWire rest layers accReq errMerged provMerged resReq resErr resProv
699+ ) =>
700+ TopoWire remaining layers accReq accErr accProv resReq resErr resProv where
701+ topoWire _ layers acc =
702+ topoWire (Proxy :: Proxy rest) layers combined
703+ where
704+ next :: OmLayer nextReq nextErr (Record nextProv)
705+ next = Record.get (Proxy :: Proxy readySym) layers
706+
707+ combined :: OmLayer accReq errMerged (Record provMerged)
708+ combined = OmLayer (freshId unit) do
709+ accProv <- Om.expandErr (buildLayer acc)
710+ nextProv <- Om.expand (buildLayer next) # Om.widenCtx accProv
711+ pure (Record.merge accProv nextProv)
712+
713+wireLayers
714+ :: forall layers rl req err prov
715+ . RowToList layers rl
716+ => TopoWire rl layers (scope :: Scope) () () req err prov
717+ => Record layers
718+ -> OmLayer req err (Record prov)
719+wireLayers layers =
720+ topoWire (Proxy :: Proxy rl) layers seed
721+ where
722+ seed = pure {} :: OmLayer (scope :: Scope) () (Record ())
723+
724+-- =============================================================================
725+-- Debug graph printing (D2 diagram)
726+-- =============================================================================
727+
728+-- | Remove `scope :: Scope` from a RowList (it's always present, just noise).
729+class FilterScope (rl :: RowList Type) (out :: RowList Type) | rl -> out
730+
731+instance FilterScope Nil Nil
732+instance FilterScope (Cons "scope" Scope tail) tail
733+else instance FilterScope tail out => FilterScope (Cons sym ty tail) (Cons sym ty out)
734+
735+-- | Marker symbol for unresolved dependencies.
736+type NotProvided :: Symbol
737+type NotProvided = "???"
738+
739+-- | Given a label, find which layer in the RowList provides it.
740+class FindProvider (label :: Symbol) (rl :: RowList Type) (provider :: Symbol) | label rl -> provider
741+
742+instance FindProvider label Nil NotProvided
743+
744+else instance
745+ ( RowToList prov provRL
746+ , HasLabel label provRL hasIt
747+ , FindProviderMatch hasIt label sym (Cons sym (OmLayer req err (Record prov)) tail) provider
748+ ) =>
749+ FindProvider label (Cons sym (OmLayer req err (Record prov)) tail) provider
750+
751+-- | Dispatch based on whether the current layer has the label.
752+class FindProviderMatch (hasIt :: Boolean) (label :: Symbol) (sym :: Symbol) (rl :: RowList Type) (provider :: Symbol) | hasIt label sym rl -> provider
753+
754+instance FindProviderMatch True label sym rl sym
755+
756+else instance
757+ FindProvider label tail provider =>
758+ FindProviderMatch False label sym (Cons sym ty tail) provider
759+
760+-- | Check if a RowList contains a given label.
761+class HasLabel (label :: Symbol) (rl :: RowList Type) (result :: Boolean) | label rl -> result
762+
763+instance HasLabel label Nil False
764+instance HasLabel label (Cons label ty tail) True
765+else instance HasLabel label tail result => HasLabel label (Cons sym ty tail) result
766+
767+-- | Emit D2 edges for one consumer: "provider -> consumer" per requirement.
768+class EmitEdges (consumer :: Symbol) (reqRL :: RowList Type) (allLayers :: RowList Type) (doc :: Doc) | consumer reqRL allLayers -> doc
769+
770+instance EmitEdges consumer Nil allLayers (Text "")
771+
772+else instance
773+ ( FindProvider label allLayers provider
774+ , Append " " provider s0
775+ , Append s0 " --> " s1
776+ , Append s1 consumer line
777+ , EmitEdges consumer tail allLayers restDoc
778+ ) =>
779+ EmitEdges consumer (Cons label ty tail) allLayers (Above (Text line) restDoc)
780+
781+-- | Walk all layers emitting D2 edges (mermaid format for wireLayersDebug).
782+class PrintLayersRL (rl :: RowList Type) (doc :: Doc) | rl -> doc
783+class PrintEdgesRL (rl :: RowList Type) (allLayers :: RowList Type) (doc :: Doc) | rl allLayers -> doc
784+
785+instance PrintLayersRL Nil (Text "")
786+else instance PrintEdgesRL rl rl doc => PrintLayersRL rl doc
787+
788+instance PrintEdgesRL Nil allLayers (Text "")
789+
790+else instance
791+ ( RowToList req reqRL
792+ , FilterScope reqRL filteredReqRL
793+ , EmitEdges sym filteredReqRL allLayers edgeDoc
794+ , PrintEdgesRL tail allLayers restDoc
795+ ) =>
796+ PrintEdgesRL (Cons sym (OmLayer req err (Record prov)) tail) allLayers (Above edgeDoc restDoc)
797+
798+-- | Map a symbol to same-length dashes (for box borders).
799+class DashesFor (sym :: Symbol) (dashes :: Symbol) | sym -> dashes
800+
801+instance DashesFor "" ""
802+
803+else instance
804+ ( Cons head tail sym
805+ , DashesFor tail rest
806+ , Append "─" rest dashes
807+ ) =>
808+ DashesFor sym dashes
809+
810+-- | Build box parts from a symbol.
811+class BoxTop (sym :: Symbol) (result :: Symbol) | sym -> result
812+
813+instance
814+ ( DashesFor sym dashes
815+ , Append "╭─" dashes s0
816+ , Append s0 "─╮" result
817+ ) =>
818+ BoxTop sym result
819+
820+class BoxMid (sym :: Symbol) (result :: Symbol) | sym -> result
821+
822+instance
823+ ( Append "│ " sym s0
824+ , Append s0 " │" result
825+ ) =>
826+ BoxMid sym result
827+
828+class BoxBot (sym :: Symbol) (result :: Symbol) | sym -> result
829+
830+instance
831+ ( DashesFor sym dashes
832+ , Append "╰─" dashes s0
833+ , Append s0 "─╯" result
834+ ) =>
835+ BoxBot sym result
836+
837+-- | Render a single dependency child node (dispatches on provided vs missing).
838+class RenderDepChildNode
839+ (isNotProvided :: Boolean) (provider :: Symbol) (label :: Symbol) (ty :: Type)
840+ (prePrefix :: Symbol) (contPrefix :: Symbol) (branchPrefix :: Symbol)
841+ (allLayers :: RowList Type) (doc :: Doc)
842+ | isNotProvided provider label ty prePrefix contPrefix branchPrefix allLayers -> doc
843+
844+-- Missing dep: boxed label, type outside
845+instance
846+ ( BoxTop label topLine, BoxMid label midLine, BoxBot label botLine
847+ , Append prePrefix topLine topFull
848+ , Append branchPrefix midLine midFull
849+ , Append contPrefix botLine botFull
850+ ) =>
851+ RenderDepChildNode True provider label ty prePrefix contPrefix branchPrefix allLayers
852+ (Above (Text topFull) (Above (Beside (Text midFull) (Beside (Text " :: ") (Beside (Quote ty) (Text " <-- ⚠️ not provided")))) (Text botFull)))
853+
854+-- Provided dep: boxed label, then recurse into provider's sub-tree
855+instance
856+ ( BoxTop label topLine, BoxMid label midLine, BoxBot label botLine
857+ , Append prePrefix topLine topFull
858+ , Append branchPrefix midLine midFull
859+ , Append contPrefix botLine botFull
860+ , Append contPrefix " " subTreePrefix
861+ , RenderProviderDeps provider subTreePrefix allLayers subDoc
862+ ) =>
863+ RenderDepChildNode False provider label ty prePrefix contPrefix branchPrefix allLayers
864+ (Above (Text topFull) (Above (Text midFull) (Above (Text botFull) subDoc)))
865+
866+-- | Is this provider the NotProvided marker?
867+class IsNotProvided (provider :: Symbol) (result :: Boolean) | provider -> result
868+instance IsNotProvided NotProvided True
869+else instance IsNotProvided other False
870+
871+-- | Does any requirement in this RowList resolve to NotProvided?
872+class HasDirectMissing (reqRL :: RowList Type) (allLayers :: RowList Type) (result :: Boolean)
873+ | reqRL allLayers -> result
874+
875+instance HasDirectMissing Nil allLayers False
876+
877+else instance
878+ ( FindProvider label allLayers provider
879+ , IsNotProvided provider isMissing
880+ , HasDirectMissingOr isMissing tail allLayers result
881+ ) =>
882+ HasDirectMissing (Cons label ty tail) allLayers result
883+
884+class HasDirectMissingOr (found :: Boolean) (tail :: RowList Type) (allLayers :: RowList Type) (result :: Boolean)
885+ | found tail allLayers -> result
886+
887+instance HasDirectMissingOr True tail allLayers True
888+
889+else instance
890+ HasDirectMissing tail allLayers result =>
891+ HasDirectMissingOr False tail allLayers result
892+
893+-- | Look up a layer's requirements by name.
894+class FindLayerReqs (sym :: Symbol) (allLayers :: RowList Type) (reqRL :: RowList Type)
895+ | sym allLayers -> reqRL
896+
897+instance
898+ RowToList req reqRL =>
899+ FindLayerReqs sym (Cons sym (OmLayer req err (Record prov)) tail) reqRL
900+
901+else instance
902+ FindLayerReqs sym tail reqRL =>
903+ FindLayerReqs sym (Cons other otherLayer tail) reqRL
904+
905+-- | Render a provider's sub-tree (stops at NotProvided or roots).
906+class RenderProviderDeps
907+ (provider :: Symbol) (prefix :: Symbol) (allLayers :: RowList Type) (doc :: Doc)
908+ | provider prefix allLayers -> doc
909+
910+instance RenderProviderDeps NotProvided prefix allLayers (Text "")
911+
912+else instance
913+ ( FindLayerReqs provider allLayers reqRL
914+ , FilterScope reqRL filteredReqRL
915+ , RenderDepTree prefix filteredReqRL allLayers doc
916+ ) =>
917+ RenderProviderDeps provider prefix allLayers doc
918+
919+-- | Render a dependency tree with tree connectors.
920+class RenderDepTree
921+ (prefix :: Symbol) (reqRL :: RowList Type) (allLayers :: RowList Type) (doc :: Doc)
922+ | prefix reqRL allLayers -> doc
923+
924+instance RenderDepTree prefix Nil allLayers (Text "")
925+
926+-- Last child: └───
927+else instance
928+ ( FindProvider label allLayers provider
929+ , IsNotProvided provider isNP
930+ , Append prefix "│ " prePrefix
931+ , Append prefix " " contPrefix
932+ , Append prefix "└───" branchPrefix
933+ , RenderDepChildNode isNP provider label ty prePrefix contPrefix branchPrefix allLayers doc
934+ ) =>
935+ RenderDepTree prefix (Cons label ty Nil) allLayers doc
936+
937+-- Non-last child: ├───
938+else instance
939+ ( FindProvider label allLayers provider
940+ , IsNotProvided provider isNP
941+ , Append prefix "│ " contPrefix
942+ , Append prefix "├───" branchPrefix
943+ , RenderDepChildNode isNP provider label ty contPrefix contPrefix branchPrefix allLayers childDoc
944+ , RenderDepTree prefix tail allLayers restDoc
945+ ) =>
946+ RenderDepTree prefix (Cons label ty tail) allLayers (Above childDoc restDoc)
947+
948+-- | Extract the first label from a RowList.
949+class FirstProvLabel (rl :: RowList Type) (label :: Symbol) | rl -> label
950+instance FirstProvLabel (Cons label ty tail) label
951+
952+-- | Dispatch: skip layers without missing deps, render tree for others.
953+class PrintLayerDispatch
954+ (show :: Boolean) (displayName :: Symbol) (filteredReqRL :: RowList Type)
955+ (tail :: RowList Type) (allLayers :: RowList Type) (doc :: Doc)
956+ | show displayName filteredReqRL tail allLayers -> doc
957+
958+instance
959+ PrintEdgesASCII tail allLayers doc =>
960+ PrintLayerDispatch False displayName filteredReqRL tail allLayers doc
961+
962+else instance
963+ ( BoxTop displayName topLine, BoxMid displayName midLine, BoxBot displayName botLine
964+ , RenderDepTree " " filteredReqRL allLayers treeDoc
965+ , PrintEdgesASCII tail allLayers restDoc
966+ ) =>
967+ PrintLayerDispatch True displayName filteredReqRL tail allLayers
968+ (Above (Text topLine) (Above (Text midLine) (Above (Text botLine) (Above treeDoc (Above (Text "") restDoc)))))
969+
970+-- | Walk all layers emitting ASCII dependency trees (for error messages).
971+class PrintLayersASCII (rl :: RowList Type) (doc :: Doc) | rl -> doc
972+class PrintEdgesASCII (rl :: RowList Type) (allLayers :: RowList Type) (doc :: Doc) | rl allLayers -> doc
973+
974+instance PrintLayersASCII Nil (Text "")
975+else instance PrintEdgesASCII rl rl doc => PrintLayersASCII rl doc
976+
977+instance PrintEdgesASCII Nil allLayers (Text "")
978+
979+else instance
980+ ( RowToList req reqRL
981+ , FilterScope reqRL filteredReqRL
982+ , RowToList prov provRL
983+ , FirstProvLabel provRL displayName
984+ , HasDirectMissing filteredReqRL allLayers hasMissing
985+ , PrintLayerDispatch hasMissing displayName filteredReqRL tail allLayers doc
986+ ) =>
987+ PrintEdgesASCII (Cons sym (OmLayer req err (Record prov)) tail) allLayers doc
988+
989+wireLayersDebug
990+ :: forall layers rl req err prov doc
991+ . RowToList layers rl
992+ => PrintLayersRL rl doc
993+ => Warn (Above (Text "") (Above (Text "%%{init: {\"flowchart\": {\"defaultRenderer\": \"elk\"}} }%%") (Above (Text "flowchart LR") doc)))
994+ => TopoWire rl layers (scope :: Scope) () () req err prov
995+ => Record layers
996+ -> OmLayer req err (Record prov)
997+wireLayersDebug = wireLayers