1
1
mirror of https://github.com/urbit/shrub.git synced 2024-12-28 06:32:51 +03:00
shrub/pkg/arvo/lib/xray.hoon
fang a539d986a7
various: move away from {type} syntax
In favor of [type] syntax.
Turns a bunch of ++ into +$ along the way.
2020-11-26 17:43:26 +01:00

1942 lines
62 KiB
Plaintext

/- *plum, *xray
::
:: # Type Analysis
::
:: This does analysis on types to produce an `ximage` value, which can
:: be used to print the type (with `ximage-to-spec`) or to print values
:: of that type (using the `libpprint` library). You should understand
:: the `ximage` type before digging further.
::
:: `xray-type` is the main gate of interest here. It's implemented as a
:: series of passes:
::
:: - `analyze-type`: This takes a `type`, which is a lazily-evaluated,
:: recursive xdat structure, and converts it into an explicit
:: graph. It also collect the information from `%hint` types and
:: decorates the graph nodes with that.
::
:: - `cleanup`: Removes `%pntr` nodes, replacing references to them
:: with references to what they resolve to.
::
:: - `decorate-ximage-with-loops`: Determines which nodes reference
:: themselves recursively.
::
:: - `decorate-ximage-with-xpats`: Adds printing heuristics to types:
:: "Should this be printed as a list?"
::
:: - `decorate-ximage-with-xshapes`: Determines the loose shape of each
:: type. This overlaps with, and is used by, the next pass. Doing
:: this as a separate pass removes a lot of difficult edge-cases when
:: determining the `xrole` of cell-types.
::
:: - `decorate-ximage-with-xroles`: Restructures forks to make them
:: coherent. This is important both for printing types (we want to use
:: `$@` `$%` `$%`, etc) and for printing xdat (we need an efficient
:: way to determine which branch of a fork matches a value.
::
:: # Todos
::
:: - XX It seems (have'nt verified this) that there's a lot of things
:: that are forks that, once void types have been factored out,
:: only actually refer to one thing. It would be nice to discover
:: things of this kind and replace such fork node with the thing the
:: actualy resolve to.
::
:: The reason I think this is what's happening is that I see lots
:: of %unexpected-fork-xrole messages when converting the kernel type
:: to a spec, and those xroles have things like %tall and %atom.
:: However! The `combine` function never produces anything with
:: those xroles.
::
:: - XX Create xpats and matchers %map %set.
::
:: - XX Create xpats and matchers for tuples. There's no need to
:: recreate this structure in the printing code, and that's what we're
:: doing now.
::
:: - XX The xpat of an xray could be computed on demand instead of
:: up-front. Possibly a lot faster!
::
:: - XX The loop-detection of an xray could be done on demand instead
:: of up-front. Possibly a lot faster!
::
:: - XX The xpat matching code is basically brute-force.
::
:: If it turns out to be a performance bottleneck, there's lots of
:: low-hanging fruit there. For example:
::
:: - Faces repeat the work done for the type they reference.
:: - When detecting whether a cell is part of an "informal" list,
:: we recurse into the tail repeatedly. For example, the following
:: example will do the "formal-list" test 3 times:
::
:: - `[1 2 `(list @)`~]`
::
:: - XX Try to find a way to drop the `%pntr` constructor from
:: `%xdat`. The consumer of an `xray` does not care.
::
:: - XX Actually, it would also be really nice to produce another
:: version of this structure that doesn't have the (unit *) wrapper around
:: everything interesting. This would make the on-demand computation
:: of various things hard, though.
::
:: - XX Simply lying about the type of deep arms is not robust. I am just
:: claiming that they are nouns, but if another thing in the xray
:: actually needs it, it will think it's a noun too.
::
:: - XX There are probably remaining bugs. Test the shit out of this.
::
:: - XX What should the `xrole` of a cell with a %noun head be? I
:: think the current design can't handle this case coherently.
::
|^ ^- $: ximage-to-spec=$-(=ximage =spec)
xray-type=$-([@ type] ximage)
focus-on=$-([xtable xkey] xray)
==
[ximage-to-spec xray-type focus-on]
::
+| %helpers
::
++ batt-of |$ [arm] (map term (pair what (map term arm)))
++ chap-of |$ [arm] [doc=what arms=(map term arm)]
::
:: Traverse over a chapter in a battery.
::
++ traverse-chapter
|* [state=mold in=mold out=mold]
|= [[st=state chap=(chap-of in)] f=$-([state term in] [out state])]
^- [(chap-of out) state]
=^ arms st ((traverse-map state term in out) [st arms.chap] f)
[chap(arms arms) st]
::
:: Traverse over a battery.
::
++ traverse-battery
|* [state=mold in=mold out=mold]
|= [[st=state batt=(batt-of in)] f=$-([state term in] [out state])]
^- [(batt-of out) state]
%+ (traverse-map state term (chap-of in) (chap-of out))
[st batt]
|= [st=state chapter-name=term chap=(chap-of in)]
^- [(chap-of out) state]
((traverse-chapter state in out) [st chap] f)
::
:: Map a function over all the arms in a battery.
::
++ turn-battery
|* arm=mold
|= [b=(batt-of arm) f=$-(arm arm)]
^- (batt-of arm)
%- ~(run by b)
|= [w=what chap=(map term arm)]
^- [what (map term arm)]
:- w
%- ~(run by chap)
|= i=arm
^- arm
(f i)
::
:: Create a new xray with `xdat` set to `d`. If the xray is already in
:: the table, do nothing.
::
++ post-xray
|= [tbl=xtable ty=type d=(unit xdat)]
^- [xkey xtable]
::
=/ old (~(get by type-map.tbl) ty)
?^ old [u.old tbl]
::
=/ i=xkey next.tbl
=/ x=xray [i ty d ~ ~ ~ ~ ~ ~ ~]
::
=. next.tbl +(next.tbl)
=. xrays.tbl (~(put by xrays.tbl) i x)
=. type-map.tbl (~(put by type-map.tbl) ty i)
[i tbl]
::
:: Create an new xray and put it in the xray table. If there's already
:: a stub xray under this type, replace it. Otherwise, allocate a
:: new index and put it there.
::
++ replace-xray
|= [img=xtable x=xray]
^- xtable
img(xrays (~(put by xrays.img) xkey.x x))
::
:: Get an xray, update its xdat, and put it back in.
::
++ set-xray-xdat
|= [img=xtable i=xkey d=xdat]
^- xtable
=/ x=xray (focus-on img i)
(replace-xray img x(xdat `d))
::
:: Get an xray from an `xtable`, given its `xkey`.
::
++ focus-on
|= [img=xtable i=xkey]
^- xray
=/ res=(unit xray) (~(get by xrays.img) i)
?~ res ~& ['internal error: invalid xray reference' i] !!
u.res
::
:: Return a list of xrays referenced by an xrayed battery. (the context
:: type and the type of each arm).
::
++ battery-refs
|= b=xbat
^- (list xkey)
%- zing
%+ turn ~(val by b)
|= [=what =(map term xkey)]
^- (list xkey)
~(val by map)
::
:: Just for debugging: print an ximage and then return it.
::
++ trace-ximage
|= img=ximage
^- ximage
~& ['root=' root.img]
~& %+ sort ~(tap by xrays.xtable.img)
|= [[xi=xkey x=xray] [yi=xkey y=xray]]
(lth xi yi)
img
::
:: All non-fork xrays referenced by a fork xray. This will recurse
:: into forks-of-forks (and so on) and can handle infinite forks.
::
:: If this is called on a non-fork node, it will return a set with just
:: that one node in it.
::
:: Separating this out really simplifies things, without this handling
:: infinite forks is quite error-prone.
::
:: XX Should we collect face nodes instead of recursing into them (feels
:: like yes, but why did I do it the other way before)?
::
:: XX This is turning out to be useful. Should we add a field to cache
:: the result of this?
::
++ xray-branches
|= [img=xtable i=xkey]
^- (set xkey)
::
=/ acc=(set xkey) ~
=/ stk=(set xkey) ~
::
|- ^- (set xkey)
::
?: (~(has in acc) i) acc
?: (~(has in stk) i) acc
::
=. stk (~(put in stk) i)
::
=/ x=xray (focus-on img i)
=/ d=xdat (need xdat.x)
::
?- d
%noun (~(put in acc) i)
%void (~(put in acc) i)
[%atom *] (~(put in acc) i)
[%cell *] (~(put in acc) i)
[%core *] (~(put in acc) i)
[%face *] $(i xray.d)
[%pntr *] $(i xray.d)
[%fork *] %+ (fold (set xkey) xkey)
[acc ~(tap in set.d)]
|= [=(set xkey) =xkey]
^$(acc set, i xkey)
==
::
+| %entry-point
::
:: The top-level routine: Takes a type, and xrays it to produce an
:: ximage.
::
:: When we analyze a core, we also analyze its context. `core-depth`
:: controls how deeply we will dig into the context. With `core-depth`
:: at 0, we just pretend that all cores have a context of type `*`.
::
++ xray-type
|= [core-depth=@ =type]
^- ximage
:: ~& %analyze-type
=/ =ximage (analyze-type core-depth type)
:: ~& %cleanup
=. ximage (cleanup ximage)
:: ~& %decorate-ximage-with-loops
=. ximage (decorate-ximage-with-loops ximage)
:: ~& %decorate-ximage-with-xpats
=. ximage (decorate-ximage-with-xpats ximage)
:: ~& %decorate-ximage-with-xshapes
=. ximage (decorate-ximage-with-xshapes ximage)
:: ~& %trace-ximage
:: =. ximage (trace-ximage ximage)
:: ~& %decorate-ximage-with-xroles
(decorate-ximage-with-xroles ximage)
:: ~& %trace-ximage
:: (trace-ximage ximage)
::
+| %analysis-passes
::
:: The main analysis code.
::
:: For every type we encounter,
::
:: - First check if an xray for this has already been created. This
:: could either be a recursive reference or just something we've
:: already processed. At this point we don't care.
::
:: - Next, allocate a new xray for this type with empty xdat. If
:: we encounter this type again recursively, that's fine, that will
:: just produce a reference to this xray and it will eventually
:: have xdat.
::
:: - Next, recurse into all referenced types and build out graph
:: nodes for those.
::
:: - Finally, create `xdat` based on the above, and update the xray
:: to have that xdat.
::
:: - The two edge-cases here are %hint and %hold. For those, we simply
:: do everything in exactly the same way except that `xdat`
:: will be set to `[%pntr *]`. We will resolve all of these
:: references in the first analysis pass (`cleanup`).
::
++ analyze-type
|= [core-depth=@ud =top=type]
^- ximage
::
|^ (main [0 ~ ~] top-type)
::
++ main
|= [st=xtable ty=type]
^- [xkey xtable]
::
=/ old (~(get by type-map.st) ty) :: already done
?^ old [u.old st]
::
=^ res=xkey st (post-xray st ty ~)
::
:- res
?- ty
%void (set-xray-xdat st res %void)
%noun (set-xray-xdat st res %noun)
[%atom *] (set-xray-xdat st res ty)
[%cell *] =^ hed=xkey st (main st p.ty)
=^ tyl=xkey st (main st q.ty)
(set-xray-xdat st res [%cell hed tyl])
[%core *] =^ d=xdat st (xray-core [p.ty q.ty] st)
(set-xray-xdat st res d)
[%face *] =^ i=xkey st (main st q.ty)
(set-xray-xdat st res [%face p.ty i])
[%fork *] =^ br st ((traverse-set xtable type xkey) [st p.ty] main)
(set-xray-xdat st res [%fork br])
[%hint *] =^ ref st (main st q.ty)
=^ updated st (hint st p.ty (focus-on st res))
(set-xray-xdat (replace-xray st updated) res [%pntr ref])
[%hold *] =^ ref st (main st ~(repo ut ty))
(set-xray-xdat st res [%pntr ref])
==
::
:: Analyze a %hint type.
::
:: This updates the `helps`, `studs`, and/or `recipe` fields of the
:: given xray.
::
++ hint
|= [st=xtable [subject-of-note=type =note] x=xray]
^- [xray xtable]
?- -.note
%help :_ st x(helps (~(put in helps.x) p.note))
%know :_ st x(studs (~(put in studs.x) p.note))
%made =^ recipe st
?~ q.note [[%direct p.note] st]
=^ params=(list xkey) st
|- ^- [(list xkey) xtable]
?~ u.q.note [~ st]
=/ tsgl [%tsgl [%limb %$] [%wing i.u.q.note]]
=/ part (~(play ut subject-of-note) tsgl)
=^ this st (main st part)
=^ more st $(u.q.note t.u.q.note)
[[this more] st]
[[%synthetic p.note params] st]
:_ st x(recipes (~(put in recipes.x) recipe))
==
::
:: Analyze a core.
::
:: When we analyze the context, we decrement `core-depth`. If that
:: ever hits zero, we substitute `%noun` for the type of the context.
::
:: The reason that we switch the variance to %gold is because the
:: core we're creating isn't an actual core, we're just using the arms
:: of this core as a namespace in which to evaluate each arm.
::
:: Also, in general, there's no way to determine the type of an arm
:: of a wet core, so we just assign all wet arms the type `%noun`.
::
:: This seems to work in practice, but I don't think it's actually
:: sound.
::
++ xray-core
|= [[=payload=type =coil] st=xtable]
^- [xdat xtable]
::
=^ payload-xkey st (main st payload-type)
=/ ctx=type [%core payload-type coil(r.p %gold)]
::
=^ batt st
%+ (traverse-battery xtable hoon xkey)
[st q.r.coil]
|= [st=xtable nm=term =hoon]
^- [xkey xtable]
?: =(%wet q.p.coil) (post-xray st %noun `%noun)
?: =(0 core-depth) (post-xray st %noun `%noun)
=. core-depth (dec core-depth)
(main st [%hold ctx hoon])
::
[[%core p.coil payload-xkey batt] st]
::
--
::
:: Remove `%pntr` nodes, replacing references to them with references
:: to what they resolve to.
::
:: 1. Build a list of reachable, non-reference nodes.
:: 2. Build a table of references mapped to the node they resolve to.
:: 3. If the root node is a pointer, replace it with what it references.
:: 4. Map over `type-map`, and replace every value using the table from #2.
:: 5. Map over the xrays, drop pointer nodes, replace every reference
:: using the table from #2.
::
++ cleanup
|= xt=ximage
^- ximage
::
=/ img=xtable xtable.xt
::
|^ =/ =xkey root.xt
:: ~& %build-table
=/ tbl (build-table xkey)
:: ~& %fix-xkey
=. xkey (fix-xkey tbl xkey)
:: ~& %fix-type-map
=. type-map.img (fix-type-map tbl type-map.img)
:: ~& %fix-xrays
=. xrays.img (fix-xrays tbl xrays.img)
:: ~& :* %gc-results
:: %before ~(wyt by xrays.xtable.xt)
:: %after ~(wyt by xrays.img)
:: ==
[xkey img]
::
+$ table
[live=(set xkey) refs=(map xkey xkey) refs-to=(map xkey (set xkey))]
::
:: Given a node that may be a pointer, follow the chain of pointers
:: until we find a non-pointer node.
::
++ deref
|= [img=xtable k=xkey]
^- xkey
|-
=/ x=xray (focus-on img k)
=/ d=xdat (need xdat.x)
?. ?=([%pntr *] d) xkey.x
$(k xray.d)
::
:: Walks the graph starting at the root, everything that's a %pntr
:: node becomes a xkey in the `refs` table and one of the values in the
:: `refs-to` table.
::
++ build-table
|^ |= k=xkey
^- table
=/ t=table [~ ~ ~]
=. t (recur t k)
=. refs-to.t ((reverse-map xkey xkey) refs.t)
t
::
++ recur
|= [acc=table k=xkey]
^- table
::
?: (~(has in live.acc) k) acc :: already processed
?: (~(has by refs.acc) k) acc :: already processed
::
=/ x=xray (focus-on img k)
=/ d=xdat (need xdat.x)
::
=. acc ?. ?=([%pntr *] d)
acc(live (~(put in live.acc) k))
acc(refs (~(put by refs.acc) k (deref img k)))
::
((fold table xkey) [acc (xray-refs k)] recur)
--
::
:: Rebuild `type-map`:
::
:: - If a type points to a pointer xray, update it to point to what
:: that pointer resolves to
:: - If the type isn't referenced from the root node, ignore it.
:: - Otherwise, just copy it into the resulting table as-is.
::
++ fix-type-map
|= [tbl=table =(map type xkey)]
^- _map
%+ (fold _map (pair type xkey))
[*_map ~(tap by map)]
|= [acc=_map [ty=type k=xkey]]
=/ dest (~(get by refs.tbl) k)
?^ dest (~(put by acc) ty u.dest)
?. (~(has in live.tbl) k) acc
(~(put in acc) ty k)
::
:: Rebuild the `xrays` table.
::
:: - If the xray isn't in the `live` set (it wont be there if it's
:: a pointer node or if it's inaccessible from the root node),
:: then ignore it.
:: - Otherwise, copy the xray into the result map while updating
:: all its references.
::
++ fix-xrays
|= [tbl=table xrays=(map xkey xray)]
^- _xrays
%+ (fold (map xkey xray) (pair xkey xray))
[*(map xkey xray) ~(tap by xrays)]
|= [acc=(map xkey xray) [i=xkey x=xray]]
?. (~(has in live.tbl) i) acc :: Drop unused xrays
(~(put by acc) i (fix-xray tbl x))
::
:: All the xrays which are simply references to `i`.
::
++ all-refs-to
|= [tbl=table i=xkey]
^- (set xkey)
=/ res (~(get by refs-to.tbl) i)
?~(res ~ u.res)
::
:: There may be `%hint` xdat on the `%pntr` xrays. Find all pointer
:: nodes that reference this one, and put all of their hint-xdat onto
:: this xray.
::
++ collect-hints
|= [tbl=table target=xray]
^- xray
%+ (fold xray xkey)
[target ~(tap in (all-refs-to tbl xkey.target))]
|= [acc=xray ref=xkey]
=/ ref-xray=xray (focus-on img ref)
=/ helps ^- (set help) (~(uni in helps.acc) helps.ref-xray)
=/ recipes ^- (set recipe) (~(uni in recipes.acc) recipes.ref-xray)
::
=/ studs ^- (set stud) :: Type system hack
%+ (fold (set stud) stud)
[studs.acc ~(tap in studs.ref-xray)]
|= [acc=(set stud) new=stud]
(~(put in acc) new)
::
acc(helps helps, studs studs, recipes recipes)
::
:: Note that the `xroles` and `pats` fields may contain references
:: to other xrays as well. We don't bother to update those, because this
:: pass runs before those fields are populated.
::
++ fix-xray
|= [tbl=table x=xray]
^- xray
=. x (collect-hints tbl x)
%= x
xdat `(fix-xdat tbl (need xdat.x))
recipes %- ~(gas in *(set recipe))
%+ turn ~(tap in recipes.x)
|= r=recipe (fix-recipe tbl r)
==
::
:: Update all the references in the `xdat` field.
::
++ fix-xdat
|= [tbl=table d=xdat]
^- xdat
::
=/ fix |=(i=xkey (fix-xkey tbl i))
::
?- d
%noun d
%void d
[%atom *] d
[%cell *] d(head (fix head.d), tail (fix tail.d))
[%core *] d(xray (fix xray.d), batt (fix-battery tbl batt.d))
[%face *] d(xray (fix xray.d))
[%fork *] d(set (~(gas in *(set xkey)) (turn ~(tap in set.d) fix)))
[%pntr *] d(xray (fix xray.d))
==
::
++ fix-battery
|= [tbl=table b=xbat]
^- xbat
%+ (turn-battery xkey) b
|= i=xkey (fix-xkey tbl i)
::
++ fix-xkey
|= [tbl=table i=xkey]
^- xkey
=/ res=(unit xkey) (~(get by refs.tbl) i)
?^ res u.res
i
::
++ fix-recipe
|= [tbl=table r=recipe]
^- recipe
?- r
[%direct *] r
[%synthetic *] r(list (turn list.r |=(i=xkey (fix-xkey tbl i))))
==
::
++ xray-refs
|= i=xkey
^- (list xkey)
=/ x=xray (focus-on img i)
%- zing
^- (list (list xkey))
:~ ?~(xdat.x ~ (xdat-refs u.xdat.x))
(zing (turn ~(tap in recipes.x) recipe-refs))
?~(xrole.x ~ (xrole-refs u.xrole.x))
==
::
++ recipe-refs
|= r=recipe
^- (list xkey)
?- r
[%direct *] ~
[%synthetic *] list.r
==
::
++ xrole-refs
|= s=xrole
^- (list xkey)
?@ s ~
?- -.s
%constant ~
%instance ~
%option ~(val by map.s)
%union ~(val by map.s)
%junction ~[flat.s deep.s]
%conjunction ~[wide.s tall.s]
%misjunction ~[one.s two.s]
==
::
++ xdat-refs
|= d=xdat
^- (list xkey)
?- d
%noun ~
%void ~
[%atom *] ~
[%cell *] ~[head.d tail.d]
[%core *] [xray.d (battery-refs batt.d)]
[%face *] ~[xray.d]
[%pntr *] ~[xray.d]
[%fork *] ~(tap in set.d)
==
--
::
:: Detect loops.
::
:: This works by simply recursing through all the references within an
:: xray while keeping an explicit recursion stack: If we hit a node
:: that's in the stack, that's a loop. If we touch everything without
:: hitting a recursive reference, then it's not a loop.
::
:: Is the short-circuiting sound? I'm not sure now.
::
:: - When could it go wrong?
:: - This graph, for example:
::
:: ```
:: x -> y
:: y -> z
:: y -> y
:: z -> x
:: ```
::
:: - Let's say we process this starting with y, we will see that `y`
:: is a loop, and then when we go to process x, recursing into y will be
:: short-circuited since its `loop` field is already set.
::
:: - Well, maybe `x` will have been recognized as a loop during the
:: processing of `x`? I think it depends on whether we continue
:: to trace through all references from `y` even after we've found
:: a loop, and I think we do.
::
:: - Put another way, this will recurse into everything referenced
:: by a type, and only mark loops once it's encountered them:
:: After processing a type, every type that it references
:: (transitive closure) will have been processed correctly.
::
++ decorate-ximage-with-loops
|= xt=ximage
^- ximage
|^ xt(xtable decorated)
::
++ decorated
^- xtable
=/ all-indicies ~(tap in ~(key by xrays.xtable.xt))
((fold xtable xkey) [xtable.xt all-indicies] decorate)
::
++ decorate
|= [img=xtable i=xkey]
^- xtable
::
=/ trace=(set xkey) ~
|- ^- xtable
::
=/ x (focus-on img i)
=/ dat (need xdat.x)
::
?. =(~ loop.x) img :: already done
?: (~(has in trace) i) (replace-xray img x(loop `%.y))
::
=. trace (~(put in trace) i)
::
=. img
?- dat
%noun img
%void img
[%atom *] img
[%cell *] =. img $(i head.dat)
$(i tail.dat)
[%core *] =. img $(i xray.dat)
%+ (fold xtable xkey)
[img (battery-refs batt.dat)]
|= [img=xtable i=xkey]
^$(img img, i i)
[%face *] $(i xray.dat)
[%pntr *] $(i xray.dat)
[%fork *] %+ (fold xtable xkey)
[img ~(tap in set.dat)]
|= [img=xtable i=xkey]
^$(img img, i i)
==
::
=. x (focus-on img i) :: get updated xray
?^ loop.x img :: loop found
(replace-xray img x(loop `%.n)) :: no loop found
--
::
:: Fills in the `xpats` fields in each xray (where possible).
::
:: This has a list of xpat "matchers", and, for each xray in the
:: ximage, it tries each matcher until one of them succeeds.
::
++ decorate-ximage-with-xpats
|= xt=ximage
^- ximage
::
=/ img=xtable xtable.xt
::
|^ =/ pairs %+ turn ~(tap by xrays.xtable.xt)
|= [i=xkey x=xray]
^- [xkey xray]
[i x(pats (xray-pats x))]
xt(xrays.xtable (~(gas by *(map xkey xray)) pairs))
::
++ xpats
^- (list $-(xray (unit xpat)))
:~ tree-xpat
list-xpat
unit-xpat
core-xpat
spec-xpat
type-xpat
manx-xpat
vase-xpat
hoon-xpat
json-xpat
nock-xpat
plum-xpat
skin-xpat
==
::
++ xray-pats
|= x=xray
^- (unit xpat)
::
=/ i=xkey xkey.x
=/ t=type type.x
=/ d=xdat (need xdat.x)
::
:: Atom printing works just fine using the xdat field.
?: ?=([%atom *] d) ~
::
=/ match xpats
::
|- ^- (unit xpat)
?~ match ~
=/ pat (i.match x)
?^ pat pat
$(match t.match)
::
++ simple-nest-xpat
|= [ty=type pat=xpat]
^- $-(xray (unit xpat))
|= x=xray
^- (unit xpat)
=/ subtype (~(nest ut ty) | type.x)
?:(subtype `pat ~)
::
++ type-xpat (simple-nest-xpat -:!>(*type) %type)
++ spec-xpat (simple-nest-xpat -:!>(*spec) %spec)
++ manx-xpat (simple-nest-xpat -:!>(*manx) %manx)
++ vase-xpat (simple-nest-xpat -:!>(*vase) %vase)
++ hoon-xpat (simple-nest-xpat -:!>(*hoon) %hoon)
++ json-xpat (simple-nest-xpat -:!>(*json) %json)
++ nock-xpat (simple-nest-xpat -:!>(*nock) %nock)
++ plum-xpat (simple-nest-xpat -:!>(*plum) %plum)
++ skin-xpat (simple-nest-xpat -:!>(*skin) %skin)
::
++ focus
|= i=xkey
^- xray
(focus-on img i)
::
++ is-nil
|= i=xkey
^- ?
=/ d=xdat (need xdat:(focus i))
?+ d %.n
[%atom *] =(d [%atom ~.n `0])
[%face *] $(i xray.d)
==
::
:: Is `ref`, after dereferencing faces, a loop-reference to `target`?
::
++ is-ref-to
|= [target=xkey ref=xkey]
^- ?
?: =(target ref) %.y
=/ =xdat (need xdat:(focus ref))
?: ?=([%face *] xdat) $(ref xray.xdat)
%.n
::
:: Is an xray an atom with the specified aura?
::
++ is-atom-with-aura
|= [c=cord i=xkey]
^- ?
=/ =xdat (need xdat:(focus i))
?+ xdat %.n
[%atom *] =(xdat [%atom aura=c constant-unit=~])
[%face *] $(i xray.xdat)
==
::
:: If the xray is a exactly two things, nil and a cell type, then
:: yield the xray for the cell type.
::
++ fork-of-nil-and-cell
|= x=xray
^- (unit xkey)
::
=/ d=xdat (need xdat.x)
::
?. ?=([%fork *] d) ~
::
=/ branches ~(tap in set.d)
?. ?=([* * ~] branches) ~
::
=/ nil i.branches
=/ node i.t.branches
|-
::
?: (is-nil node) $(node nil, nil node)
?. (is-nil nil) ~
::
`node
::
:: Is this xray a unit? (the %unit xpat)
::
:: This matches strictly. For example `[~ %a]` doesn't match, but
:: `^-((unit @) [~ %a])` does.
::
++ unit-xpat
|^ |= x=xray
^- (unit xpat)
=/ elem (match-unit-type-strict (focus xkey.x))
?~ elem ~
`[%unit u.elem]
::
++ match-unit-type-strict
|= =input=xray
^- (unit xkey)
::
=/ node=(unit xkey) (fork-of-nil-and-cell input-xray)
?~ node ~
::
=/ node-xdat=xdat (need xdat:(focus u.node))
::
?. ?=([%cell *] node-xdat) ~
?. (is-nil head.node-xdat) ~
=/ elem-xkey tail.node-xdat
=/ elem-xdat (need xdat:(focus elem-xkey))
?. ?=([%face *] elem-xdat) ~
::
`xray.elem-xdat
--
::
:: Is this xray a tree? (the %tree xpat)
::
++ tree-xpat
|^ |= =input=xray
^- (unit xpat)
=/ input-xkey=xkey xkey.input-xray
=/ inxdat=xdat (need xdat.input-xray)
?. ?=([%fork *] inxdat) ~
=/ branches ~(tap in set.inxdat)
?. ?=([* * ~] branches) ~
=/ nil i.branches
=/ node i.t.branches
|-
?: (is-nil node) $(node nil, nil node)
?. (is-nil nil) ~
=/ node-xdat=xdat (need xdat:(focus node))
?. ?=([%cell *] node-xdat) ~
?. (is-pair-of-refs-to input-xkey tail.node-xdat)
~
=/ elem-xdat (need xdat:(focus head.node-xdat))
?. ?=([%face *] elem-xdat) ~
`[%tree xray.elem-xdat]
::
++ is-pair-of-refs-to
|= [target=xkey cell=xkey]
^- ?
=/ =xdat (need xdat:(focus cell))
?: ?=([%face *] xdat) $(cell xray.xdat)
?. ?=([%cell *] xdat) %.n
?. (is-ref-to target head.xdat) %.n
?. (is-ref-to target tail.xdat) %.n
%.y
--
::
::
:: Is this xray a list? (a %list, %tape, %path, or %tour xpat)
::
:: This handles the special case of path literals not having a
:: list type: `/a/b` is just a macro for `[%a %b ~]`, but doesn't
:: accept this for other lists: We don't want ['a' %n ~] to be printed
:: as `['a' ~[%n]]`. However, we WILL print ['a' ~['b' 'c']] as ~['a'
:: 'b' 'c']. And that's what `match-list` matches on.
::
:: `match-list` checks is a type is informally a list: Is it a
:: cell with a (formal or informal) list in its tail?
::
:: `match-list-type-strict` checks if a list literally has the shape
:: of a `list type`. It must be a loop reference and fork of two
:: types, one of which is the nil type and the other is a cell with a
:: face in its head and loop reference as its tail.
::
++ list-xpat
|^ |= x=xray
^- (unit xpat)
=/ elem (match-list x)
?~ elem ~
?: (is-atom-with-aura 'tD' u.elem) [~ %tape]
?: (is-atom-with-aura 'ta' u.elem) [~ %path]
?: (is-atom-with-aura 'c' u.elem) [~ %tour]
?: (is-atom-with-aura 'tas' u.elem) [~ %path]
`[%list u.elem]
::
++ match-list
|= =input=xray
^- (unit xkey)
=/ d=xdat (need xdat.input-xray)
?+ d ~
[%face *] (match-list (focus xray.d))
[%fork *] (match-list-type-strict input-xray)
[%cell *] =/ elem-xkey=(unit xkey)
?: ?&((is-nil tail.d) (is-atom-with-aura 'tas' head.d))
`head.d
(match-list (focus tail.d))
?~ elem-xkey ~
?. (is-ref-to u.elem-xkey head.d) ~
`u.elem-xkey
==
::
++ match-list-type-strict
|= =input=xray
^- (unit xkey)
::
=/ node=(unit xkey) (fork-of-nil-and-cell input-xray)
?~ node ~
::
=/ node-xdat=xdat (need xdat:(focus u.node))
?. ?=([%cell *] node-xdat) ~
?. (is-ref-to xkey.input-xray tail.node-xdat) ~
::
=/ elem-xdat (need xdat:(focus head.node-xdat))
?. ?=([%face *] elem-xdat) ~
::
`xray.elem-xdat
--
::
:: A %gear is any core with a cell context.
::
:: A %gate is a gear with one chapter ('') with one arm ('').
::
++ core-xpat
|^ |= x=xray
^- (unit xpat)
=. x (focus xkey.x)
=/ gear (match-gear x)
?~ gear ~
=/ gate (match-gate x sample.u.gear batt.u.gear)
?^ gate gate
~ :: XX gear
::
++ match-gear
|= =input=xray
^- (unit [%gear sample=xkey context=xkey batt=xbat])
::
=/ input-xdat (need xdat.input-xray)
?. ?=([%core *] input-xdat) ~
=/ context-xkey=xkey xray.input-xdat
::
=/ context-xdat=xdat (need xdat:(focus context-xkey))
?. ?=([%cell *] context-xdat) ~
::
=/ sample-xkey=xkey head.context-xdat
=. context-xkey tail.context-xdat
`[%gear sample-xkey context-xkey batt.input-xdat]
::
++ match-gate
|= [=input=xray sample=xkey batt=xbat]
^- (unit [%gate xkey xkey])
::
=/ input-xdat (need xdat.input-xray)
?. ?=([%core *] input-xdat) ~
=/ chapters ~(tap by batt)
::
?~ chapters ~
?^ t.chapters ~
?. =(p.i.chapters '') ~
::
=/ arms=(list (pair term xkey)) ~(tap by q.q.i.chapters)
::
?~ arms ~
?^ t.arms ~
?. =(p.i.arms '') ~
::
=/ product=xkey q.i.arms
::
`[%gate sample product]
--
::
--
::
:: Determines the loose shape of each node in an ximage.
::
:: This is trival for everything besides forks, and for forks, we just
:: find all the non-fork branches with `xray-branches` and then calculate
:: the union type with `combine`.
::
:: Here's some pseudocode for the essence of the logic that we're
:: trying to implement here:
::
:: xdat Data = Noun | Void
:: | Atom | Cnst
:: | Cell Data Data
:: | Fork Data Data
::
:: xdat Shape = Noun | Void | Atom | Cnst | Cell | Junc
::
:: shape :: Data -> Shape
:: shape Noun = Noun
:: shape Void = Void
:: shape Atom = Atom
:: shape Cnst = Atom
:: shape (Cell a b) = Cell
:: shape (Fork x y) = forkShape (shape x) (shape y)
::
:: forkShape :: Shape -> Shape -> Shape
:: forkShape Void x = x
:: forkShape Noun _ = Noun
:: forkShape Junc _ = Junc
:: forkShape Atom Cell = Junc
:: forkShape x y | x==y = x
:: forkShape x y = forkShape y x
::
++ decorate-ximage-with-xshapes
|^ |= xt=ximage
^- ximage
=/ keys ~(tap in ~(key by xrays.xtable.xt))
%= xt xtable
%+ (fold xtable xkey)
[xtable.xt keys]
|= [st=xtable i=xkey]
xtable:(xray-xshape st i)
==
::
:: Calculate the xray
::
++ xray-xshape
|= [st=xtable i=xkey]
^- [xshape =xtable]
::
=/ x=xray (focus-on st i)
=/ dat (need xdat.x)
::
?^ xshape.x [u.xshape.x st] :: already processed
::
=^ res=xshape st
?- dat
%noun [%noun st]
%void [%void st]
[%atom *] [%atom st]
[%cell *] [%cell st]
[%core *] [%cell st]
[%fork *] (fork-xshape st (xray-branches st xkey.x))
[%face *] (xray-xshape st xray.dat)
[%pntr *] !! :: run `cleanup` first
==
::
=/ y=xray x :: type system hack
=. xshape.y `res
=. xrays.st (~(put by xrays.st) xkey.y y)
[res st]
::
:: Because `branches` comes from `xray-branches`, none of the xrays
:: we're folding over will be forks, therefore, we none of our calls
:: to `xray-xshape` will recurse: we won't get stuck in a loop.
::
++ fork-xshape
|= [st=xtable branches=(set xkey)]
^- [xshape xtable]
%+ (fold (pair xshape xtable) xkey)
[[%void st] ~(tap in branches)]
|= [acc=(pair xshape xtable) i=xkey]
^- [xshape xtable]
=^ res st (xray-xshape q.acc i)
[(combine p.acc res) st]
::
:: Given the xshapes of two types, determine the xshape of their union.
::
++ combine
|= [x=xshape y=xshape]
^- xshape
?: =(x y) x
?: =(x %void) y
?: =(y %void) x
?: =(x %noun) %noun
?: =(y %noun) %noun
%junc
--
::
:: Determine the `xrole` of each xray node, restructuring forks to make
:: them coherent.
::
:: This is fairly simple for non-role types, and we handle forks the
:: same way we do with `xshape` detection. The basic move is to get all
:: of the non-fork branches using `xray-branches`, make a list of them,
:: and fold a function over that. However, the function we're folding with
:: is MUCH more complicated.
::
:: One of the big sources of complexity is that we need to restructure
:: the shape of forks, so we will be creating a bunch of new graph
:: nodes, and rearranging them. For example, if we want to merge a
:: junction (a fork of an atom and a cell) with an atom type, we create
:: a new junction xray that is a fork of the old cell type and the
:: union of the two cell types. The function we fold with is `merge`,
:: but the bulk of the logic lives in `combine`.
::
:: Here's some pseudocode for the essence of the logic that we're
:: trying to implement here. Note that the code is actually shaped
:: quite differently than this and is much more detailed. So, try
:: to wrap your head around WHY this makes sense instead of just
:: trying to use this a map for the actual code.
::
:: xdat Data = Noun | Void
:: | Atom | Cnst
:: | Cell Data Data
:: | Fork Data Data
::
:: xdat Shape = Noun | Void | Atom | Cnst | Cell | Junc
::
:: xdat Role = Void | Noun
:: | Atom | Cnst
:: | Tall | Wide | Instance
:: | Option | Union | Conjunc | Junc
:: | Misjunc
::
:: role :: Data -> Unit Role
:: role Noun = ~
:: role Void = ~
:: role Atom = ~
:: role Cnst = ~
:: role (Cell hd _) = `(cellRoleByHead (shape hd))
:: role (Fork x y) = `(forkRole (shape x, role x) (shape y, role y))
::
:: cellRoleByHead :: Shape -> Unit Role
:: cellRoleByHead Cell = `Wide
:: cellRoleByHead Cnst = `Instance
:: cellRoleByHead Atom = `Tall
:: cellRoleByHead _ = ~
::
:: forkRole :: (Shape,Role) + (Shape,Role) -> Role
:: forkRole
:: Option <- option + option
:: Union <- union + union
:: Conjunc <- tall + wide
:: Junc <- atom + cell
:: Misjunc <- otherwise
:: where
:: option = role==Option || role==Instance
:: union = shape==Cnst || role==Union
:: atom = shape==Atom || shape==Cnst
:: cell = shape==Cell
:: tall = role==Tall
:: wide = role==Wide
:: cell = shape==Cell
::
++ decorate-ximage-with-xroles
|^ |= xt=ximage
^- ximage
::
=/ keys=(list xkey) ~(tap in ~(key by xrays.xtable.xt))
::
%= xt xtable
%+ (fold xtable xkey) [xtable.xt keys]
|= [st=xtable i=xkey]
^- xtable
xtable:(xray-xrole st i)
==
::
:: Given a type and xdat, either find the xray corresponding to that
:: type, or create a new one.
::
:: These xrays are for internal types that we create in order to
:: restructure forks, therefore they will never be loops.
::
++ alloc-fork-xray
|= [st=xtable ty=type d=xdat]
^- [xkey xtable]
=/ old=(unit xkey) (~(get by type-map.st) ty)
?^ old [u.old st]
=/ xkey next.st
=/ res=xray [xkey ty `d ~ ~ ~ ~ ~ ~ `%.n]
=. next.st +(xkey)
=. xrays.st (~(put by xrays.st) xkey.res res)
=. type-map.st (~(put by type-map.st) type.res xkey.res)
[xkey st]
::
:: Produces an xtable updated to have xrole information for a certain
:: node. For convenience, it also returns the xrole itself.
::
:: Note that the xrole of a core is always %wide, since the head of
:: a core is a battery, which is always a cell.
::
++ xray-xrole
|= [st=xtable i=xkey]
^- [=xrole =xtable]
=/ x=xray (focus-on st i)
::
=/ old xrole.x
?^ old [u.old st]
::
=/ dat=xdat (need xdat.x)
::
=^ res=xrole st
?: ?=([~ %void] xshape.x) [%void st] :: optimization
?: ?=([~ %noun] xshape.x) [%noun st] :: optimization
?- dat
%noun :_ st %noun
%void :_ st %void
[%atom *] :_ st (atom-xrole dat)
[%cell *] :_ st (cell-xrole-by-head (focus-on st head.dat))
[%core *] :_ st %wide
[%face *] (xray-xrole st xray.dat)
[%pntr *] !! :: Run `cleanup` first.
[%fork *] (fork-xrole st (xray-branches st xkey.x))
==
::
=. xrays.st (~(put by xrays.st) xkey.x x(xrole `res))
[res st]
::
:: Determines the xrole of an atom xray.
::
++ atom-xrole
|= [%atom =aura =constant=(unit @)]
^- xrole
?~ constant-unit %atom
[%constant u.constant-unit]
::
:: Calculate the xrole of a %cell xray.
::
:: XX I'm not sure this is correct. Should a cell with a noun head
:: be %tall? How about a %void head?
::
:: - A %void head should probably be %void.
:: - A %noun head should probably just be %cell, a xrole separate from
:: (%wide and %tall) to make the ambiguity explicit. For example,
:: the union of `[* @] + [@ @]` should be a misjunction, which isn't
:: what's happening now.
::
:: XX Also! A cell with a junction in its head should be a
:: conjunction, right?
::
++ cell-xrole-by-head
|= head=xray
^- xrole
::
=/ =xshape (need xshape.head)
=/ =xdat (need xdat.head)
::
=/ const ?. ?=([%atom *] xdat) ~
constant.xdat
::
?: =(xshape %cell) %wide
?^ const [%instance u.const]
%tall
::
:: Determine the xrole of %fork type.
::
:: Fold over all the branches off a fork using the `merge` function,
:: and then grab its `xrole` using `xray-xrole`.
::
:: In any non-trivial cases, the xray returned from `merge` will
:: already have its `xrole` set, so recursing into `xray-xrole`
:: shouldn't be dangerous.
::
:: XX This is probably an important part of the control-flow, and it
:: might be helpful to make this invariant more prominent.
::
++ fork-xrole
|= [st=xtable fork=(set xkey)]
^- [xrole xtable]
::
=^ void st (post-xray st %void `%void)
::
=^ i=xkey st
^- [xkey xtable]
%+ (fold ,[xkey xtable] xkey)
[[void st] ~(tap in fork)]
|= [[k=xkey tbl=xtable] branch=xkey]
^- [xkey xtable]
(merge tbl k branch)
::
(xray-xrole st i)
::
:: Return an xray of the union of two xrays.
::
++ merge
|= [st=xtable this=xkey that=xkey]
^- [xkey xtable]
=/ this-xray=xray (focus-on st this)
=/ that-xray=xray (focus-on st that)
?: =(%void type.this-xray) [that st]
?: =(%void type.that-xray) [this st]
(combine st this that)
::
:: =collate-union: merge union maps
::
++ collate-union
|^ |= [st=xtable thick=(map atom xkey) thin=(map atom xkey)]
^- [(map atom xkey) xtable]
::
=/ list=(list (pair atom xkey)) ~(tap by thin)
::
|- ^- [(map atom xkey) xtable]
::
?~ list [thick st]
=/ item=(unit xkey) (~(get by thick) p.i.list)
=^ merged=xkey st ?~ item [q.i.list st]
(merge-instances st p.i.list u.item q.i.list)
=/ new-thick (~(put by thick) p.i.list merged)
$(list t.list, thick new-thick)
::
:: We want to merge two cell-types that have the same head; gross.
::
:: First, get both tail types, merge them, produce a new cell type
:: with the merged tail.
::
++ merge-instances
|= [st=xtable =atom =x=xkey =y=xkey]
^- [xkey xtable]
::
=/ x-xray=xray (focus-on st x-xkey)
=/ x-xdat=xdat (need xdat.x-xray)
|- ^- [xkey xtable]
::
?: ?=([%face *] x-xdat)
$(x-xdat (need xdat:(focus-on st xray.x-xdat)))
?> ?=([%cell *] x-xdat)
=/ x-tail=xkey tail.x-xdat
=/ head-xray=xray (focus-on st head.x-xdat)
::
=/ y-xray=xray (focus-on st y-xkey)
=/ y-xdat=xdat (need xdat.y-xray)
|- ^- [xkey xtable]
::
?: ?=([%face *] y-xdat)
$(y-xdat (need xdat:(focus-on st xray.y-xdat)))
?> ?=([%cell *] y-xdat)
=/ y-tail=xkey tail.y-xdat
::
=^ merged-tail st (merge st x-tail y-tail)
=/ tail-xray=xray (focus-on st merged-tail)
::
=/ res-ty=type [%cell type.head-xray type.tail-xray]
=/ res-xdat=xdat [%cell xkey.head-xray xkey.tail-xray]
=^ res-xkey st (alloc-fork-xray st res-ty res-xdat)
::
=/ res-xray=xray (focus-on st res-xkey)
=. xshape.res-xray `%cell
=. xrole.res-xray `[%instance atom]
=. xrays.st (~(put by xrays.st) res-xkey res-xray)
::
[xkey.res-xray st]
--
::
:: =collate-option: merge option maps
::
++ collate-option
|= [st=xtable thick=(map atom xkey) thin=(map atom xkey)]
^- [(map atom xkey) xtable]
=/ list=(list (pair atom xkey)) ~(tap by thin)
|-
^- [(map atom xkey) xtable]
?~ list [thick st]
=/ item=(unit xkey) (~(get by thick) p.i.list)
=^ merged=xkey st ?~ item [q.i.list st]
(merge st u.item q.i.list)
=/ new-thick (~(put by thick) p.i.list merged)
$(list t.list, thick new-thick)
::
:: Create a new xray that is the union of two xrays, but with a
:: coherent `xrole` (where possible, otherwise a %misjunction).
::
:: This often needs to restructure things. For example, if we are
:: combining `[[~ ~] [%a ~]]` and `[[~ ~] [%b ~]]`, we should produce
:: `[[~ ~] ?%([%a ~] [%b ~])]`.
::
:: This is a massive switch on the xroles of the two arguments. This
:: is *very* easy to get wrong, so I structured things this in a
:: verbose and explicit way, so that you should be able to easily go
:: through each case and verify that it's doing the right thing.
::
++ combine
|^ |= [st=xtable =this=xkey =that=xkey]
^- [xkey xtable]
::
?: =(this-xkey that-xkey) [this-xkey st]
::
=^ this-xrole=xrole st (xray-xrole st this-xkey)
=^ that-xrole=xrole st (xray-xrole st that-xkey)
::
=/ this=[=xkey =xrole] [this-xkey this-xrole]
=/ that=[=xkey =xrole] [that-xkey that-xrole]
::
?: ?=(%void xrole.this) [that-xkey st]
?: ?=(%void xrole.that) [this-xkey st]
?: ?=(%noun xrole.this) (noun-noun st this that)
?: ?=(%noun xrole.that) (noun-noun st that this)
?: ?=([%misjunction *] xrole.this) (misjunkin st this that)
?: ?=([%misjunction *] xrole.that) (misjunkin st this that)
::
?- xrole.that
%atom
?- xrole.this
%atom (atom-atom st that this)
%tall (atom-cell st that this)
%wide (atom-cell st that this)
[%constant *] (atom-atom st that this)
[%instance *] (atom-cell st that this)
[%option *] (atom-optn st that this)
[%union *] (atom-cell st that this)
[%junction *] (atom-junc st that this)
[%conjunction *] (atom-cell st that this)
==
%tall
?- xrole.this
%atom (atom-cell st this that)
%tall (tall-tall st this that)
%wide (wide-tall st this that)
[%constant *] (atom-cell st this that)
[%instance *] (tall-tall st this that)
[%option *] (atom-cell st this that)
[%union *] (tall-tall st this that)
[%junction *] (cell-junc st that this)
[%conjunction *] (tall-conj st that this)
==
%wide
?- xrole.this
%atom (atom-cell st this that)
%tall (wide-tall st that this)
%wide (wide-wide st this that)
[%constant *] (atom-cell st this that)
[%instance *] (wide-tall st this that)
[%option *] (atom-cell st this that)
[%union *] (wide-tall st that this)
[%junction *] (cell-junc st that this)
[%conjunction *] (wide-conj st that this)
==
[%constant *]
?- xrole.this
%atom (atom-atom st that this)
%tall (atom-cell st that this)
%wide (atom-cell st that this)
[%constant *] (cnst-cnst st that this)
[%instance *] (atom-cell st that this)
[%option *] (cnst-optn st that this)
[%union *] (atom-cell st that this)
[%junction *] (atom-junc st that this)
[%conjunction *] (atom-cell st that this)
==
[%instance *]
?- xrole.this
%atom (atom-cell st this that)
%tall (tall-tall st this that)
%wide (wide-tall st this that)
[%constant *] (atom-cell st this that)
[%instance *] (inst-inst st this that)
[%option *] (atom-cell st this that)
[%union *] (inst-unin st that this)
[%junction *] (cell-junc st that this)
[%conjunction *] (tall-conj st that this)
==
[%option *]
?- xrole.this
%atom (atom-optn st this that)
%tall (atom-cell st that this)
%wide (atom-cell st that this)
[%constant *] (cnst-optn st this that)
[%instance *] (atom-cell st that this)
[%option *] (optn-optn st this that)
[%union *] (atom-cell st that this)
[%junction *] (atom-junc st that this)
[%conjunction *] (atom-cell st that this)
==
[%union *]
?- xrole.this
%atom (atom-cell st this that)
%tall (tall-tall st this that)
%wide (wide-tall st this that)
[%constant *] (atom-cell st this that)
[%instance *] (inst-unin st this that)
[%option *] (atom-cell st this that)
[%union *] (unin-unin st this that)
[%junction *] (cell-junc st that this)
[%conjunction *] (tall-conj st that this)
==
[%junction *]
?- xrole.this
%atom (atom-junc st this that)
%tall (cell-junc st this that)
%wide (cell-junc st this that)
[%constant *] (atom-junc st this that)
[%instance *] (cell-junc st this that)
[%option *] (atom-junc st this that)
[%union *] (cell-junc st this that)
[%junction *] (junc-junc st this that)
[%conjunction *] (cell-junc st this that)
==
[%conjunction *]
?- xrole.this
%atom (atom-cell st this that)
%tall (tall-conj st this that)
%wide (wide-conj st this that)
[%constant *] (atom-cell st this that)
[%instance *] (tall-conj st this that)
[%option *] (atom-cell st this that)
[%union *] (tall-conj st this that)
[%junction *] (cell-junc st that this)
[%conjunction *] (conj-conj st this that)
==
==
::
:: This guy ACTUALLY constructs the union type by calling `fork`
:: from `hoon.hoon`. To populate the `xdat` field, we just call
:: `xray-branches` on both of the input xrays and union the result.
::
:: Node that `xray-branches` produces a singleton set when called on
:: a node that isn't a fork, so this works correctly both for
:: joining fork node and non-fork nodes.
::
++ join
|= [st=xtable this=xkey that=xkey]
^- [xkey xtable]
::
?: =(this that) [this st]
::
=/ this-xray=xray (focus-on st this)
=/ that-xray=xray (focus-on st that)
::
=/ union-type=type (fork ~[type.this-xray type.that-xray])
::
=/ this-fork (xray-branches st this)
=/ that-fork (xray-branches st that)
=/ branches (~(uni in this-fork) that-fork)
::
(alloc-fork-xray st union-type [%fork branches])
::
:: Create the join of two xrays with the specified `xrole`.
::
++ joint
|= [st=xtable x=xkey y=xkey =xrole]
^- [xkey xtable]
::
=^ joined=xkey st (join st x y)
=/ jray (focus-on st joined)
=. st (replace-xray st jray(xrole `xrole))
[xkey.jray st]
::
++ atom-atom :: Can't discriminate
|= [st=xtable [x=xkey xrole] [y=xkey xrole]]
(joint st x y [%misjunction x y])
::
++ atom-cell
|= [st=xtable [a=xkey xrole] [c=xkey xrole]]
(joint st a c [%junction a c])
::
++ wide-tall
|= [st=xtable [w=xkey xrole] [t=xkey xrole]]
(joint st w t [%conjunction w t])
::
++ noun-noun :: Can't discriminate
|= [st=xtable [x=xkey xrole] [y=xkey xrole]]
(joint st x y [%misjunction x y])
::
++ misjunkin
|= [st=xtable [x=xkey xrole] [y=xkey xrole]]
(joint st x y [%misjunction x y])
::
++ atom-optn :: Can't discriminate
|= [st=xtable [x=xkey xrole] [y=xkey [%option *]]]
(joint st x y [%misjunction x y])
::
++ cnst-optn
|= $: st=xtable
[x=xkey [%constant xv=atom]]
[y=xkey [%option ym=(map atom xkey)]]
==
=^ res st (collate-option st [[xv x] ~ ~] ym)
(joint st x y [%option res])
::
:: XX If the have the same xkey, produce a new instance who's tail
:: is the union of both tails.
::
++ inst-inst
|= $: st=xtable
[x=xkey [%instance xv=atom]]
[y=xkey [%instance yv=atom]]
==
=^ res st (collate-union st [[xv x] ~ ~] [[yv y] ~ ~])
(joint st x y [%union res])
::
++ inst-unin
|= $: st=xtable
[x=xkey [%instance xv=atom]]
[y=xkey [%union ym=(map atom xkey)]]
==
=^ res st (collate-union st [[xv x] ~ ~] ym)
(joint st x y [%union res])
::
++ junc-junc
|= $: st=xtable
[x=xkey [%junction xflat=xkey xdeep=xkey]]
[y=xkey [%junction yflat=xkey ydeep=xkey]]
==
=^ flat st (merge st xflat yflat)
=^ deep st (merge st xdeep ydeep)
(joint st x y [%junction flat deep])
::
:: XX Justify why this is always a misjunction. What if they have
:: the same head? Wouldn't producing a wide with that head and the
:: union of the two tails be coherent?
::
:: I *can* get the head and the tail of both and merge them,
:: why would this never make sense?
::
++ tall-tall
|= [st=xtable [x=xkey xrole] [y=xkey xrole]]
(joint st x y [%misjunction x y])
::
++ unin-unin
|= $: st=xtable
[x=xkey [%union xm=(map atom xkey)]]
[y=xkey [%union ym=(map atom xkey)]]
==
=^ res st (collate-union st xm ym)
(joint st x y [%union res])
::
:: XX Can this ever produce a coherent result? If it can't, should
:: the result be a misjunction, or should the misjunction instead
:: exist in the wide part of the resulting conjunction (what this
:: code will do)?
::
++ wide-conj
|= $: st=xtable
[x=xkey xrole]
[y=xkey [%conjunction ywide=xkey ytall=xkey]]
==
=^ new-wide st (merge st x ywide)
(joint st x y [%conjunction new-wide ytall])
::
:: XX Justify why this is always a misjunction. What if they have
:: the same head? Wouldn't producing a wide with that head and the
:: union of the two tails be coherent?
::
:: I *can* get the head and the tail and merge
:: them, why would this never make sense?
::
++ wide-wide
|= [st=xtable [x=xkey xrole] [y=xkey xrole]]
(joint st x y [%misjunction x y])
::
++ cnst-cnst
|= $: st=xtable
[x=xkey [%constant xv=atom]]
[y=xkey [%constant yv=atom]]
==
=^ res st (collate-option st [[xv x] ~ ~] [[yv y] ~ ~])
(joint st x y [%option res])
::
++ optn-optn
|= $: st=xtable
[x=xkey [%option xm=(map atom xkey)]]
[y=xkey [%option ym=(map atom xkey)]]
==
=^ res st (collate-option st xm ym)
(joint st x y [%option res])
::
++ tall-conj
|= $: st=xtable
[x=xkey xrole]
[y=xkey [%conjunction ywide=xkey ytall=xkey]]
==
=^ new-tall st (merge st x ytall)
(joint st ywide new-tall [%conjunction ywide new-tall])
::
++ atom-junc
|= $: st=xtable
[x=xkey xrole]
[y=xkey [%junction yflat=xkey ydeep=xkey]]
==
=^ flat-merged st (merge st x yflat)
(joint st flat-merged ydeep [%junction flat-merged ydeep])
::
++ cell-junc
|= $: st=xtable
[x=xkey xrole]
[y=xkey [%junction yflat=xkey ydeep=xkey]]
==
=^ deep-merged st (merge st x ydeep)
(joint st yflat deep-merged [%junction yflat deep-merged])
::
++ conj-conj
|= $: st=xtable
[x=xkey [%conjunction xwide=xkey xtall=xkey]]
[y=xkey [%conjunction ywide=xkey ytall=xkey]]
==
=^ new-wide st (merge st xwide ywide)
=^ new-tall st (merge st xtall ytall)
(joint st new-wide new-tall [%conjunction new-wide new-tall])
::
--
--
::
:: Convert an `ximage` to a spec for printing.
::
++ ximage-to-spec
|= [=top=xkey img=xtable]
^- spec
::
|^ (xray-to-spec ~ top-xkey)
::
+$ trace (set xkey)
::
++ xray-to-spec
|= [tr=trace i=xkey]
^- spec
=/ x=xray (focus-on img i)
=/ d=xdat (need xdat.x)
?: (~(has in tr) i) [%loop (synthetic i)]
?^ recipes.x (recipe-to-spec tr n.recipes.x)
%+ wrap-with-loop-binding x
=. tr (~(put in tr) i)
^- spec
?@ d [%base d]
?- -.d
%atom ?~ constant.d [%base %atom aura.d]
?: &(=(%n aura.d) =(`@`0 u.constant.d)) [%base %null]
[%leaf aura.d u.constant.d]
%cell =/ hd `spec`$(i head.d)
=/ tl `spec`$(i tail.d)
=/ both-basic &(=([%base %noun] hd) =([%base %noun] tl))
?: both-basic [%base %cell]
?: ?=(%bccl -.tl) [%bccl hd +.tl]
[%bccl hd tl ~]
%core =/ payld $(i xray.d)
=/ batt ^- (map term spec)
%- ~(run by (flatten-battery batt.d))
|= =xkey ^$(i xkey)
?- r.garb.d
%lead [%bczp payld batt]
%gold [%bcdt payld batt]
%zinc [%bctc payld batt]
%iron [%bcfs payld batt]
==
%pntr !!
%face =/ =spec $(i xray.d)
?^(face.d spec [%bcts face.d spec])
%fork =/ =xrole (need xrole.x)
|^ ?+ xrole
~& [%unexpected-fork-xrole xkey.x d xrole choices]
[%bcwt choices]
%noun [%base %noun]
%void [%base %void]
[%option *] [%bcwt choices]
[%union *] [%bccn choices]
[%misjunction *] [%bcwt choices]
[%junction *] :+ %bcpt
^$(i flat.xrole)
^$(i deep.xrole)
[%conjunction *] :+ %bckt
^$(i wide.xrole)
^$(i tall.xrole)
==
::
++ choices
^- [i=spec t=(list spec)]
=- ?>(?=(^ -) -)
(turn ~(tap in set.d) |=(=xkey ^^$(i xkey)))
--
==
::
:: If this xray references itself, generate a $$ binding in the output
:: spec, and then we can just reference ourselves by name.
::
++ wrap-with-loop-binding
|= [xr=xray sp=spec]
^- spec
?. (need loop.xr) sp
=/ nm (synthetic xkey.xr)
[%bcbc [%loop nm] [[nm sp] ~ ~]]
::
:: If we have a `recipe`, we can generate much nicer output.
::
++ recipe-to-spec
|= [tr=trace r=recipe]
^- spec
?- -.r
%direct [%like [term.r ~] ~]
%synthetic =/ subs %+ turn list.r
|= =xkey (xray-to-spec tr xkey)
[%make [%limb term.r] subs]
==
::
:: Generate symbols to be used for loop references.
::
:: given a small atom (:number), construct a coresponding symbol
:: using the Hebrew alphabet.
::
++ synthetic
|= number=@ud
^- @tas
=/ alf=(list term)
^~ :~ %alf %bet %gim %dal %hej %vav %zay %het
%tet %yod %kaf %lam %mem %nun %sam %ayn
%pej %sad %qof %res %sin %tav
==
?: (lth number 22)
(snag number alf)
(cat 3 (snag (mod number 22) alf) $(number (div number 22)))
::
:: Batteries in a `spec` do not have chapters, so we just ignore
:: the chapters and flatten the whole battery down to `(map term xkey)`.
::
++ flatten-battery
|= batt=(batt-of xkey)
^- (map term xkey)
=/ chapters ~(tap by batt)
|- ^- (map term xkey)
?~ chapters ~
(~(uni by q.q.i.chapters) $(chapters t.chapters))
::
--
::
:: Left-fold over a list.
::
:: This is `roll`, but with explicit type parameters.
::
++ fold
|* [state=mold elem=mold]
|= [[st=state xs=(list elem)] f=$-([state elem] state)]
^- state
|-
?~ xs st
$(xs t.xs, st (f st i.xs))
::
:: This is basically a `mapM` over a list using the State monad.
::
:: Another way to think about this is that it is the same as `turn`,
:: except that a state variable `st` is threaded through the
:: execution. The list is processed from left to right.
::
:: This is `spin`, but with explicit type parameters.
::
++ traverse
|* [state=mold in=mold out=mold]
|= [[st=state xs=(list in)] f=$-([state in] [out state])]
^- [(list out) state]
?~ xs [~ st]
=^ r st (f st i.xs)
=^ rs st $(xs t.xs, st st)
[[r rs] st]
::
:: `traverse` over a set.
::
++ traverse-set
|* [state=mold input=mold out=mold]
|= [[st=state xs=(set input)] f=$-([state input] [out state])]
^- [(set out) state]
::
=^ elems st ((traverse state input out) [st ~(tap in xs)] f)
:_ st (~(gas in *(set out)) elems)
::
:: `traverse` over a map, also passing the key to the folding function.
::
++ traverse-map
|* [state=mold key=mold in=mold out=mold]
|= [[st=state dict=(map key in)] f=$-([state key in] [out state])]
^- [(map key out) state]
::
=^ pairs=(list (pair key out)) st
%+ (traverse state (pair key in) (pair key out))
[st ~(tap by dict)]
|= [st=state k=key x=in]
^- [(pair key out) state]
=^ v st (f st k x)
[[k v] st]
::
:_ st
(~(gas by *(map key out)) pairs)
::
:: Given a map, return its inverse: For each value, what are the set
:: of associated keys?
::
++ reverse-map
|* [key=mold val=mold]
|= tbl=(map key val)
=/ init *(map val (set key))
^- _init
%+ (fold _init (pair key val))
[init ~(tap by tbl)]
|= [acc=_init k=key v=val]
^- _init
=/ mb-keys (~(get by acc) v)
=/ keys=(set key) ?~(mb-keys ~ u.mb-keys)
(~(put by acc) v (~(put in keys) k))
--