@@ -1,206 +1,997 @@
1−-- @inline export makeLayer arity=1
2-- @inline export runLayer arity=2
1-- @inline export runLayer arity=2
3−module Yoga.Om.Layer
2+module Yoga.Om.Layer
4− ( OmLayer(..)
3+ ( OmLayer
5 , makeLayer
6 , makeLayer
6 , runLayer
11 , runLayer
7 , combineRequirements
17 , combineRequirements
27+ , class FindProviderMatch
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
42+ , class PrintLayersASCII
43+ , class PrintEdgesASCII
10 , class CheckAllProvided
45 , class CheckAllProvided
11 , class CheckAllLabelsExist
46 , class CheckAllLabelsExist
12 , class CheckLabelExists
47 , class CheckLabelExists
48+ , class TopoWire, topoWire
51+ , class FindReadyDispatch
15import Prelude
54import Prelude
17−import Data.Newtype (class Newtype)
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_)
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)
18−import Effect.Aff.Class (liftAff)
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)
19import Prim.Row (class Nub, class Union)
87import Prim.Row (class Nub, class Union)
88+import Prim.Row as Row
89+import Type.Proxy (Proxy(..))
20import Prim.RowList (class RowToList, Cons, Nil, RowList)
90import Prim.RowList (class RowToList, Cons, Nil, RowList)
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)
21−import Prim.TypeError (class Fail, Above, Quote, Text)
95+import Prim.TypeError (class Fail, class Warn, Above, Beside, Doc, Quote, Text)
22import Record as Record
96import Record as Record
23import Record.Studio (class Keys)
97import Record.Studio (class Keys)
24import Type.Equality (class TypeEquals)
98import Type.Equality (class TypeEquals)
25import Unsafe.Coerce (unsafeCoerce)
99import Unsafe.Coerce (unsafeCoerce)
26−import Yoga.Om (Om)
100+import Yoga.Om (Om, ParOm)
27import Yoga.Om as Om
101import Yoga.Om as Om
102+import Yoga.Om.Error (Exception)
104+-- =============================================================================
105+-- Scope — a first-class representation of resource lifetime
106+-- =============================================================================
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)
117+-- | Opaque box for cached values, retrieved via `unsafeCoerce`.
118+foreign import data Dynamic :: Type
120+toDynamic :: forall a. a -> Dynamic
121+toDynamic = unsafeCoerce
123+fromDynamic :: forall a. Dynamic -> a
124+fromDynamic = unsafeCoerce
126+-- | Create a fresh, empty scope.
127+newScope :: Effect Scope
129+ finalizers <- Ref.new []
130+ cache <- Ref.new Map.empty
131+ pure (Scope { finalizers, cache })
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
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
143+-- =============================================================================
145+-- =============================================================================
147+foreign import nextId :: Effect Int
148+foreign import tryGetScope :: forall r. Record r -> Nullable Scope
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
156+-- =============================================================================
158+-- =============================================================================
29−-- | A layer that requires dependencies (req) and provides services (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.
30−newtype OmLayer req prov err = OmLayer (Om (Record req) err (Record prov))
163+data OmLayer req err a = OmLayer Int (Om (Record req) err a)
165+-- =============================================================================
166+-- ParOmLayer — parallel counterpart
167+-- =============================================================================
169+data ParOmLayer req err a = ParOmLayer (ParOm (Record req) err a)
171+-- =============================================================================
173+-- =============================================================================
175+instance Functor (OmLayer req err) where
176+ map f layer = OmLayer (freshId unit) (map f (buildLayer layer))
178+instance Apply (OmLayer req err) where
179+ apply f a = OmLayer (freshId unit) (apply (buildLayer f) (buildLayer a))
181+instance Applicative (OmLayer req err) where
182+ pure a = OmLayer (freshId unit) (pure a)
184+instance Bind (OmLayer req err) where
185+ bind layer f = OmLayer (freshId unit) do
186+ a <- buildLayer layer
189+instance Monad (OmLayer req err)
191+instance MonadEffect (OmLayer req err) where
192+ liftEffect eff = OmLayer (freshId unit) (Effect.liftEffect eff)
194+instance MonadAff (OmLayer req err) where
195+ liftAff aff = OmLayer (freshId unit) (Aff.liftAff aff)
197+instance MonadAsk (Record req) (OmLayer req err) where
198+ ask = OmLayer (freshId unit) Reader.ask
200+instance MonadReader (Record req) (OmLayer req err) where
201+ local f layer = OmLayer (freshId unit) (Reader.local f (buildLayer layer))
203+instance MonadThrow (Variant (Exception err)) (OmLayer req err) where
204+ throwError e = OmLayer (freshId unit) (throwError e)
206+instance MonadError (Variant (Exception err)) (OmLayer req err) where
207+ catchError layer handler = OmLayer (freshId unit) (catchError (buildLayer layer) (\e -> buildLayer (handler e)))
32−derive instance Newtype (OmLayer req prov err) _
209+instance MonadRec (OmLayer req err) where
210+ tailRecM f a = OmLayer (freshId unit) (tailRecM (\x -> buildLayer (f x)) a)
34−-- | Helper to create a layer from an Om computation
212+instance Semigroup a => Semigroup (OmLayer req err a) where
35−makeLayer :: forall req prov err. Om (Record req) err (Record prov) -> OmLayer req prov err
213+ append a b = OmLayer (freshId unit) (append (buildLayer a) (buildLayer b))
36−makeLayer = OmLayer
214+
215+instance Alt (OmLayer req err) where
216+ alt a b = OmLayer (freshId unit) (Alt.alt (buildLayer a) (buildLayer b))
218+instance Plus (OmLayer req err) where
219+ empty = OmLayer (freshId unit) Plus.empty
221+instance Functor (ParOmLayer req err) where
222+ map f (ParOmLayer p) = ParOmLayer (map f p)
224+instance Apply (ParOmLayer req err) where
225+ apply (ParOmLayer f) (ParOmLayer a) = ParOmLayer (apply f a)
227+instance Applicative (ParOmLayer req err) where
228+ pure a = ParOmLayer (pure a)
230+instance Alt (ParOmLayer req err) where
231+ alt (ParOmLayer a) (ParOmLayer b) = ParOmLayer (Alt.alt a b)
233+instance Plus (ParOmLayer req err) where
234+ empty = ParOmLayer Plus.empty
236+instance Alternative (ParOmLayer req err)
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)
242+-- =============================================================================
243+-- Automatic memoization
244+-- =============================================================================
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
252+ case toMaybe (tryGetScope ctx) of
254+ Just (Scope s) -> do
255+ cached <- liftEffect $ Map.lookup layerId <$> Ref.read s.cache
257+ Just hit -> pure (fromDynamic hit)
260+ liftEffect $ Ref.modify_ (Map.insert layerId (toDynamic prov)) s.cache
263+-- =============================================================================
264+-- Layer constructors
265+-- =============================================================================
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
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
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.
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
288+-- | Bracket-style scoped layer: acquire a resource, register its release,
289+-- | then build provisions from it.
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)
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`.
305+ . Om { scope :: Scope | ctx } err a
307+ -> Om { scope :: Scope | ctx } err a
308+acquireRelease acquire release = do
311+ addFinalizer scope (release a) # liftEffect
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
38-- =============================================================================
320-- =============================================================================
39-- Custom Type Errors for Missing Dependencies
321-- Custom Type Errors for Missing Dependencies
40-- =============================================================================
322-- =============================================================================
42−-- | Check if all required dependencies are provided
324+-- | Check if all required dependencies are provided.
43−-- If not, show a helpful diff of required vs available
325+-- If not, show a helpful diff of required vs available.
44class CheckAllProvided (required :: Row Type) (available :: Row Type)
326class CheckAllProvided (required :: Row Type) (available :: Row Type)
46−instance checkAllProvidedImpl ::
328+instance
47 ( RowToList required reqList
329 ( RowToList required reqList
48 , RowToList available availList
330 , RowToList available availList
49 , CheckAllLabelsExist reqList availList required available
331 , CheckAllLabelsExist reqList availList required available
51 CheckAllProvided required available
333 CheckAllProvided required available
53−-- | Check that all labels in required RowList exist in available RowList
335+-- | Check that all labels in required RowList exist in available RowList.
54−-- Pass along the original rows for better error messages
336+-- Pass along the original rows for better error messages.
55class CheckAllLabelsExist (required :: RowList Type) (available :: RowList Type) (requiredRow :: Row Type) (availableRow :: Row Type)
337class CheckAllLabelsExist (required :: RowList Type) (available :: RowList Type) (requiredRow :: Row Type) (availableRow :: Row Type)
57−-- Base case: no more requirements to check
58−instance checkAllLabelsNil :: CheckAllLabelsExist Nil available requiredRow availableRow
339+instance CheckAllLabelsExist Nil available requiredRow availableRow
60−-- Recursive case: check if this label exists, then check the rest
61−instance checkAllLabelsCons ::
341+instance
62 ( CheckLabelExists label ty available requiredRow availableRow
342 ( CheckLabelExists label ty available requiredRow availableRow
63 , CheckAllLabelsExist tail available requiredRow availableRow
343 , CheckAllLabelsExist tail available requiredRow availableRow
65 CheckAllLabelsExist (Cons label ty tail) available requiredRow availableRow
345 CheckAllLabelsExist (Cons label ty tail) available requiredRow availableRow
67−-- | Check if a single label exists in the available RowList
347+-- | 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!
69class CheckLabelExists (label :: Symbol) (ty :: Type) (available :: RowList Type) (requiredRow :: Row Type) (availableRow :: Row Type)
348class CheckLabelExists (label :: Symbol) (ty :: Type) (available :: RowList Type) (requiredRow :: Row Type) (availableRow :: Row Type)
71−-- Found it! The label matches in the instance head
72−-- TypeEquals ensures the types at this label actually match!
73−instance checkLabelExistsFound ::
350+instance
74 TypeEquals ty ty' =>
351 TypeEquals ty ty' =>
75 CheckLabelExists label ty (Cons label ty' tail) requiredRow availableRow
352 CheckLabelExists label ty (Cons label ty' tail) requiredRow availableRow
77−-- Keep looking: different label, recurse on tail
78−else instance checkLabelExistsKeepLooking ::
354+else instance
79 CheckLabelExists label ty tail requiredRow availableRow =>
355 CheckLabelExists label ty tail requiredRow availableRow =>
80 CheckLabelExists label ty (Cons otherLabel otherTy tail) requiredRow availableRow
356 CheckLabelExists label ty (Cons otherLabel otherTy tail) requiredRow availableRow
82−-- Not found: reached end of list, emit custom error WITH FULL CONTEXT!
83−else instance checkLabelExistsNotFound ::
358+else instance
86 (Text "Missing required dependency!")
361 (Text "Missing required dependency!")
88− (Text "")
363+ (Text "")
90− (Text "The first missing field is: ")
365+ (Text "The first missing field is: ")
92− (Quote label)
367+ (Quote label)
94− (Text "")
369+ (Text "")
96− (Text "The layer requires: ")
371+ (Text "The layer requires: ")
98− (Quote requiredRow)
373+ (Quote requiredRow)
100− (Text "")
375+ (Text "")
102− (Text "But you provided: ")
377+ (Text "But you provided: ")
103− (Quote availableRow)
378+ (Quote availableRow)
113 CheckLabelExists label ty Nil requiredRow availableRow
388 CheckLabelExists label ty Nil requiredRow availableRow
390+-- =============================================================================
392+-- =============================================================================
115−-- | Run a layer with a given context, with custom error if requirements aren't met
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
117− :: forall req prov err available
399+ :: forall req err a available
118− . CheckAllProvided req available -- ← Custom error if dependencies missing!
400+ . CheckAllProvided req available
119 => Record available
402 => Record available
120− -> OmLayer req prov err
403+ -> OmLayer req err a
121− -> Om (Record available) err (Record prov)
404+ -> Om (Record available) err a
122−runLayer _ctx layer = unsafeCastLayer layer
405+runLayer _ctx layer = widenCtx (buildLayer layer)
124− -- After CheckAllProvided succeeds, we know req ⊆ available at compile time
407+ widenCtx :: Om (Record req) err a -> Om (Record available) err a
125− -- So this cast is safe - we're just telling the type system what it already proved
408+ widenCtx = unsafeCoerce
126− unsafeCastLayer :: OmLayer req prov err -> Om (Record available) err (Record prov)
409+
127− unsafeCastLayer = unsafeCoerce
410+-- | Build a fully-provided scoped layer, return the provisions.
128−
411+-- | All finalizers run after the provisions are returned.
412+-- | For layers with typed errors, use `runScopedWith`.
415+ . OmLayer (scope :: Scope) () (Record prov)
416+ -> Aff (Record prov)
417+runScoped layer = withScoped layer pure
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`.
426+ . OmLayer (scope :: Scope) () (Record prov)
427+ -> (Record prov -> Aff a)
429+withScoped = withScopedWith { exception: throwError }
431+-- | Like `runScoped` but accepts error handlers for layers with typed errors.
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
442+-- | Like `withScoped` but accepts error handlers for layers with typed errors.
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)
452+withScopedWith handlers layer callback = bracket acquire release use
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
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)
471+scoped = withScopedWith
473+-- =============================================================================
129−-- | The key function: combine two layers with automatic deduplication
474+-- Horizontal composition — combine two layers with automatic deduplication
130−-- Given two layers with potentially overlapping requirements,
475+-- =============================================================================
131−-- produce a layer with deduplicated requirements
476+
133−-- Uses expand to properly widen contexts and errors, then runs both layers!
134combineRequirements
477combineRequirements
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
136 . Union req1 req2 reqMerged
479 . Union req1 req2 reqMerged
137− => Nub reqMerged reqDeduped -- ← Automatic deduplication of requirements!
480+ => Nub reqMerged reqDeduped
138− => Union req1 _req1 reqDeduped -- req1 is subset of reqDeduped
481+ => Union req1 _req1 reqDeduped
139− => Union req2 _req2 reqDeduped -- req2 is subset of reqDeduped
482+ => Union req2 _req2 reqDeduped
483+ => Union err1 err2 errMerged
484+ => Nub errMerged errDeduped
140− => Union err1 _err1 () -- Widen errors to empty
485+ => Union err1 _err1 errDeduped
141− => Union err2 _err2 ()
486+ => Union err2 _err2 errDeduped
142− => Union prov1 prov2 provMergedRaw -- Merge provisions
487+ => Union prov1 prov2 provMerged
143− => Nub provMergedRaw provMerged -- Deduplicate provisions too!
488+ => Nub provMerged provMerged
144− => Keys req1 -- Needed for expand
489+ => Keys req1
145− => Keys req2 -- Needed for expand
490+ => Keys req2
146− => OmLayer req1 prov1 err1
491+ => OmLayer req1 err1 (Record prov1)
147− -> OmLayer req2 prov2 err2
492+ -> OmLayer req2 err2 (Record prov2)
148− -> OmLayer reqDeduped provMerged ()
493+ -> OmLayer reqDeduped errDeduped (Record provMerged)
149−combineRequirements (OmLayer build1) (OmLayer build2) = makeLayer do
494+combineRequirements layer1 layer2 = OmLayer (freshId unit) do
150− -- Widen both contexts and errors to allow them to run in the deduplicated context
495+ rec1 <- Om.expand (buildLayer layer1)
151− -- expand allows an Om computation to run in a larger context with larger error row
496+ rec2 <- Om.expand (buildLayer layer2)
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)
155 pure (Record.merge rec1 rec2)
497 pure (Record.merge rec1 rec2)
157−-- Example proof that this works:
499+withValue
158−-- If we have:
500+ :: forall req err prov1 prov2 provMerged
159−-- layer1 :: OmLayer (config :: Config) (logger :: Logger) ()
501+ . Union prov1 prov2 provMerged
160−-- layer2 :: OmLayer (config :: Config) (database :: Database) ()
502+ => Nub provMerged provMerged
161−--
503+ => Record prov1
162−-- Then: combineRequirements layer1 layer2
504+ -> OmLayer req err (Record prov2)
163−-- Has type: OmLayer (config :: Config) prov3 err3
505+ -> OmLayer req err (Record provMerged)
164−--
506+withValue defaults layer = OmLayer (freshId unit) do
165−-- NOT: OmLayer (config :: Config, config :: Config) prov3 err3
507+ rec <- buildLayer layer
166−--
508+ pure (Record.merge defaults rec)
167−-- The duplicated requirement (config, config) is automatically
509+
168−-- deduplicated to just (config) by the Nub constraint!
510+-- =============================================================================
170−-- =============================================================================
171−-- Vertical Composition (ZLayer-style provide)
172−-- =============================================================================
174−-- | Vertical composition: feed output of one layer into input of another
511+-- Vertical composition — feed output of one layer into input of another
175−-- | This is the >>> operator from ZIO ZLayer
512+-- =============================================================================
178−-- | postgresLive :: OmLayer (config :: Config) (postgres :: SQL) ()
179−-- | userRepoLive :: OmLayer (postgres :: SQL) (userRepo :: UserRepo) ()
181−-- | composed = userRepoLive `provide` postgresLive
182−-- | -- Result: OmLayer (config :: Config) (userRepo :: UserRepo) ()
184− :: forall req prov1 prov2 err1 err2 _req _prov1 _err1 _err2
515+ :: forall req prov1 prov2 err1 err2 req2 reqOut errMerged errDeduped _req _prov1 _err1 _err2
185− . Union req _req req -- expand constraints
516+ . Union req _req req
186 => Union prov1 _prov1 prov1
517 => Union prov1 _prov1 prov1
187− => Union err1 _err1 ()
518+ => Union err1 err2 errMerged
519+ => Nub errMerged errDeduped
520+ => Union err1 _err1 errDeduped
188− => Union err2 _err2 ()
521+ => Union err2 _err2 errDeduped
522+ => Union prov1 req reqOut
523+ => Nub reqOut reqOut
524+ => Union req2 _prov1 reqOut
189 => Keys req
525 => Keys req
190 => Keys prov1
526 => Keys prov1
191− => OmLayer prov1 prov2 err2 -- layer that needs prov1, provides prov2
527+ => Keys req2
528+ => OmLayer req2 err2 (Record prov2)
192− -> OmLayer req prov1 err1 -- layer that needs req, provides prov1
529+ -> OmLayer req err1 (Record prov1)
193− -> OmLayer req prov2 () -- composed: needs req, provides prov2
530+ -> OmLayer req errDeduped (Record prov2)
194−provide (OmLayer layer2) (OmLayer layer1) = makeLayer do
531+provide l2 l1 = OmLayer (freshId unit) do
195− -- Run first layer to get prov1
196− prov1 <- Om.expand layer1
532+ prov1 <- Om.expand (buildLayer l1)
197−
533+ Om.expand (buildLayer l2) # Om.widenCtx prov1
198− -- Run second layer with prov1 as context
199− liftAff $ Om.runOm prov1
200− { exception: \_ -> pure (unsafeCoerce {}) }
203infixl 9 provide as >->
535infixl 9 provide as >->
205−-- TODO: More sophisticated composition operators
537+-- =============================================================================
206−-- For now, use >>> for simple chains and combineRequirements for parallel deps
538+-- Retry / Repeat on layers
539+-- =============================================================================
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)
557+ catchError om (handleErr status)
559+ handleErr status variant = do
560+ let shouldRetry = variant # onMatch (mkChecks status) (\_ -> pure false)
562+ (applyAndDelay policy status >>= maybe (throwError variant) go)
563+ (throwError variant)
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)
576+ ifM (shouldRepeat status result)
577+ (applyAndDelay policy status >>= maybe (pure result) go)
581+-- =============================================================================
582+-- Topological auto-wiring (order-independent)
583+-- =============================================================================
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
589+instance AllLabelsIn Nil haystack True
592+ ( HasLabel label haystack found
593+ , AllLabelsIn tail haystack tailResult
594+ , And found tailResult result
596+ AllLabelsIn (Cons label ty tail) haystack result
598+-- | Dispatch based on whether a layer is ready (deps satisfied).
599+class FindReadyDispatch
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
611+instance FindReadyDispatch True sym layer tail available allLayersRL sym layer tail
614+ FindReady tail available allLayersRL foundSym foundLayer rest' =>
615+ FindReadyDispatch False sym layer tail available allLayersRL foundSym foundLayer (Cons sym layer rest')
617+-- | Scan candidates for the first layer whose requirements are satisfied.
619+ (candidates :: RowList Type)
620+ (available :: RowList Type)
621+ (allLayersRL :: RowList Type)
624+ (rest :: RowList Type)
625+ | candidates available allLayersRL -> sym layer rest
628+ ( PrintLayersASCII allLayersRL graphDoc
631+ ( Above (Text "Dependency not provided!")
633+ ( Above (Text "No remaining layer has all its dependencies satisfied.")
635+ ( Above (Text "Dependency graph:") graphDoc
643+ FindReady Nil available allLayersRL sym layer rest
646+ ( RowToList req reqRL
647+ , AllLabelsIn reqRL available isReady
648+ , FindReadyDispatch isReady sym (OmLayer req err (Record prov)) tail available allLayersRL foundSym foundLayer rest
650+ FindReady (Cons sym (OmLayer req err (Record prov)) tail) available allLayersRL foundSym foundLayer rest
652+-- | Topologically sort and wire layers. Each iteration finds a layer whose
653+-- | dependencies are already satisfied, processes it, and adds its provisions.
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
668+ -> OmLayer accReq accErr (Record accProv)
669+ -> OmLayer resReq resErr (Record resProv)
671+instance TopoWire Nil layers accReq accErr accProv accReq accErr accProv where
672+ topoWire _ _ acc = acc
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
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
690+ , Union accErr nextErr errMergedRaw
691+ , Nub errMergedRaw errMerged
692+ , Union accErr _e1 errMerged
693+ , Union nextErr _e2 errMerged
695+ , Union accProv nextProv provMerged
696+ , Nub provMerged provMerged
698+ , TopoWire rest layers accReq errMerged provMerged resReq resErr resProv
700+ TopoWire remaining layers accReq accErr accProv resReq resErr resProv where
701+ topoWire _ layers acc =
702+ topoWire (Proxy :: Proxy rest) layers combined
704+ next :: OmLayer nextReq nextErr (Record nextProv)
705+ next = Record.get (Proxy :: Proxy readySym) layers
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)
714+ :: forall layers rl req err prov
715+ . RowToList layers rl
716+ => TopoWire rl layers (scope :: Scope) () () req err prov
718+ -> OmLayer req err (Record prov)
720+ topoWire (Proxy :: Proxy rl) layers seed
722+ seed = pure {} :: OmLayer (scope :: Scope) () (Record ())
724+-- =============================================================================
725+-- Debug graph printing (D2 diagram)
726+-- =============================================================================
728+-- | Remove `scope :: Scope` from a RowList (it's always present, just noise).
729+class FilterScope (rl :: RowList Type) (out :: RowList Type) | rl -> out
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)
735+-- | Marker symbol for unresolved dependencies.
736+type NotProvided :: Symbol
737+type NotProvided = "???"
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
742+instance FindProvider label Nil NotProvided
745+ ( RowToList prov provRL
746+ , HasLabel label provRL hasIt
747+ , FindProviderMatch hasIt label sym (Cons sym (OmLayer req err (Record prov)) tail) provider
749+ FindProvider label (Cons sym (OmLayer req err (Record prov)) tail) provider
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
754+instance FindProviderMatch True label sym rl sym
757+ FindProvider label tail provider =>
758+ FindProviderMatch False label sym (Cons sym ty tail) provider
760+-- | Check if a RowList contains a given label.
761+class HasLabel (label :: Symbol) (rl :: RowList Type) (result :: Boolean) | label rl -> result
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
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
770+instance EmitEdges consumer Nil allLayers (Text "")
773+ ( FindProvider label allLayers provider
774+ , Append " " provider s0
775+ , Append s0 " --> " s1
776+ , Append s1 consumer line
777+ , EmitEdges consumer tail allLayers restDoc
779+ EmitEdges consumer (Cons label ty tail) allLayers (Above (Text line) restDoc)
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
785+instance PrintLayersRL Nil (Text "")
786+else instance PrintEdgesRL rl rl doc => PrintLayersRL rl doc
788+instance PrintEdgesRL Nil allLayers (Text "")
791+ ( RowToList req reqRL
792+ , FilterScope reqRL filteredReqRL
793+ , EmitEdges sym filteredReqRL allLayers edgeDoc
794+ , PrintEdgesRL tail allLayers restDoc
796+ PrintEdgesRL (Cons sym (OmLayer req err (Record prov)) tail) allLayers (Above edgeDoc restDoc)
798+-- | Map a symbol to same-length dashes (for box borders).
799+class DashesFor (sym :: Symbol) (dashes :: Symbol) | sym -> dashes
801+instance DashesFor "" ""
804+ ( Cons head tail sym
805+ , DashesFor tail rest
806+ , Append "─" rest dashes
808+ DashesFor sym dashes
810+-- | Build box parts from a symbol.
811+class BoxTop (sym :: Symbol) (result :: Symbol) | sym -> result
814+ ( DashesFor sym dashes
815+ , Append "╭─" dashes s0
816+ , Append s0 "─╮" result
820+class BoxMid (sym :: Symbol) (result :: Symbol) | sym -> result
823+ ( Append "│ " sym s0
824+ , Append s0 " │" result
828+class BoxBot (sym :: Symbol) (result :: Symbol) | sym -> result
831+ ( DashesFor sym dashes
832+ , Append "╰─" dashes s0
833+ , Append s0 "─╯" result
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
844+-- Missing dep: boxed label, type outside
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
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)))
854+-- Provided dep: boxed label, then recurse into provider's sub-tree
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
863+ RenderDepChildNode False provider label ty prePrefix contPrefix branchPrefix allLayers
864+ (Above (Text topFull) (Above (Text midFull) (Above (Text botFull) subDoc)))
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
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
875+instance HasDirectMissing Nil allLayers False
878+ ( FindProvider label allLayers provider
879+ , IsNotProvided provider isMissing
880+ , HasDirectMissingOr isMissing tail allLayers result
882+ HasDirectMissing (Cons label ty tail) allLayers result
884+class HasDirectMissingOr (found :: Boolean) (tail :: RowList Type) (allLayers :: RowList Type) (result :: Boolean)
885+ | found tail allLayers -> result
887+instance HasDirectMissingOr True tail allLayers True
890+ HasDirectMissing tail allLayers result =>
891+ HasDirectMissingOr False tail allLayers result
893+-- | Look up a layer's requirements by name.
894+class FindLayerReqs (sym :: Symbol) (allLayers :: RowList Type) (reqRL :: RowList Type)
895+ | sym allLayers -> reqRL
898+ RowToList req reqRL =>
899+ FindLayerReqs sym (Cons sym (OmLayer req err (Record prov)) tail) reqRL
902+ FindLayerReqs sym tail reqRL =>
903+ FindLayerReqs sym (Cons other otherLayer tail) reqRL
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
910+instance RenderProviderDeps NotProvided prefix allLayers (Text "")
913+ ( FindLayerReqs provider allLayers reqRL
914+ , FilterScope reqRL filteredReqRL
915+ , RenderDepTree prefix filteredReqRL allLayers doc
917+ RenderProviderDeps provider prefix allLayers doc
919+-- | Render a dependency tree with tree connectors.
921+ (prefix :: Symbol) (reqRL :: RowList Type) (allLayers :: RowList Type) (doc :: Doc)
922+ | prefix reqRL allLayers -> doc
924+instance RenderDepTree prefix Nil allLayers (Text "")
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
935+ RenderDepTree prefix (Cons label ty Nil) allLayers doc
937+-- Non-last child: ├───
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
946+ RenderDepTree prefix (Cons label ty tail) allLayers (Above childDoc restDoc)
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
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
959+ PrintEdgesASCII tail allLayers doc =>
960+ PrintLayerDispatch False displayName filteredReqRL tail allLayers doc
963+ ( BoxTop displayName topLine, BoxMid displayName midLine, BoxBot displayName botLine
964+ , RenderDepTree " " filteredReqRL allLayers treeDoc
965+ , PrintEdgesASCII tail allLayers restDoc
967+ PrintLayerDispatch True displayName filteredReqRL tail allLayers
968+ (Above (Text topLine) (Above (Text midLine) (Above (Text botLine) (Above treeDoc (Above (Text "") restDoc)))))
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
974+instance PrintLayersASCII Nil (Text "")
975+else instance PrintEdgesASCII rl rl doc => PrintLayersASCII rl doc
977+instance PrintEdgesASCII Nil allLayers (Text "")
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
987+ PrintEdgesASCII (Cons sym (OmLayer req err (Record prov)) tail) allLayers doc
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
996+ -> OmLayer req err (Record prov)
997+wireLayersDebug = wireLayers