ilyakooo0/urbit
1
0
Fork 0
mirror of https://github.com/ilyakooo0/urbit.git synced 2024-09-20 15:08:34 +03:00
Code Issues Packages Projects Releases Wiki Activity
7e4ad62a51
urbit/pkg/arvo/lib/pprint.hoon
Joe Bryan 17f95c0cb6 Merge branch 'm/remove-ketcen' into m/modern-hoon 
* m/remove-ketcen:
  u3: removes .fab from |ut hooks
  hoon: patch up +ax callsites
  u3: WIP removes fab:ut
  hoon: WIP remove fab:ut
  hoon: remove ^%
2020-11-30 20:08:17 -08:00

1203 lines
34 KiB
Plaintext
Raw Blame History

/- *plum, *xray
/+ *plume,
libxray=xray
::
:: This code pretty-prints a variety of things using the `xray` and
:: `plum` libraries:
::
:: - `render-vase`: Renders the data in a vase.=$-(vase wain)
:: - `render-hoon`: Pretty-prints a `hoon` AST as hoon code.
:: - `render-type`: Pretty-prints a type as a hoon expression.
:: - `render-type-simple`: Debug-print for the `type` structure.
:: - `render-vase-with-type`: Pretty print a vase: both value and type.
::
:: There's a lot of logic here, but most of it is fairly
:: straight-forward.
::
:: XX Output for cords is ugly. Why ~~a instead of 'a'?
::
|^ ^- $: render-vase=$-(vase wain)
render-hoon=$-(hoon wain)
render-type=$-(type wain)
type-to-plum=$-(type plum)
type-to-tank=$-(type tank)
vase-to-tank=$-(vase tank)
render-type-simple=$-(type wain)
render-vase-with-type=$-(vase wain)
==
:* render-vase
render-hoon
render-type
type-to-plum
type-to-tank
vase-to-tank
render-type-simple
render-vase-with-type
==
::
+| %utils
::
+$ battery (map term (pair what (map term hoon)))
::
+| %render
::
++ render-vase-with-type
|= =vase
^- wain
::
=/ =ximage (xray-type:libxray 1 p.vase)
::
:: ~& %noun-to-plum
=/ val=plum (noun-to-plum ximage q.vase)
::
:: ~& %type-to-plum
=/ typ=plum (spec-to-plum (ximage-to-spec:libxray ximage))
::
=/ result=plum
(sexp 'vase' (sexp 'type' typ ~) (sexp 'val' val ~) ~)
::
:: ~& %convert-to-wain
~(tall plume result)
::
++ render-vase
|= =vase
^- wain
~(tall plume (vase-to-plum vase))
::
++ render-type-simple
|= =type
^- wain
~(tall plume (type-to-plum-simple type 100))
::
++ render-type
|= =type ^- wain
~(tall plume (type-to-plum type))
::
:: Pretty-print a hoon.
::
++ render-hoon
|= =hoon ^- wain
~(tall plume (hoon-to-plum 999 hoon))
::
:: Pretty-print a type given as a string.
::
++ render-type-from-cord
|= =cord ^- wain
=/ t=type -:(ride -:!>(..libxray) cord)
~(tall plume (type-to-plum t))
::
:: This is just a helper function for testing out this code. It just digs
:: through a type and finds hoon values referenced within that type,
:: and then renders the result.
::
++ render-all-hoons-inside-of-type
|= =type
^- wain
?. ?=([%core *] type) [%zpzp ~]
=* tomes=(list tome) ~(val by q.r.q.type)
=* hoons=(list hoon) (turn tomes |=(t=tome [%cltr ~(val by q.t)]))
~(tall plume (hoon-to-plum 999 [%cltr hoons]))
::
+| %to-plum
::
:: Pretty-print a vase.
::
++ vase-to-plum
|= v=vase
^- plum
(noun-to-plum (xray-type:libxray 1 p.v) q.v)
::
:: Pretty-print a type.
::
++ type-to-plum
|= t=type
^- plum
(spec-to-plum (ximage-to-spec:libxray (xray-type:libxray 1 t)))
::
:: Pretty-print a type to a tank.
::
++ type-to-tank
|= t=type
^- tank
:+ %rose [~ ~ ~]
%+ turn (render-type t)
|=(=cord leaf+(trip cord))
::
:: Pretty-print a vase to a tank.
::
++ vase-to-tank
|= v=vase
^- tank
:+ %rose [~ ~ ~]
%+ turn (render-vase v)
|=(=cord leaf+(trip cord))
::
:: Render an `axis`.
::
++ axis-to-cord
|= p=@
^- cord
?: =(p 1) '.'
?: =(p 2) '-'
?: =(p 3) '+'
(cat 3 '+' (scot %ud p))
::
:: Render a limb. A limb is either an empty atom (which is rendered as
:: '$') or an axis.
::
:: XX The code for handling the `%|` ("by name") case is obviously
:: wrong (the `runt` call does nothing, for example), but I'm not sure
:: what it was trying to do in the first place.
::
++ limb-to-plum
|= =limb
^- plum
?@ limb
?: .=('' limb) '$'
limb
?- -.limb
%& (axis-to-cord p.limb)
:: [%| p=@ud q=(unit term) ]
%| (crip (runt [0 p.limb] ?~(q.limb "," (trip u.q.limb))))
==
::
:: Render a wing
::
++ wing-to-plum
|= =wing
^- plum
:+ %tree
[wide=`['.' ~] tall=~]
(turn `^wing`wing limb-to-plum)
::
:: In the spec for a battery, there's a `(map term spec)`. This
:: transforms one of those into a list of plums, one per `term/spec`
:: pair.
::
++ battery-spec-to-plum-list
|= =(map term spec)
%+ turn ~(tap by map)
|= [=term =spec]
:- %sbrk
:+ %tree
[wide=~ tall=`['' ~]]
[term (spec-to-plum spec) ~]
::
:: Given a rune and a spec for a core, transform that into a plum.
::
++ core-spec-to-plum
|= [=knot =spec =(map term spec)]
^- plum
:- %sbrk
:+ %tree
[~ `[knot ~]]
:~ (spec-to-plum spec)
:+ %tree
[~ tall=`['' `['++' '--']]]
(battery-spec-to-plum-list map)
==
::
:: Convert a "standard name" into a plum.
::
++ stud-to-plum
|= =stud
^- plum
?@ stud stud
:+ %tree
[wide=`['/' ~] tall=~]
`(list plum)`[auth.stud type.stud]
::
:: Convert a woof (an interpolated expression inside of a string literal)
:: to a plum.
::
++ woof-to-plum
|= =woof
^- plum
|^ ?@ woof woof
=* fmt [wide=`[' ' `['{' '}']] tall=~]
:+ %tree fmt
(turn (unwrap-woof-tuple +.woof) |=(h=hoon (hoon-to-plum 999 h)))
::
:: Woofs contain one or more hoons, and if there are more than one,
:: it's encoded with a %cltr ast node. This just simplifies both
:: cases down into a list of subhoons.
::
++ unwrap-woof-tuple
|= =hoon
^- (list ^hoon)
?: ?=([%cltr *] hoon)
p.hoon
~[hoon]
--
::
:: This is just a trivial helper function. It's only here because this
:: xpat is used repeatedly in `hoon-to-plum`.
::
++ hoons-to-plum-list
|= =hoon=(list hoon)
^. (list plum)
(turn hoon-list |=(h=hoon (hoon-to-plum 999 h)))
::
:: XX Placeholder for rendering a chum to a plum.
::
++ chum-to-plum
|= =chum
^- plum
%todo-chum
::
:: XX Placeholder for rendering a tyre to a plum
::
++ tyre-to-plum
|= =tyre
^- plum
%todo-tyre
::
:: Generate a list of plums from a list of matches. This would be
:: trivial, but we also need to append commas on each match (besides
:: the last) when `matches` is rendered in wide mode.
::
++ matches-to-plum-list
|= matches=(list (pair spec hoon))
^- (list plum)
%- add-trailing-commas-to-wide-form
%+ turn matches
|= [=spec =hoon]
^- (pair plum plum)
[(spec-to-plum spec) (hoon-to-plum 999 hoon)]
::
:: Generate a list of plums from a list of updates. This would be
:: trivial, but we also need to append commas on each update (besides
:: the last) when the update-list is rendered in wide mode.
::
++ updates-to-plum-list
|= =update=(list (pair wing hoon))
^- (list plum)
%- add-trailing-commas-to-wide-form
%+ turn update-list
|= [=wing =hoon]
^- (pair plum plum)
[(wing-to-plum wing) (hoon-to-plum 999 hoon)]
::
:: This adds commas to a list of pair of hoons, but only in wide form.
::
:: For example, in wide form with commas:
::
:: %=($ a 1, b 2)
::
:: In tall form without commas:
::
:: %= $ a 1 b 2 ==
::
:: It's important that this not be wrapped in an %sbrk, since we need
:: to be sure that this is rendered in wide mode if-and-only-if our
:: parent is rendered in wide mode.
::
++ add-trailing-commas-to-wide-form
|= plums=(list (pair plum plum))
=| acc=(list (list plum))
|^ ^- (list plum)
?~ plums (zing (flop acc))
=/ x=plum p.i.plums
=/ y=plum q.i.plums
?~ t.plums
$(plums t.plums, acc [~[x y] acc])
$(plums t.plums, acc [~[x (comma y)] acc])
++ comma
|= =sub=plum
^- plum
:+ %tree
:- [~ '' [~ '' ',']] [~ '' ~]
~[sub-plum]
--
::
:: Render a hoon as a plum. Given the helper functions above, this is
:: fairly straightforward. It is a big-ass switch, though.
::
++ hoon-to-plum
|= [maxdepth=@ x=hoon]
|^ ^- plum
?+ x
%autocons
[%$ @] (axis-to-cord p.x)
[%base *] (spec [%base p.x])
[%bust *] (simple-wide '*' '' '' (spec [%base p.x]) ~)
[%dbug *] (hn q.x) :: p.x is irrelevant
[%eror *] %assembly-error
[%hand *] %ast-node-hand
[%note *] (hn q.x) :: p.x is irrelevant
[%fits *] %ast-node-fits
[%knit *] (simple-wide '"' '' '"' (turn p.x woof-to-plum))
[%leaf *] (spec x)
[%limb *] p.x
[%lost *] (hn p.x) :: for internal use
[%rock *] ?^ q.x !! (cat 3 '%' (crip (scow p.x `@`q.x)))
[%sand *] ?^ q.x !! (crip (scow p.x `@`q.x))
[%tell *] (simple-wide '<' ' ' '>' (hoons p.x))
[%tune *] ?@(p.x p.x %todo-tune)
[%wing *] (simple-wide '' '.' '' (turn p.x limb))
[%yell *] (simple-wide '>' ' ' '<' (hoons p.x))
[%xray *] (xray-to-plum p.x)
[%brcb *] (chapter '|_' `(spec p.x) r.x) :: skip aliases
[%brcl *] (rune '|:' ~ ~ (hoons ~[p q]:x))
[%brcn *] (chapter '|%' ~ q.x) :: Ignoring p.x
[%brdt *] (rune '|.' ~ ~ (hoons ~[p]:x))
[%brkt *] (chapter '|^' `(hn p.x) q.x)
[%brhp *] (rune '|-' ~ ~ (hn p.x) ~)
[%brsg *] (rune '|~' ~ ~ (spec p.x) (hn q.x) ~)
[%brtr *] (rune '|*' ~ ~ (spec p.x) (hn q.x) ~)
[%brts *] (rune '|=' ~ ~ (spec p.x) (hn q.x) ~)
[%brpt *] (chapter '|@' ~ q.x) :: Ignoring p.x
[%brwt *] (rune '|?' ~ ~ (hn p.x) ~)
[%clcb *] (rune ':_' ~ ~ (hoons ~[p q]:x))
[%clkt *] (rune ':^' ~ ~ (hoons ~[p q r s]:x))
[%clhp *] (rune ':-' ~ `['[' spc ']'] (hoons ~[p q]:x))
[%clls *] (rune ':+' ~ `['[' spc ']'] (hoons ~[p q r]:x))
[%clsg *] (rune ':~' `'==' `['~[' spc ']'] (hoons p.x))
[%cltr *] ?~ p.x '~'
?~ +.p.x (hn -.p.x)
(rune ':*' `'==' `['[' spc ']'] (hoons p.x))
[%cncb *] (rune '%_' `'==' ~ (wing p.x) (updates q.x))
[%cndt *] (rune '%.' ~ ~ (hoons ~[p q]:x))
[%cnhp *] (rune '%-' ~ `['(' spc ')'] (hoons ~[p q]:x))
[%cncl *] (rune '%:' `'==' `['(' spc ')'] (hoons [p q]:x))
[%cntr *] (rune '%*' `'==' ~ (wing p.x) (hn q.x) (updates r.x))
[%cnkt *] (rune '%^' ~ ~ (hoons ~[p q r s]:x))
[%cnls *] (rune '%+' ~ ~ (hoons ~[p q r]:x))
[%cnsg *] (rune '%~' `'==' `['~(' spc ')'] (wing p.x) (hoons [q r]:x))
[%cnts *] ?~ q.x (wing p.x)
(rune '%=' `'==' ~ (wing p.x) (updates q.x))
[%dtkt *] (rune '.^' ~ ~ (spec p.x) (hn q.x) ~)
[%dtls *] (rune '.+' ~ `['+(' spc ')'] (hoons ~[p]:x))
[%dttr *] (rune '.*' ~ ~ (hoons ~[p q]:x))
[%dtts *] (rune '.=' ~ `['=(' spc ')'] (hoons ~[p q]:x))
[%dtwt *] (rune '.?' ~ ~ (hoons ~[p.x]))
[%ktbr *] (rune '^|' ~ ~ (hoons ~[p.x]))
[%ktdt *] (rune '^.' ~ ~ (hoons ~[p q]:x))
[%ktls *] (rune '^+' ~ ~ (hoons ~[p q]:x))
[%kthp *] (rune '^-' ~ ~ ~[(spec p.x) (hn q.x)])
[%ktpm *] (rune '^&' ~ ~ (hoons ~[p]:x))
[%ktsg *] (rune '^~' ~ ~ (hoons ~[p]:x))
[%ktts *] (rune '^=' ~ `['' '=' ''] ~[(skin p.x) (hn q.x)])
[%ktwt *] (rune '^?' ~ ~ (hoons ~[p]:x))
[%kttr *] (rune '^*' ~ ~ ~[(spec p.x)])
[%ktcl *] (rune '^:' ~ ~ ~[(spec p.x)])
[%sgbr *] (rune '~|' ~ ~ (hoons ~[p q]:x))
[%sgcb *] (rune '~_' ~ ~ (hoons ~[p q]:x))
[%sgcn *] (rune '~%' ~ ~ (chum p.x) (hn q.x) (tyre r.x) (hn s.x) ~)
[%sgfs *] (rune '~/' ~ ~ (chum p.x) (hn q.x) ~)
[%sggl *] (rune '~<' ~ ~ (hint p.x) (hn q.x) ~)
[%sggr *] (rune '~>' ~ ~ (hint p.x) (hn q.x) ~)
[%sgbc *] (rune '~$' ~ ~ p.x (hn q.x) ~)
[%sgls *] (rune '~+' ~ ~ (hn q.x) ~) :: Ignoring p.x
[%sgpm *] (rune '~&' ~ ~ (hoons ~[q r]:x)) :: Ignoring p.x
[%sgts *] (rune '~=' ~ ~ (hoons ~[p q]:x))
[%sgwt *] (rune '~?' ~ ~ (hoons ~[q r s]:x)) :: Ignoring p.x
[%sgzp *] (rune '~!' ~ ~ (hoons ~[p q]:x))
[%mcts *] %ast-node-mcts
[%mccl *] (rune ';:' `'==' `[':(' spc ')'] (hoons [p q]:x))
[%mcfs *] (rune ';/' ~ ~ (hoons ~[p]:x))
[%mcgl *] (rune ';<' ~ ~ (spec p.x) (hoons ~[q r s]:x))
[%mcsg *] (rune ';~' `'==' ~ (hoons [p q]:x))
[%mcmc *] (rune ';;' ~ ~ ~[(spec p.x) (hn q.x)])
[%tsbr *] (rune '=|' ~ ~ ~[(spec p.x) (hn q.x)])
[%tscl *] (tiscol-to-plum p.x q.x)
[%tsfs *] (rune '=/' ~ ~ (skin p.x) (hn q.x) (hn r.x) ~)
[%tsmc *] (rune '=;' ~ ~ [(skin p.x) (hoons ~[q r]:x)])
[%tsdt *] (rune '=.' ~ ~ [(wing p.x) (hoons ~[q r]:x)])
[%tswt *] (rune '=?' ~ ~ [(wing p.x) (hoons ~[q r s]:x)])
:: XX %tsld to %tsgl, but should be %tsgr? (to match =>)
[%tsgl *] (rune '=>' ~ `['' ':' ''] (hoons ~[p q]:x))
[%tshp *] (rune '=-' ~ ~ (hoons ~[p q]:x))
:: XX %tsbn to %tsgr, but should be %tsgl? (to match =<)
[%tsgr *] (rune '=<' ~ ~ (hoons ~[p q]:x))
[%tskt *] (rune '=^' ~ ~ [(skin p.x) (wing q.x) (hoons ~[r s]:x)])
[%tsls *] (rune '=+' ~ ~ (hoons ~[p q]:x))
[%tssg *] (rune '=~' `'==' ~ (hoons p:x))
[%tstr *] ?~ q.p.x
(rune '=*' ~ ~ p.p.x (hoons ~[q r]:x))
(rune '=*' ~ ~ (spec [%bcts p.p.x u.q.p.x]) (hoons ~[q r]:x))
[%tscm *] (rune '=,' ~ ~ (hoons ~[p q]:x))
[%wtbr *] (rune '?|' `'--' `['|(' ' ' ')'] (hoons p:x))
[%wthp *] (rune '?-' `'==' ~ (wing p.x) (matches q.x))
[%wtcl *] (rune '?:' ~ ~ (hoons ~[p q r]:x))
[%wtdt *] (rune '?.' ~ ~ (hoons ~[p q r]:x))
[%wtkt *] (rune '?^' ~ ~ [(wing p.x) (hoons ~[q r]:x)])
[%wtgl *] (rune '?<' ~ ~ (hoons ~[p q]:x))
[%wtgr *] (rune '?>' ~ ~ (hoons ~[p q]:x))
[%wtls *] (rune '?+' `'==' ~ (wing p.x) (hn q.x) (matches r.x))
[%wtpm *] (rune '?&' `'==' `['&(' ' ' ')'] (hoons p:x))
[%wtpt *] (rune '?@' ~ ~ (wing p.x) (hoons ~[q r]:x))
[%wtsg *] (rune '?~' ~ ~ (wing p.x) (hoons ~[q r]:x))
[%wthx *] (rune '?#' ~ ~ (skin p.x) (wing q.x) ~)
[%wtts *] (rune '?=' ~ ~ (spec p.x) (wing q.x) ~)
[%wtzp *] (rune '?!' ~ `['!' '' ''] (hoons ~[p]:x))
[%zpcm *] (rune '!,' ~ ~ (hoons ~[p q]:x))
[%zpgr *] (rune '!>' ~ ~ (hoons ~[p]:x))
[%zpmc *] (rune '!;' ~ ~ (hoons ~[p q]:x))
[%zpts *] (rune '!=' ~ ~ (hoons ~[p]:x))
[%zppt *] (rune '!@' ~ ~ (wingseq p.x) (hoons ~[q r]:x))
[%zpwt *] (hn q.x) :: Ignore p.x
[%zpzp ~] '!!'
==
++ hoons hoons-to-plum-list
++ battery battery-to-plum-list
++ chapter chapters-to-plum
++ chum chum-to-plum
++ hint hint-to-plum
++ hn |= h=hoon (hoon-to-plum (dec maxdepth) h)
++ limb limb-to-plum
++ matches matches-to-plum-list
++ skin skin-to-plum
++ spc ' '
++ spec spec-to-plum
++ tyre tyre-to-plum
++ updates updates-to-plum-list
++ wing wing-to-plum
++ wingseq wingseq-to-plum
::
:: Here's an example of what a hint looks like.
::
:: ~>(%mean.[%leaf "need"] !!)
::
:: The actual form that we're printing here looks something like this:
::
:: %mean.[%leaf "need"]
::
:: XX I'm not sure if the `[%leaf "need"]` bit represents a literal
:: AST fragment or an expression that evaluates to `[%leaf "need"]`. I'm
:: going to assume the latter for now.
::
++ tiscol-to-plum
|= [updates=(list [^wing hoon]) body=hoon]
^- plum
=/ rem=(list (pair ^wing hoon)) updates :: Note [TisCol Order]
=/ acc=hoon body
%+ hoon-to-plum (dec maxdepth)
|- ^- hoon
?~ rem acc
$(rem t.rem, acc `hoon`[%tsdt `^wing`p.i.rem `hoon`q.i.rem `hoon`acc])
::
:: Note [TisCol Order]
:: ~~~~~~~~~~~~~~~~~~~
:: By accumulating over the updates list from the front, we are
:: effectively reversing the assignment order of the forms in `.=`.
:: This is semantically correct:
::
:: > =a 3
:: > =b 4
:: > =: a 4 b a == b
:: 3
:: > +hoon-printer !, *hoon =: a 4 b a == b
:: <|=.(b a =.(a 4 b))|>
:: > =.(a 4 =.(b a b))
:: 4
:: > =.(b a =.(a 4 b))
:: 3
--
::
:: Pretty-print a hint.
::
++ hint-to-plum
|= hint=$@(term (pair term hoon))
^- plum
?@ hint (cat 3 '%' hint)
:+ %tree
[wide=`['.' ~] tall=~]
:~ (cat 3 '%' p.hint)
(hoon-to-plum 999 q.hint)
==
::
:: Pretty-print a hoon battery.
::
++ battery-to-plum-list
|= =(map term hoon)
^- (list plum)
%+ turn ~(tap by map)
|= [=term =hoon]
=/ fmt [wide=`[' ' ~] tall=`['' ~]]
:- %sbrk
:+ %tree fmt
[term (hoon-to-plum 999 hoon) ~]
::
:: Pretty-print a core.
::
++ core-to-plum
|= [=knot head=(unit plum) =(map term hoon)]
^- plum
=* kids (battery-to-plum-list map)
:- %sbrk
:- %tree
?~ head
:- [~ `[knot `['++' '--']]]
kids
:- [~ `[knot ~]]
:~ u.head
=* battery-fmt [~ `['' `['++' '--']]]
[%tree battery-fmt kids]
==
::
:: XX Document this
::
:: XX What's a cleaner way to implement this?
::
++ chapters-to-plum
|= [=knot head=(unit plum) =(map term tome)]
^- plum
=/ chapters=(list (pair term tome)) ~(tap by map)
=* with-chapters (chapters-to-plum-verbose knot head map)
=* without-chaps (core-to-plum knot head q.q.i.chapters)
?~ chapters with-chapters
?~ t.chapters
?: .=('' p.i.chapters) without-chaps
with-chapters
with-chapters
::
:: XX Document this.
::
++ chapters-to-plum-verbose
|= [=knot head=(unit plum) =(map term tome)]
^- plum
=/ chaps=(list (pair term tome))
~(tap by map)
:+ %tree
[~ `[knot `['' '--']]]
=/ kids=(list plum)
%+ turn chaps
chapter-to-plum
?~ head kids
[u.head kids]
::
:: XX Document this.
::
++ chapter-to-plum
|= [nm=knot [* bat=(map term hoon)]]
^- plum
:+ %tree
[~ `['+|' ~]]
:~ (cat 3 '%' nm)
:+ %tree
[~ `['' `['++' '']]]
(battery-to-plum-list bat)
==
::
:: XX Document this.
::
++ chapters-to-plum-list
|= =(map term tome)
^- (list plum)
%+ turn ~(tap by map)
|= [=term [* hoons=(^map term hoon)]]
^- plum
?: =(term '')
:+ %tree [wide=~ tall=[~ '' ~]] (battery-to-plum-list hoons)
(rune '+|' ~ ~ [(cat 3 '%' term) (battery-to-plum-list hoons)])
::
:: XX Document this.
::
++ xray-to-plum
|= =manx:hoot
^- plum
%ast-node-xray :: XX Punt
::
:: Render a plum to a skin.
::
++ skin-to-plum
|= =skin
^- plum
?@ skin skin
%todo-complex-skin :: XX Punt
::
:: Render a list of wings a plum that looks something like "a:b:c"
::
++ wingseq-to-plum
|= =(list wing)
^- plum
=* fmt [wide=`[':' ~] tall=~]
[%tree fmt (turn list wing-to-plum)]
::
:: Renders a spec to a plum. Similarly to `hoon-to-plum`, given all of
:: the helper functions this becomes quite simple. It does have a lot of
:: cases, though.
::
++ spec-to-plum
|^ |= =spec
^- plum
?- -.spec
%base ?- p.spec
%noun '*'
%cell '^'
%flag '?'
%null '~'
%void '!!'
[%atom *] (cat 3 '@' p.p.spec)
==
%dbug $(spec q.spec)
%leaf =+((scot p.spec q.spec) ?:(=('~' -) - (cat 3 '%' -)))
%like tree/[[`[':' ~] ~] (turn `(list wing)`+.spec wing-to-plum)]
%loop (cat 3 '$' p.spec)
%name $(spec q.spec)
%made $(spec q.spec)
%over $(spec q.spec)
%make =+ (lent q.spec)
:- %sbrk
:+ %tree
:- wide=`[' ' `['(' ')']]
:- ~
?: |((gth - 3) =(- 0))
['%:' `['' '==']]
:_ ~
?: =(- 3) '%^'
?: =(- 2) '%+' '%-'
[(dohoon p.spec) (turn q.spec ..$)]
%bcbc (core-spec-to-plum '$$' p.spec q.spec)
%bcbr (subtree (fixed '$|') $(spec p.spec) (dohoon q.spec) ~)
%bccb (dohoon p.spec)
%bccl :- %sbrk
:+ %tree
[`[' ' `['[' ']']] `['$:' `['' '==']]]
(turn `(list ^spec)`+.spec ..$)
%bccn (subtree (varying '$%' '==') (turn `(list ^spec)`+.spec ..$))
%bcdt (core-spec-to-plum '$.' p.spec q.spec)
%bcgl (subtree (fixed '$<') $(spec p.spec) $(spec q.spec) ~)
%bcgr (subtree (fixed '$>') $(spec p.spec) $(spec q.spec) ~)
%bchp (subtree (fixed '$-') $(spec p.spec) $(spec q.spec) ~)
%bckt (subtree (fixed '$^') $(spec p.spec) $(spec q.spec) ~)
%bcls (subtree (fixed '$+') (stud-to-plum p.spec) $(spec q.spec) ~)
%bcfs (core-spec-to-plum '$/' p.spec q.spec)
%bcmc (subtree (fixed '$;') (dohoon p.spec) ~)
%bcpm (subtree (fixed '$&') $(spec p.spec) (dohoon q.spec) ~)
%bcsg (subtree (fixed '$~') (dohoon p.spec) $(spec q.spec) ~)
%bctc (core-spec-to-plum '$`' p.spec q.spec)
%bcts :- %sbrk
:+ %tree
[`['=' ~] `['$=' ~]]
:~ (skin-to-plum p.spec)
$(spec q.spec)
==
%bcpt (subtree (fixed '$@') $(spec p.spec) $(spec q.spec) ~)
%bcwt :- %sbrk
:+ %tree
[`[' ' `['?(' ')']] `['$?' `['' '==']]]
(turn `(list ^spec)`+.spec ..$)
%bczp (core-spec-to-plum '$.' p.spec q.spec)
==
::
++ varying
|= [intro=knot final=knot]
[`[' ' `[(cat 3 intro '(') ')']] `[intro `['' final]]]
::
++ dohoon
|= h=hoon (hoon-to-plum 999 h)
::
--
::
++ noun-to-plum
|= [xt=ximage =top=noun]
^- plum
::
=/ img xtable.xt
::
|^ (main root.xt top-noun)
::
++ main
|= [i=xkey n=*]
^- plum
=/ x=xray (focus-on:libxray img i)
?~ pats.x (render-with-xdat i (need xdat.x) n)
(render-with-xpat u.pats.x n)
::
++ tree-noun-to-list
|= n=*
^- (list *)
?@ n ~
:- -.n
%- zing
:~ (tree-noun-to-list +.+.n)
(tree-noun-to-list -.+.n)
==
::
++ noun-to-list
|= n=*
^- (list *)
?@ n ~
[-.n $(n +.n)]
::
++ render-tree
|= [elt=xkey noun=*]
^- plum
?~ noun '~'
=/ ns=(list *) (tree-noun-to-list noun)
=/ ps=(list plum) (turn ns |=(n=* (main elt n)))
=/ elems=plum (rune ':~' `'==' `['~[' ' ' ']'] ps)
(rune '%-' ~ `['(' ' ' ')'] ~['tree' elems])
::
++ render-list
|= [elt=xkey noun=*]
^- plum
?~ noun '~'
=/ ns=(list *) (noun-to-list noun)
=/ ps=(list plum) (turn ns |=(n=* (main elt n)))
(rune ':~' `'==' `['~[' ' ' ']'] ps)
::
++ render-unit
|= [i=xkey n=*]
^- plum
?~ n '~'
(tuple-plum ~['~' (main i +:n)])
::
++ tuple-plum
|= kids=(list plum)
^- plum
=/ n (lent kids)
(rune ':*' `['=='] `['[' ' ' ']'] kids)
::
++ render-atom
|= [=aura =atom]
^- cord
?: =(aura '')
(scot %ud atom)
(scot aura atom)
::
++ render-const
|= [=aura const=@ =atom]
^- plum
?: =(~.n aura) '~'
(cat 3 '%' (render-atom aura atom))
::
++ untyped-noun :: XX Where is the existing code for doing this?
|= [n=*] :: Can I just use that?
^- plum
?@ n (render-atom 'ud' n)
(tuple-plum ~[(untyped-noun -:n) (untyped-noun +:n)])
::
++ render-tuple
|= [i=xkey n=*]
^- plum
=/ acc=(list plum) ~
%- tuple-plum
%- flop
|-
^- (list plum)
::
=/ x=xray (focus-on:libxray img i)
=/ d=xdat (need xdat.x)
::
?^ pats.x [(main i n) acc]
?. ?=([%cell *] d) [(main i n) acc]
%= $
acc [(main head.d -:n) acc]
n +:n
i tail.d
==
::
++ render-with-xdat
|= [i=xkey d=xdat n=*]
^- plum
?- d
%void '!!'
%noun (untyped-noun n)
[%cell *] (render-tuple i n)
[%atom *] ?^ n ~& [%not-an-atom i d n] !!
?~ constant.d (render-atom aura.d n)
(render-const aura.d u.constant.d n)
[%face *] (main xray.d n)
[%pntr *] !!
[%core *] (render-core garb.d xray.d batt.d)
[%fork *] (render-fork i n)
==
::
++ render-fork
|= [i=xkey n=*]
^- plum
::
=/ x=xray (focus-on:libxray img i)
?~ xrole.x ~& x '%evil-fork'
=/ r=xrole u.xrole.x
::
?- r
%void !!
%noun !!
%atom !!
%tall !!
%wide !!
[%constant *] !!
[%instance *] !!
[%union *]
:: ~& %render-union
?> ?=(^ n)
=/ hd=* -:n
?> ?=(@ hd)
::
=/ pairs=(list (pair atom xkey)) ~(tap by map.r)
|-
?~ pairs '%bad-union-fork'
?. =(p.i.pairs hd) $(pairs t.pairs)
(main q.i.pairs n)
[%option *]
:: ~& %render-option
=/ pairs=(list (pair atom xkey)) ~(tap by map.r)
|-
?~ pairs '%bad-option-fork'
?. =(p.i.pairs n) $(pairs t.pairs)
(main q.i.pairs n)
[%junction *]
:: ~& %render-junction
(main ?@(n flat.r deep.r) n)
[%conjunction *]
:: ~& %render-conjunction
?> ?=(^ n)
=/ hd=* -:n
(main ?@(hd tall.r wide.r) n)
[%misjunction *]
:: ~& %render-misjunction
'%misjunction'
==
::
++ render-gate
|= [=sample=xkey =product=xkey]
^- plum
%- spec-to-plum :*
%bchp
(ximage-to-spec:libxray sample-xkey img)
(ximage-to-spec:libxray product-xkey img)
==
::
++ render-core
|= [=garb xray=xkey =xbat]
^- plum
::
=/ cvt-arms
|= m=(map term xkey)
^- (map term hoon)
%- ~(gas by *(map term hoon))
%+ turn ~(tap by m)
|= [t=term i=xkey]
=. t ?:(=('' t) '$' t)
^- [term hoon]
:- t
[%zpzp ~]
::
=/ batt=(map term tome)
%- ~(gas by *(map term tome))
%+ turn ~(tap by xbat)
|= [nm=term w=what arms=(map term xkey)]
[nm w (cvt-arms arms)]
::
(hoon-to-plum 999 [%brcn p.garb batt])
::
++ path-to-plum
|= =path
^- plum
=/ fmt=plumfmt [[~ '/' [~ '/' '']] ~]
[%tree fmt path]
::
++ nock-to-plum
|= n=nock
^- plum
(untyped-noun n)
::
++ tour-to-plum
|= t=tour
^- plum
'%tour' :: XX TODO
::
++ render-with-xpat
|= [p=xpat n=*]
^- plum
?- p
%hoon (hoon-to-plum 999 ;;(hoon n))
%json (json-to-plum ;;(json n))
%manx (manx-to-plum ;;(manx n))
%nock (nock-to-plum ;;(nock n))
%path (path-to-plum ;;(path n))
%plum ;;(plum n)
%skin (skin-to-plum ;;(skin n))
%spec (spec-to-plum ;;(spec n))
%tape (tape-to-plum ;;(tape n))
%tour (tour-to-plum ;;(tour n))
%type =/ ttp type-to-plum
;;(plum .*(ttp(+< n) [9 2 0 1]))
%vase =/ vtp vase-to-plum
=/ =plum ;;(plum .*(vtp(+< n) [9 2 0 1]))
(rune '!>' ~ ~ ~[plum])
[%gate *] (render-gate sample.p product.p)
[%gear *] '%gear' :: XX TODO
[%list *] (render-list item.p n)
[%tree *] (render-tree item.p n)
[%unit *] (render-unit item.p n)
==
::
++ tape-to-plum
|= =tape
^- plum
(simple-wide '"' '' '"' `(list plum)`tape)
::
--
::
++ type-to-plum-simple
|^ main
::
++ main
|= [ty=type maxdepth=@ud]
^- plum
?: =(0 maxdepth) 'DEEP'
=/ d (dec maxdepth)
?- ty
%void '!!'
%noun '*'
[%atom *] (sexp 'atom' p.ty ?~(q.ty '~' (scot %ud u.q.ty)) ~)
[%cell *] (sexp 'cons' (main p.ty d) (main q.ty d) ~)
[%core *] =/ payload (sexp 'payload' (main p.ty d) ~)
(sexp 'core' (arms q.ty) payload ~)
[%face *] (sexp 'face' (type-face-to-plum p.ty) (main q.ty d) ~)
[%fork *] =/ forks %+ turn ~(tap in p.ty) |=(t=type (main t d))
(sexp 'fork' forks)
[%hint *] (sexp 'hint' 'hint' (main q.ty d) ~)
[%hold *] 'HOLD'
==
::
++ arms
|= =coil
^- plum
=/ arms (arm-names q.r.coil)
=. arms (turn arms |=(c=cord ?:(=('' c) '$' c)))
?: (gte (lent arms) 50) 'KERNEL'
(sexp 'arms' (chapters-to-plum-list q.r.coil))
::
:: Given a battery expression (from a hoon expression), produce a list
:: of arm names.
::
++ arm-names
|= =battery
^- (list term)
%- zing
%+ turn ~(val by battery)
|= [=what arms=(map term hoon)]
^- (list term)
~(tap in ~(key by arms))
::
++ type-face-to-plum
|= f=$@(term tune)
^- plum
?@ f f
(tune-to-plum f)
::
++ tune-to-plum
|= =tune
^- plum
=/ aliases p.tune
=/ bridges q.tune
=/ fmt [[~ ' ' [~ '[' ']']] ~]
=/ aliases
:- %sbrk
[%tree fmt 'aliases' (turn ~(tap by p.tune) alias-to-plum)]
=/ bridges
:- %sbrk
[%tree fmt 'bridges' (turn q.tune |=(h=hoon (hoon-to-plum 999 h)))]
:- %sbrk
[%tree fmt 'tune' bridges aliases ~]
::
++ alias-to-plum
|= [=term =(unit hoon)]
^- plum
=/ fmt [[~ ' ' [~ '(' ')']] ~]
[%sbrk [%tree fmt 'alias' term ?~(unit '~' (hoon-to-plum 999 u.unit)) ~]]
::
--
::
++ json-to-plum
::
:: Note that `arrayfmt` and `objfmt` use core-like formatting in
:: the tall case. This is kind-of a hack but works well!
::
=/ arrfmt=plumfmt :- wide=`[' ' `['[' ']']]
tall=`['[ ' `['' ']']]
::
=/ objfmt=plumfmt :- wide=`[' ' `['{' '}']]
tall=`['{ ' `['' '}']]
::
:: Note that `kidfmt` uses the magical "ace-ace" rune to get
:: 4-space indentation.
=/ kidfmt=plumfmt [wide=`['' ~] tall=`[' ' `['' '']]]
::
=/ colfmt=plumfmt [wide=`[' ' ~] tall=`['' `['' '']]]
::
|^ jsn
::
++ str |= t=@t
^- cord
(cat 3 '"' (cat 3 t '"')) :: XX Escaping
::
++ key |= t=@t
^- cord
(cat 3 (str t) ':')
::
++ kid |= kids=(list plum)
^- plum
[%tree kidfmt kids]
::
++ jsn |= j=json
^- plum
?- j
~ 'null'
[%a *] (arr p.j)
[%b *] ?:(p.j 'true' 'false')
[%o *] (obj p.j)
[%n *] p.j
[%s *] (str p.j)
==
::
++ arr |= l=(list json)
^- plum
[%sbrk [%tree arrfmt (seq (turn l jsn))]]
::
++ obj |= m=(map @t json)
^- plum
[%sbrk [%tree objfmt (seq (turn ~(tap by m) col))]]
::
++ col |= [k=@t v=json]
^- plum
[%sbrk [%tree colfmt ~[(key k) (kid (jsn v) ~)]]]
::
::
:: Adds a comma to the end of every plum but the last.
::
++ seq |= ps=(list plum)
^- (list plum)
=/ acc=(list plum) ~
|-
?~ ps (flop acc)
?~ t.ps (flop [i.ps acc])
%= $
acc [(com i.ps) acc]
ps `(list plum)`t.ps
==
::
++ lst |= ps=(list plum)
^- (list plum)
=/ acc=(list plum) ~
|-
?~ ps (flop acc)
?~ t.ps (flop [(com i.ps) acc])
%= $
acc [i.ps acc]
ps `(list plum)`t.ps
==
::
:: Adds a comma at the end of a plum in both wide and tall modes.
::
++ com |= p=plum
^- plum
?- p
@ (cat 3 p ',')
[%sbrk *] [%sbrk (com kid.p)]
[%para *] p
[%tree *]
?. ?& ?=(^ tall.fmt.p)
?| =(' ' intro.u.tall.fmt.p)
=('' intro.u.tall.fmt.p)
==
==
p(fmt (hak fmt.p))
p(kids (lst kids.p))
==
::
:: Nasty hack to add a trailing comma to an element in a sequence.
::
:: Everything that can appear in a sequence has a plum that is
:: either a cord or has a `plumfmt` that contains a terminator
:: character (possibly empty) in both wide and tall formats.
::
:: This routine fudges a `plumfmt` value so that a trailing comma
:: will be inserted at the end
::
++ hak |= fmt=plumfmt
^- plumfmt
::
%= fmt
wide ?~ wide.fmt wide.fmt
?~ enclose.u.wide.fmt wide.fmt
=. q.u.enclose.u.wide.fmt
(cat 3 q.u.enclose.u.wide.fmt ',')
wide.fmt
tall ?~ tall.fmt tall.fmt
?~ indef.u.tall.fmt tall.fmt
=. final.u.indef.u.tall.fmt
(cat 3 final.u.indef.u.tall.fmt ',')
tall.fmt
==
::
--
::
++ manx-to-plum
|= [[tag-name=mane attrs=mart] kids=marl]
^- plum
|^ result
::
++ result `plum`[%sbrk [%tree outfmt toptag childs ~]]
++ outfmt ^- plumfmt :- `['' `['' endtag]] `['' [~ '' endtag]]
::
++ tagstr (mane-to-cord tag-name)
::
++ toptag =/ a atribs
?~ a (cat 3 topstr '>')
[%sbrk [%tree topfmt a]]
::
++ txtstr ^- (unit plum)
=/ res (manx-text [[tag-name attrs] kids])
?~ res res
`(crip u.res)
:: `[%para '' ~[(crip u.res)]]
::
:: Note that `kidfmt` uses "the ace-ace rune" (scare quotes) to
:: get indentation.
::
++ childs ^- plum
=/ body txtstr
?~ body [%tree kidfmt (turn kids manx-to-plum)]
[%tree kidfmt [u.body (turn kids manx-to-plum)]]
++ kidfmt ^- plumfmt :- `['' `['' '']] `[' ' `['' '']]
::
++ topfmt =/ widetopstr (cat 3 topstr ' ')
:- wide=[~ ' ' [~ widetopstr '>']]
tall=[~ topstr [~ '' '>']]
++ topstr (cat 3 '<' tagstr)
++ atribs (turn (drop-body attrs) attr-to-plum)
::
++ endtag (cat 3 '</' (cat 3 tagstr '>'))
++ endfmt [[~ '' [~ '</' '>']] ~]
::
++ atrfmt [[~ '="' [~ '' '"']] ~] :: XX Escaping
::
:: All attributes except the bullshit '' attribute. (It indicates
:: the tag body).
::
++ drop-body
|= l=mart
^- mart
=/ acc=mart ~
|- ^- mart
?~ l (flop acc)
?: =('' n.i.l) $(l t.l)
$(l t.l, acc [i.l acc])
::
++ manx-text
|= [[=mane =mart] =marl] ^- (unit tape)
?~ mart ~
?: =('' n.i.mart) `v.i.mart
$(mart t.mart)
::
++ attr-to-plum
|= [m=mane t=tape]
^- plum
[%tree atrfmt (mane-to-cord m) (crip t) ~]
::
++ mane-to-cord
|= m=mane
^- cord
?@ m m
(cat 3 -:m (cat 3 ':' +:m))
::
--
--
Reference in New Issue View Git Blame Copy Permalink