@@ -1,46 +1,328 @@
1−-- @inline export makeLayer arity=1
21-- @inline export runLayer arity=2
3−module Yoga.Om.Layer
4− ( OmLayer(..)
2+module Yoga.Om.Layer
3+ ( OmLayer
4+ , ParOmLayer
5+ , Scope
56 , makeLayer
7+ , makeScopedLayer
8+ , bracketLayer
9+ , acquireRelease
10+ , fresh
611 , runLayer
12+ , runScoped
13+ , runScopedWith
14+ , withScoped
15+ , withScopedWith
16+ , scoped
717 , combineRequirements
18+ , withValue
819 , provide
920 , (>->)
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
1045 , class CheckAllProvided
1146 , class CheckAllLabelsExist
1247 , class CheckLabelExists
48+ , class TopoWire, topoWire
49+ , class AllLabelsIn
50+ , class FindReady
51+ , class FindReadyDispatch
1352 ) where
1453
1554import Prelude
1655
17−import Data.Newtype (class Newtype)
18−import Effect.Aff.Class (liftAff)
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)
69+import Data.Array as Array
70+import Data.Foldable (for_)
71+import Data.Map (Map)
72+import Data.Map as Map
73+import Data.Maybe (Maybe(..), maybe)
74+import Data.Nullable (Nullable, toMaybe)
75+import Data.Variant (class VariantMatchCases, onMatch)
76+import Effect (Effect)
77+import Effect.Aff (Aff, bracket)
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)
84+import Effect.Ref (Ref)
85+import Effect.Ref as Ref
86+import Effect.Unsafe (unsafePerformEffect)
1987import Prim.Row (class Nub, class Union)
88+import Prim.Row as Row
89+import Type.Proxy (Proxy(..))
2090import Prim.RowList (class RowToList, Cons, Nil, RowList)
21−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)
2296import Record as Record
2397import Record.Studio (class Keys)
2498import Type.Equality (class TypeEquals)
2599import Unsafe.Coerce (unsafeCoerce)
26−import Yoga.Om (Om)
100+import Yoga.Om (Om, ParOm)
27101import Yoga.Om as Om
102+import Yoga.Om.Error (Exception)
28103
29−-- | A layer that requires dependencies (req) and provides services (prov)
30−newtype OmLayer req prov err = OmLayer (Om (Record req) err (Record prov))
104+-- =============================================================================
105+-- Scope — a first-class representation of resource lifetime
106+-- =============================================================================
107+
108+-- | A first-class representation of resource lifetime and memoization.
109+-- | Finalizers are registered via `acquireRelease` and run in reverse order
110+-- | when the scope is closed. Layers are automatically memoized by identity
111+-- | within a scope — the same layer value builds only once.
112+newtype Scope = Scope
113+ { finalizers :: Ref (Array (Aff Unit))
114+ , cache :: Ref (Map Int Dynamic)
115+ }
116+
117+-- | Opaque box for cached values, retrieved via `unsafeCoerce`.
118+foreign import data Dynamic :: Type
119+
120+toDynamic :: forall a. a -> Dynamic
121+toDynamic = unsafeCoerce
122+
123+fromDynamic :: forall a. Dynamic -> a
124+fromDynamic = unsafeCoerce
125+
126+-- | Create a fresh, empty scope.
127+newScope :: Effect Scope
128+newScope = do
129+ finalizers <- Ref.new []
130+ cache <- Ref.new Map.empty
131+ pure (Scope { finalizers, cache })
132+
133+-- | Register a finalizer to run when this scope closes.
134+addFinalizer :: Scope -> Aff Unit -> Effect Unit
135+addFinalizer (Scope s) fin = Ref.modify_ (_ <> [ fin ]) s.finalizers
136+
137+-- | Close the scope, running all registered finalizers in reverse order.
138+closeScope :: Scope -> Aff Unit
139+closeScope (Scope s) = do
140+ fins <- liftEffect $ Ref.read s.finalizers
141+ for_ (Array.reverse fins) identity
142+
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+
156+-- =============================================================================
157+-- OmLayer
158+-- =============================================================================
159+
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+-- =============================================================================
31174
32−derive instance Newtype (OmLayer req prov err) _
175+instance Functor (OmLayer req err) where
176+ map f layer = OmLayer (freshId unit) (map f (buildLayer layer))
33177
34−-- | Helper to create a layer from an Om computation
35−makeLayer :: forall req prov err. Om (Record req) err (Record prov) -> OmLayer req prov err
36−makeLayer = OmLayer
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
262+
263+-- =============================================================================
264+-- Layer constructors
265+-- =============================================================================
266+
267+-- | Create a layer from an Om computation.
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
276+
277+-- | Create a scoped layer with acquire/release semantics.
278+-- | The release function runs when the enclosing scope closes.
279+-- | The layer requires `scope :: Scope` in its context.
280+makeScopedLayer
281+ :: forall req prov err
282+ . Om { scope :: Scope | req } err (Record prov)
283+ -> (Record prov -> Aff Unit)
284+ -> OmLayer (scope :: Scope | req) err (Record prov)
285+makeScopedLayer acquire release = makeLayer do
286+ acquireRelease acquire release
287+
288+-- | Bracket-style scoped layer: acquire a resource, register its release,
289+-- | then build provisions from it.
290+bracketLayer
291+ :: forall req prov resource err
292+ . Om { scope :: Scope | req } err resource
293+ -> (resource -> Aff Unit)
294+ -> (resource -> Om { scope :: Scope | req } err (Record prov))
295+ -> OmLayer (scope :: Scope | req) err (Record prov)
296+bracketLayer acquire release use = makeLayer do
297+ resource <- acquireRelease acquire (\r -> release r)
298+ use resource
299+
300+-- | Acquire a resource and register its release with the current scope.
301+-- | This is the core scoped resource primitive — the PureScript equivalent
302+-- | of ZIO's `ZIO.acquireRelease`.
303+acquireRelease
304+ :: forall ctx err a
305+ . Om { scope :: Scope | ctx } err a
306+ -> (a -> Aff Unit)
307+ -> Om { scope :: Scope | ctx } err a
308+acquireRelease acquire release = do
309+ a <- acquire
310+ { scope } <- Om.ask
311+ addFinalizer scope (release a) # liftEffect
312+ pure a
313+
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
37319
38320-- =============================================================================
39321-- Custom Type Errors for Missing Dependencies
40322-- =============================================================================
41323
42−-- | Check if all required dependencies are provided
43−-- If not, show a helpful diff of required vs available
324+-- | Check if all required dependencies are provided.
325+-- If not, show a helpful diff of required vs available.
44326class CheckAllProvided (required :: Row Type) (available :: Row Type)
45327
46328instance
@@ -50,157 +332,666 @@ instance
50332 ) =>
51333 CheckAllProvided required available
52334
53−-- | Check that all labels in required RowList exist in available RowList
54−-- Pass along the original rows for better error messages
335+-- | Check that all labels in required RowList exist in available RowList.
336+-- Pass along the original rows for better error messages.
55337class CheckAllLabelsExist (required :: RowList Type) (available :: RowList Type) (requiredRow :: Row Type) (availableRow :: Row Type)
56338
57−-- Base case: no more requirements to check
58339instance CheckAllLabelsExist Nil available requiredRow availableRow
59340
60−-- Recursive case: check if this label exists, then check the rest
61341instance
62342 ( CheckLabelExists label ty available requiredRow availableRow
63343 , CheckAllLabelsExist tail available requiredRow availableRow
64344 ) =>
65345 CheckAllLabelsExist (Cons label ty tail) available requiredRow availableRow
66346
67−-- | Check if a single label exists in the available RowList
68−-- This is where the magic happens - we dispatch on RowList structure in the instance head!
347+-- | Check if a single label exists in the available RowList.
69348class CheckLabelExists (label :: Symbol) (ty :: Type) (available :: RowList Type) (requiredRow :: Row Type) (availableRow :: Row Type)
70349
71−-- Found it! The label matches in the instance head
72−-- TypeEquals ensures the types at this label actually match!
73350instance
74351 TypeEquals ty ty' =>
75352 CheckLabelExists label ty (Cons label ty' tail) requiredRow availableRow
76353
77−-- Keep looking: different label, recurse on tail
78−else instance checkLabelExistsKeepLooking ::
354+else instance
79355 CheckLabelExists label ty tail requiredRow availableRow =>
80356 CheckLabelExists label ty (Cons otherLabel otherTy tail) requiredRow availableRow
81357
82−-- Not found: reached end of list, emit custom error WITH FULL CONTEXT!
83−else instance checkLabelExistsNotFound ::
358+else instance
84359 Fail
85360 ( Above
86361 (Text "Missing required dependency!")
87− (Above
88− (Text "")
89− (Above
90− (Text "The first missing field is: ")
91− (Above
92− (Quote label)
93− (Above
94− (Text "")
95− (Above
96− (Text "The layer requires: ")
97− (Above
98− (Quote requiredRow)
99− (Above
100− (Text "")
101− (Above
102− (Text "But you provided: ")
103− (Quote availableRow)
104− )
362+ ( Above
363+ (Text "")
364+ ( Above
365+ (Text "The first missing field is: ")
366+ ( Above
367+ (Quote label)
368+ ( Above
369+ (Text "")
370+ ( Above
371+ (Text "The layer requires: ")
372+ ( Above
373+ (Quote requiredRow)
374+ ( Above
375+ (Text "")
376+ ( Above
377+ (Text "But you provided: ")
378+ (Quote availableRow)
379+ )
380+ )
381+ )
382+ )
105383 )
106− )
107384 )
108− )
109385 )
110− )
111386 )
112387 ) =>
113388 CheckLabelExists label ty Nil requiredRow availableRow
114389
115−-- | Run a layer with a given context, with custom error if requirements aren't met
390+-- =============================================================================
391+-- Running layers
392+-- =============================================================================
393+
394+-- | 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.
116398runLayer
117− :: forall req prov err available
118− . CheckAllProvided req available -- ← Custom error if dependencies missing!
399+ :: forall req err a available
400+ . CheckAllProvided req available
401+ => Keys req
119402 => Record available
120− -> OmLayer req prov err
121− -> Om (Record available) err (Record prov)
122−runLayer _ctx layer = unsafeCastLayer layer
403+ -> OmLayer req err a
404+ -> Om (Record available) err a
405+runLayer _ctx layer = widenCtx (buildLayer layer)
406+ where
407+ widenCtx :: Om (Record req) err a -> Om (Record available) err a
408+ widenCtx = unsafeCoerce
409+
410+-- | Build a fully-provided scoped layer, return the provisions.
411+-- | All finalizers run after the provisions are returned.
412+-- | For layers with typed errors, use `runScopedWith`.
413+runScoped
414+ :: forall prov
415+ . OmLayer (scope :: Scope) () (Record prov)
416+ -> Aff (Record prov)
417+runScoped layer = withScoped layer pure
418+
419+-- | Build a fully-provided scoped layer and pass the provisions to a callback.
420+-- | A fresh `Scope` is created and closed when the callback completes,
421+-- | running all finalizers in reverse order — whether by success, failure,
422+-- | or interruption.
423+-- | For layers with typed errors, use `withScopedWith`.
424+withScoped
425+ :: forall prov a
426+ . OmLayer (scope :: Scope) () (Record prov)
427+ -> (Record prov -> Aff a)
428+ -> Aff a
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
123453 where
124− -- After CheckAllProvided succeeds, we know req ⊆ available at compile time
125− -- So this cast is safe - we're just telling the type system what it already proved
126− unsafeCastLayer :: OmLayer req prov err -> Om (Record available) err (Record prov)
127− unsafeCastLayer = unsafeCoerce
128−
129−-- | The key function: combine two layers with automatic deduplication
130−-- Given two layers with potentially overlapping requirements,
131−-- produce a layer with deduplicated requirements
132−--
133−-- Uses expand to properly widen contexts and errors, then runs both layers!
454+ acquire = do
455+ scope <- newScope # liftEffect
456+ let om = buildLayer layer
457+ prov <- Om.runOm { scope } handlers om
458+ pure { scope, prov }
459+ release { scope } = closeScope scope
460+ use { prov } = callback prov
461+
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+
473+-- =============================================================================
474+-- Horizontal composition — combine two layers with automatic deduplication
475+-- =============================================================================
476+
134477combineRequirements
135− :: forall req1 req2 prov1 prov2 err1 err2 provMerged provMergedRaw reqMerged reqDeduped _req1 _req2 _err1 _err2
478+ :: forall req1 req2 prov1 prov2 err1 err2 provMerged reqMerged reqDeduped errMerged errDeduped _req1 _req2 _err1 _err2
136479 . Union req1 req2 reqMerged
137− => Nub reqMerged reqDeduped -- ← Automatic deduplication of requirements!
138− => Union req1 _req1 reqDeduped -- req1 is subset of reqDeduped
139− => Union req2 _req2 reqDeduped -- req2 is subset of reqDeduped
140− => Union err1 _err1 () -- Widen errors to empty
141− => Union err2 _err2 ()
142− => Union prov1 prov2 provMergedRaw -- Merge provisions
143− => Nub provMergedRaw provMerged -- Deduplicate provisions too!
144− => Keys req1 -- Needed for expand
145− => Keys req2 -- Needed for expand
146− => OmLayer req1 prov1 err1
147− -> OmLayer req2 prov2 err2
148− -> OmLayer reqDeduped provMerged ()
149−combineRequirements (OmLayer build1) (OmLayer build2) = makeLayer do
150− -- Widen both contexts and errors to allow them to run in the deduplicated context
151− -- expand allows an Om computation to run in a larger context with larger error row
152− rec1 <- Om.expand build1 -- Om req1 err1 -> Om reqDeduped ()
153− rec2 <- Om.expand build2 -- Om req2 err2 -> Om reqDeduped ()
154− -- Merge the results (Record.merge handles the Nub)
480+ => Nub reqMerged reqDeduped
481+ => Union req1 _req1 reqDeduped
482+ => Union req2 _req2 reqDeduped
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
489+ => Keys req1
490+ => Keys req2
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)
155497 pure (Record.merge rec1 rec2)
156498
157−-- Example proof that this works:
158−-- If we have:
159−-- layer1 :: OmLayer (config :: Config) (logger :: Logger) ()
160−-- layer2 :: OmLayer (config :: Config) (database :: Database) ()
161−--
162−-- Then: combineRequirements layer1 layer2
163−-- Has type: OmLayer (config :: Config) prov3 err3
164−--
165−-- NOT: OmLayer (config :: Config, config :: Config) prov3 err3
166−--
167−-- The duplicated requirement (config, config) is automatically
168−-- deduplicated to just (config) by the Nub constraint!
169−
170−-- =============================================================================
171−-- Vertical Composition (ZLayer-style provide)
172−-- =============================================================================
173−
174−-- | Vertical composition: feed output of one layer into input of another
175−-- | This is the >>> operator from ZIO ZLayer
176−-- |
177−-- | Example:
178−-- | postgresLive :: OmLayer (config :: Config) (postgres :: SQL) ()
179−-- | userRepoLive :: OmLayer (postgres :: SQL) (userRepo :: UserRepo) ()
180−-- |
181−-- | composed = userRepoLive `provide` postgresLive
182−-- | -- Result: OmLayer (config :: Config) (userRepo :: UserRepo) ()
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+
510+-- =============================================================================
511+-- Vertical composition — feed output of one layer into input of another
512+-- =============================================================================
513+
183514provide
184− :: forall req prov1 prov2 err1 err2 _req _prov1 _err1 _err2
185− . Union req _req req -- expand constraints
515+ :: forall req prov1 prov2 err1 err2 req2 reqOut errMerged errDeduped _req _prov1 _err1 _err2
516+ . Union req _req req
186517 => Union prov1 _prov1 prov1
187− => Union err1 _err1 ()
188− => Union err2 _err2 ()
518+ => Union err1 err2 errMerged
519+ => Nub errMerged errDeduped
520+ => Union err1 _err1 errDeduped
521+ => Union err2 _err2 errDeduped
522+ => Union prov1 req reqOut
523+ => Nub reqOut reqOut
524+ => Union req2 _prov1 reqOut
189525 => Keys req
190526 => Keys prov1
191− => OmLayer prov1 prov2 err2 -- layer that needs prov1, provides prov2
192− -> OmLayer req prov1 err1 -- layer that needs req, provides prov1
193− -> OmLayer req prov2 () -- composed: needs req, provides prov2
194−provide (OmLayer layer2) (OmLayer layer1) = makeLayer do
195− -- Run first layer to get prov1
196− prov1 <- Om.expand layer1
197−
198− -- Run second layer with prov1 as context
199− liftAff $ Om.runOm prov1
200− { exception: \_ -> pure (unsafeCoerce {}) }
201− (Om.expand layer2)
527+ => Keys req2
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
202534
203535infixl 9 provide as >->
204536
205−-- TODO: More sophisticated composition operators
206−-- For now, use >>> for simple chains and combineRequirements for parallel deps
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