@@ -76,6 +76,193 @@
7676 ^- (each imported @t)
7777 (read-with module name typ ~)
7878::
79+:: When Hoon's expanded type has lost source cases, inspect the exact
80+:: selected local arm. Restrict this fallback to distinct literal head tags
81+:: and proven-safe dependencies, then verify each projected branch again.
82++$ tagged-case [tag=@ branch=spec]
83+:: Clay and eval expose different versions of the spec union. Inspect a
84+:: help wrapper as a noun before checking its contained spec.
85+++ source-gist-tail
86+ |= raw=*
87+ ^- (unit *)
88+ ?. ?=([%gist [%help *] *] raw) ~
89+ `+.+.raw
90+::
91+++ tagged-head
92+ |= branch=spec
93+ ^- (unit @)
94+ =/ gist=(unit *) (source-gist-tail branch)
95+ ?^ gist $(branch ;;(spec u.gist))
96+ ?+ branch ~
97+ [%bccl *]
98+ ?~ t.p.branch ~
99+ ?. ?=([%leaf %tas @] i.p.branch) ~
100+ `q.i.p.branch
101+ ==
102+::
103+++ tagged-cases
104+ |= [cases=(list spec) tags=(list @)]
105+ ^- (unit (list tagged-case))
106+ ?~ cases `~
107+ ?: |((has-spec-cell-union i.cases) (has-spec-general-union i.cases)) ~
108+ =/ tag=(unit @) (tagged-head i.cases)
109+ ?~ tag ~
110+ ?: (lien tags |=(x=@ =(x u.tag))) ~
111+ =/ rest $(cases t.cases, tags [u.tag tags])
112+ ?~ rest ~
113+ `[[u.tag i.cases] u.rest]
114+::
115+:: Benign source annotations have different typed representations on
116+:: Clay and under eval. Inspect the wrapper as a noun, and validate the
117+:: contained Hoon before examining an arm.
118+++ source-note-tail
119+ |= raw=*
120+ ^- (unit *)
121+ ?: ?=([%note [%help *] *] raw) `+.+.raw
122+ ?: ?=([%dbug * *] raw) `+.+.raw
123+ ~
124+::
125+++ tagged-source-code
126+ |= [code=hoon name=term]
127+ ^- (unit (list tagged-case))
128+ =/ note=(unit *) (source-note-tail code)
129+ ?^ note $(code ;;(hoon u.note))
130+ ?+ code ~
131+ [%ktcl *]
132+ ?. ?=([%name * [%bccn *]] p.code) ~
133+ ?. =(name p.p.code) ~
134+ =/ cases=(list spec) p.q.p.code
135+ ?~ cases ~
136+ ?~ t.cases ~
137+ (tagged-cases cases ~)
138+ ==
139+::
140+:: Source proof for dependencies of an explicitly tagged union. Only
141+:: simple local molds, standard collections and distinct term enums are
142+:: accepted; computed molds, nested cell unions and cycles fail closed.
143+:: One shared fuel budget bounds repeated visits through acyclic aliases;
144+:: exhaustion or an inherited same-name arm leaves the result unsupported.
145+++ local-arm-source
146+ |= [cor=type name=term]
147+ ^- (unit hoon)
148+ ?. ?=([%core *] cor) ~
149+ =/ chapters=(map term tome) q.r.q.cor
150+ =/ all=(list [term tome]) ~(tap by chapters)
151+ ?: (lien all |=(e=[term tome] &(!=(-.e %$) (chapter-unsafe +.e name)))) ~
152+ =/ chapter=(unit tome) (~(get by chapters) %$)
153+ ?~ chapter ~
154+ (chapter-source u.chapter name)
155+::
156+++ local-mold-spec
157+ |= [code=hoon name=term]
158+ ^- (unit spec)
159+ =/ note=(unit *) (source-note-tail code)
160+ ?^ note $(code ;;(hoon u.note))
161+ ?+ code ~
162+ [%ktcl *]
163+ ?. ?=([%name * *] p.code) ~
164+ ?. =(name p.p.code) ~
165+ `q.p.code
166+ ==
167+::
168+++ safe-source-enum
169+ |= [cases=(list spec) seen=(list @) fuel=@ud]
170+ ^- (unit @ud)
171+ ?~ cases `fuel
172+ ?: =(fuel 0) ~
173+ ?. ?=([%leaf %tas @] i.cases) ~
174+ ?: (lien seen |=(n=@ =(n q.i.cases))) ~
175+ $(cases t.cases, seen [q.i.cases seen], fuel (dec fuel))
176+::
177+++ safe-source-specs
178+ |= [xs=(list spec) cor=type seen=(list term) fuel=@ud]
179+ ^- (unit @ud)
180+ ?~ xs `fuel
181+ =/ left=(unit @ud) (safe-source-spec i.xs cor seen fuel)
182+ ?~ left ~
183+ $(xs t.xs, fuel u.left)
184+::
185+++ safe-source-name
186+ |= [name=term cor=type seen=(list term) fuel=@ud]
187+ ^- (unit @ud)
188+ ?: (lien seen |=(x=term =(name x))) ~
189+ =/ arm=(unit hoon) (local-arm-source cor name)
190+ ?~ arm
191+ ?. &(|(=(name %ship) =(name %path)) (scope-safe cor name)) ~
192+ `fuel
193+ ?. ?=([%core *] cor) ~
194+ ?. (scope-safe p.cor name) ~
195+ =/ body=(unit spec) (local-mold-spec u.arm name)
196+ ?~ body ~
197+ (safe-source-spec u.body cor [name seen] fuel)
198+::
199+++ safe-source-spec
200+ |= [shape=spec cor=type seen=(list term) fuel=@ud]
201+ ^- (unit @ud)
202+ ?: =(fuel 0) ~
203+ =. fuel (dec fuel)
204+ =/ gist=(unit *) (source-gist-tail shape)
205+ ?^ gist $(shape ;;(spec u.gist))
206+ ?+ shape ~
207+ [%base *] ?:(?=([%atom *] p.shape) `fuel ~)
208+ [%leaf *] `fuel
209+ [%bcts *] ?@ p.shape $(shape q.shape)
210+ ~
211+ [%bccl *] (safe-source-specs p.shape cor seen fuel)
212+ [%bcwt *] (safe-source-enum p.shape ~ fuel)
213+ [%like *]
214+ ?. ?=([@ ~] p.shape) ~
215+ ?. ?=(~ q.shape) ~
216+ (safe-source-name i.p.shape cor seen fuel)
217+ [%make *]
218+ ?. ?=([%wing [@ ~]] p.shape) ~
219+ =/ n=term i.p.p.shape
220+ ?. (lien `(list term)`~[%map %set %qeu %list %unit %jar %jug] |=(x=term =(x n))) ~
221+ ?. (scope-safe cor n) ~
222+ (safe-source-specs q.shape cor seen fuel)
223+ ==
224+::
225+++ safe-source-tagged
226+ |= [cases=(list tagged-case) cor=type seen=(list term) fuel=@ud]
227+ ^- ?
228+ ?~ cases &
229+ =/ left=(unit @ud) (safe-source-spec branch.i.cases cor seen fuel)
230+ ?~ left |
231+ $(cases t.cases, fuel u.left)
232+::
233+++ tagged-union-fallback
234+ |= [module=term name=term cor=type]
235+ ^- (unit (each imported @t))
236+ ?. ?=([%core *] cor) ~
237+ =/ chapters=(map term tome) q.r.q.cor
238+ =/ other=(list [term tome]) ~(tap by chapters)
239+ ?: (lien other |=(e=[term tome] &(!=(-.e %$) (chapter-unsafe +.e name)))) ~
240+ =/ chapter=(unit tome) (~(get by chapters) %$)
241+ ?~ chapter ~
242+ =/ selected=(unit hoon) (chapter-source u.chapter name)
243+ ?~ selected ~
244+ =/ cases (tagged-source-code u.selected name)
245+ ?~ cases ~
246+ ?. (safe-source-tagged u.cases cor ~[name] 4.096) ~
247+ =/ tried=(each (list type) tang)
248+ (mule |.((turn u.cases |=(c=tagged-case (~(play ut cor) [%kttr branch.c])))))
249+ ?. ?=([%& *] tried) ~
250+ =/ projected=(each (list imported) tang)
251+ (mule |.((turn p.tried |=(t=type (walk module t catalog ~ `cor)))))
252+ ?. ?=([%& *] projected) ~
253+ ?^ (first-bads p.projected) ~
254+ ?. (all-disjoint p.projected) ~
255+ =/ xs=(list tagged-case) u.cases
256+ =/ ys=(list imported) p.projected
257+ |-
258+ ?~ xs
259+ ?^ ys ~
260+ `[%& [%fork (sort p.projected |=(pair=[imported imported] (dor -.pair +.pair)))]]
261+ ?~ ys ~
262+ ?. ?=([%cell [%atom %tas [~ @]] *] i.ys) ~
263+ ?. =(tag.i.xs u.value.head.i.ys) ~
264+ $(xs t.xs, ys t.ys)
265+::
79266:: +read-mold-in: accept the /sur core as provenance. The core must be
80267:: built against zuse or validated Ford imports, and its selected arm
81268:: must be this type. Unknown subject shapes fail closed.
@@ -91,8 +278,12 @@
91278 ?. =(typ (~(play ut cor) (ream (cat 3 '*' name))))
92279 [%| 'Hoon module provenance does not match the selected mold']
93280 =/ result (read-with module name typ [~ cor])
94− ?. ?=([%& *] result) result
95− result
281+ ?: ?=([%& *] result) result
282+ =/ fallback=(each (unit (each imported @t)) tang)
283+ (mule |.((tagged-union-fallback module name cor)))
284+ ?: ?=(%| -.fallback) result
285+ ?~ p.fallback result
286+ u.p.fallback
96287::
97288:: +read-named is the source-aware entry point for callers that have
98289:: not selected a Hoon type yet. Check the core and the local arm
@@ -663,6 +854,32 @@
663854 ?. (arm-map-valid +.chapter) ~
664855 [~ (arm-map-has +.chapter target)]
665856::
857+:: Return a unique source arm from either validated tome wrapper. Walk
858+:: the noun map rather than relying on fields that differ on Clay.
859+++ arm-map-sources
860+ |= [m=* target=term]
861+ ^- (list hoon)
862+ ?@ m ~
863+ =/ kv=* -.m
864+ =/ children=* +.m
865+ =/ found=(list hoon) ?:(=(-.kv target) ~[;;(hoon +.kv)] ~)
866+ (weld found (weld $(m -.children) $(m +.children)))
867+::
868+++ chapter-source
869+ |= [chapter=* target=term]
870+ ^- (unit hoon)
871+ ?: (arm-map-valid chapter) (unique-arm-source chapter target)
872+ ?@ chapter ~
873+ ?. (arm-map-valid +.chapter) ~
874+ (unique-arm-source +.chapter target)
875+::
876+++ unique-arm-source
877+ |= [arms=* target=term]
878+ ^- (unit hoon)
879+ =/ sources=(list hoon) (arm-map-sources arms target)
880+ ?. ?=([* ~] sources) ~
881+ `i.sources
882+::
666883++ chapter-unsafe
667884 |= [chapter=* target=term]
668885 ^- ?
@@ -1366,6 +1583,13 @@
13661583 =/ distinct=type -:(ride distinct-parent origin-first)
13671584 =/ trans-amb-parent=type [%cell [%face %intermediate fc] [%cell [%face %second sc] -:!>(..zuse)]]
13681585 =/ trans-amb=type -:(ride trans-amb-parent origin-trans)
1586+ =/ tag-child=@t
1587+ '|%\0a+$ tag-invalid-cell @t\0a+$ choice $%([%ok a=tag-invalid-cell] [%err a=@ud])\0a--\0a'
1588+ =/ tag-collision=type -:(ride [%cell [%face %base sc] -:!>(..zuse)] tag-child)
1589+ =/ tag-clean=type -:(ride [%cell [%face %base other] -:!>(..zuse)] tag-child)
1590+ =/ tag-zuse=@t
1591+ '|%\0a+$ ship @t\0a+$ path @ud\0a+$ choice $%([%ok who=ship] [%err where=path])\0a--\0a'
1592+ =/ tag-zuse-core=type -:(ride -:!>(..zuse) tag-zuse)
13691593 =/ sample
13701594 |= name=term
13711595 (read-mold-in %small name (~(play ut sc) (ream (cat 3 '*' name))) sc)
@@ -1526,6 +1750,26 @@
15261750 (crip "missing-arm: {(show-result (read-mold-in %small %missing [%atom %ud ~] sc))}")
15271751 (crip "wrong-provenance: {(show-result (read-mold-in %small %action (~(play ut sc) (ream '*items')) sc))}")
15281752 (crip "unverified-subject: {(show-result (read-mold-in %std %jar (~(play ut -:!>(..zuse)) (ream '*(jar @ud @t)')) -:!>(..zuse)))}")
1753+ (crip "tag-ford-collision: {(show-result (read-named %child %choice tag-collision))}")
1754+ (crip "tag-ford-clean: {(show-result (read-named %child %choice tag-clean))}")
1755+ (crip "tag-zuse-local: {(show-result (read-named %child %choice tag-zuse-core))}")
1756+ (crip "tag-valid: {(show-result (sample %tag-valid))}")
1757+ (crip "tag-duplicate: {(show-result (sample %tag-duplicate))}")
1758+ (crip "tag-collapsed: {(show-result (sample %tag-collapsed))}")
1759+ (crip "tag-invalid-direct: {(show-result (sample %tag-invalid-direct))}")
1760+ (crip "tag-invalid-alias: {(show-result (sample %tag-invalid-alias))}")
1761+ (crip "tag-invalid-list: {(show-result (sample %tag-invalid-list))}")
1762+ (crip "tag-enum-good: {(show-result (sample %tag-enum-good))}")
1763+ (crip "tag-enum-bad: {(show-result (sample %tag-enum-bad))}")
1764+ (crip "tag-nested-good: {(show-result (sample %tag-nested-good))}")
1765+ (crip "tag-shadow-jar: {(show-result (read-named %shadow-static %tag-shadow-jar xc))}")
1766+ (crip "tag-shadow-jug: {(show-result (read-named %shadow-static %tag-shadow-jug xc))}")
1767+ (crip "tag-fuel-small: {?:(?=(^ (safe-source-name %tag-fuel-2 sc ~ 64)) "yes" "no")}")
1768+ (crip "tag-fuel-large: {?:(?=(~ (safe-source-name %tag-fuel-11 sc ~ 64)) "rejected" "wrong")}")
1769+ (crip "presence-action-1: {(show-result (present %action-1))}")
1770+ (crip "presence-command-1: {(show-result (present %command-1))}")
1771+ (crip "presence-update-1: {(show-result (present %update-1))}")
1772+ (crip "presence-response-1: {(show-result (present %response-1))}")
15291773 (crip "presence-topic: {(show-result (present %topic))}")
15301774 (crip "presence-timing: {(show-result (present %timing))}")
15311775 (crip "presence-places: {(show-result (present %places))}")