urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2024-12-29 23:23:52 +03:00
Code Issues Packages Projects Releases Wiki Activity
0cb03b0461
shrub/pkg/arvo/sys/vane/ford.hoon
Ted Blackman 9fb37543ec ford: clear build results on +load
2019-12-18 00:25:27 -05:00

6355 lines
208 KiB
Plaintext
Raw Blame History

:: ford: build system vane
!:
:: Ford is a functional reactive build system.
::
:: A Ford build is a function of the Urbit namespace and a date that
:: produces marked, typed data or an error.
::
:: The function in the definition of a build is called a "schematic,"
:: and it's represented by a Hoon data structure with twenty-five sub-types.
:: A schematic is a (possibly trivial) DAG of sub-builds to be performed.
:: The different schematic sub-types transform the results of their
:: sub-builds in different ways.
::
:: We call the date in the definition of a build the "formal date" to
:: distinguish it from the time at which the build was performed.
::
:: Each build is referentially transparent with respect to its formal date:
:: ask to run that function on the namespace and a particular formal date,
:: and Ford will always produce the same result.
::
:: We can now say Ford is a functional build system, since each build is a
:: function. We have not yet explained how it's a functional reactive build
:: system. With Ford, you can subscribe to results of a build. Ford tracks
:: the result of a "live" build consisting of a static schematic and the
:: ever-changing current date. Whenever this live build's result changes,
:: Ford sends you the new result and the formal date of the build (the date
:: which would cause the same result if you asked Ford to build that
:: schematic again). This is a push-based FRP paradigm.
::
:: The implementation is event-driven, like the rest of Urbit. While
:: performing a build, Ford registers each namespace access as a dependency
:: and also notes whether the dependency is "live," meaning the path within
:: the namespace updates with time. For example a live Clay dependency would
:: update the +case within the +beam over time.
::
:: A request to perform a build without subscribing to its future changes is
:: called a "once build."
::
:: After finishing a build, Ford subscribes to updates on the build's
:: dependencies. For now, this just means it subscribes to Clay for file
:: changes. Whenever any of the files in the subscription have new contents,
:: Clay will notify Ford, which will then rerun any live builds that depend
:: on any of the changed files and send its subscribers the new results.
::
:: This matches the semantics of live builds defined above. If someone had
:: asked for a build of the schematic with a formal date d2 just before the
:: changed Clay files, Ford would respond with the result of the previous
:: build with formal date d1, which would still be an accurate
:: representation of the schematic's result at d2, since Ford knows none of
:: its dependencies changed between d1 and d2.
::
:: Note that Ford can only calculate dependencies after running a build,
:: not before. This is because Ford can be thought of as an interpreter for
:: schematics, rather than a compiler, in the sense that it can't have a
:: dependency-gathering step followed by a build step. The dependencies of
:: some schematics must be calculated based on results, e.g. the %alts
:: schematic, which tries a sequence of sub-builds until one succeeds. If
:: the first sub-build succeeds, the build depends only on that first
:: sub-build, but if the first fails and the second succeeds, the build
:: depends on both.
::
:: This dynamicity implies we don't know what we depend on until we depend
:: on it. Most build systems have this property, but this part of Ford's
:: job is easier than for most Unix-based build systems: Ford draws all
:: resources from an immutable namespace, and it can track every access of
:: that namespace.
::
:: Ford might produce a build's result asynchronously, in a subsequent Arvo
:: event. This happens when accessing the namespace doesn't complete
:: synchronously, such as when grabbing a file from another ship. Ford
:: guarantees it will respond with build results in chronological order
:: using the formal date, not the order in which the builds completed.
::
:: Ford does not guarantee it will notify a subscriber of a changed build
:: only once per change. In common usage it will not send duplicate
:: notifications, but it might if its cache was recently wiped.
::
:: Ford uses dependency tracking, caching, and results of previous builds
:: to eliminate excess work. When rerunning a live build, Ford "promotes"
:: previous results to the new time if the build's dependencies hvaen't
:: changed since the previous build's formal date. Ford does this check
:: for each build in a tree of sub-builds under the "root build," which
:: is the build that was requested directly.
::
:: In addition to the main %build +task sub-type, Ford also supports
:: four other commands:
::
:: %kill: cancel a build
::
:: A once build in progress will be canceled, including all of its
:: sub-builds that aren't part of any other builds.
::
:: A live build's subscriptions will be canceled, its completed results
:: will be deleted, and its dependency tracking information will be
:: deleted. If a rebuild is in progress, it will be canceled.
::
:: %keep: resize caches
::
:: Ford maintains two caches: a :compiler-cache that stores
:: content-addressed compiler operations, such as parsing, compiling,
:: and type inference; and a :build-cache that stores previously
:: completed build trees along with their results and dependency tracking.
::
:: The %keep command resets the maximum sizes of these caches, deleting
:: entries if necessary.
::
:: %wipe: decimate storage
::
:: The %wipe command removes build results from storage to free memory.
:: It deletes the specified percentage of build results, in LRU
:: (Least Recently Used) order. It also removes entries from the compiler
:: cache. It does not remove dependency tracking information.
::
:: %wegh: report memory usage
::
:: Like all vanes, Ford can also be asked to produce a human-readable
:: report of its memory usage. Nock cannot calculate its own memory use
:: directly, so instead we produce the nouns themselves, which the runtime
:: "weighs" based on its memory model.
::
:: For details on Ford's implementation, consult Ford's vane interface core
:: near the bottom of the file.
::
:: pit: a +vase of the hoon+zuse kernel, which is a deeply nested core
::
|= pit=vase
::
=, contain
=, ford
:: ford internal data structures
::
=> =~
|%
:: +move: arvo moves that ford can emit
::
+= move
::
$: :: duct: request identifier
::
=duct
:: card: move contents; either a +note or a +gift:able
::
card=(wind note gift:able)
==
:: +note: private request from ford to another vane
::
+$ note
$~ [%c %warp *@p *riff:clay]
$% :: %c: to clay
::
$: %c
:: %warp: internal (intra-ship) file request
::
$>(%warp task:able:clay)
== ==
:: +sign: private response from another vane to ford
::
+$ sign
$~ [%c %writ *riot:clay]
$? :: %c: from clay
::
:: XX also from behn due to %slip asynchronicity
::
$: ?(%b %c)
$> $? :: %writ: internal (intra-ship) file response
::
%writ
:: %wris: response to %mult; many changed files
::
%wris
==
gift:able:clay
== ==
--
|%
:: +axle: overall ford state
::
+= axle
$: :: date: date at which ford's state was updated to this data structure
::
date=%~2018.12.13
:: state: all persistent state
::
state=ford-state
==
:: +ford-state: all state that ford maintains
::
+= ford-state
$: :: builds: per-build state machine for all builds
::
:: Ford holds onto all in-progress builds that were either directly
:: requested by a duct (root builds) or that are dependencies
:: (sub-builds) of a directly requested build.
::
:: It also stores the last completed version of each live build tree
:: (root build and sub-builds), and any cached builds.
::
builds=(map build build-status)
:: ducts: per-duct state machine for all incoming ducts (build requests)
::
:: Ford tracks every duct that has requested a build until it has
:: finished dealing with that request.
::
:: For live ducts, we store the duct while we repeatedly run new
:: versions of the live build it requested until it is explicitly
:: canceled by the requester.
::
:: A once (non-live) duct, on the other hand, will be removed
:: as soon as the requested build has been completed.
::
ducts=(map duct duct-status)
:: builds-by-schematic: all attempted builds, sorted by time
::
:: For each schematic we've attempted to build at any time,
:: list the formal dates of all build attempts, sorted newest first.
::
builds-by-schematic=(map schematic (list @da))
:: pending-scrys: outgoing requests for static resources
::
pending-scrys=(request-tracker scry-request)
:: pending-subscriptions: outgoing subscriptions on live resources
::
pending-subscriptions=(request-tracker subscription)
:: build-cache: fifo queue of completed root builds
::
$= build-cache
$: :: next-anchor-id: incrementing identifier for cache anchors
::
next-anchor-id=@ud
:: queue: fifo queue of root builds identified by anchor id
::
queue=(capped-queue build-cache-key)
==
:: compiler-cache: clock based cache of build results
::
compiler-cache=(clock compiler-cache-key build-result)
==
:: +anchor: something which holds on to builds
::
:: An anchor is a reference which keeps builds. This is either a %duct, in
:: which case the build is live because a duct is waiting for a response, or
:: a %cache, in which case the anchor is a cached build.
::
:: When a duct would be removed from a build, the %duct anchor is replaced
:: with a %cache anchor. This %cache anchor refers to a FIFO queue of cached
:: builds.
::
+= anchor
$% :: %duct: this is anchored on a duct
::
[%duct =duct]
:: %cache: this is anchored to a cache entry
::
[%cache id=@ud]
==
:: +build-status: current data for a build, including construction status
::
:: +build-status stores the construction status of a build as a finite state
:: machine (:state). It stores links to dependent sub-builds in :subs, and
:: per-duct client builds in :clients.
::
+= build-status
$: :: requesters: ducts for whom this build is the root build
::
requesters=(set anchor)
:: clients: per duct information for this build
::
clients=(jug anchor build)
:: subs: sub-builds of this build, for whom this build is a client
::
subs=(map build build-relation)
:: state: a state machine for tracking the build's progress
::
$= state
$% $: :: %untried: build has not been started yet
::
%untried ~
==
$: :: %blocked: build blocked on either sub-builds or resource
::
:: If we're in this state and there are no blocks in :subs,
:: then we're blocked on a resource.
::
%blocked ~
==
$: :: %unblocked: we were blocked but now we aren't
::
%unblocked ~
==
$: :: %complete: build has finished running and has a result
::
%complete
:: build-record: the product of the build, possibly tombstoned
::
=build-record
== == ==
:: +duct-status: information relating a build to a duct
::
+= duct-status
$: :: live: whether this duct is being run live
::
$= live
$% [%once in-progress=@da]
$: %live
::
::
in-progress=(unit @da)
:: the last subscription we made
::
:: This can possibly have an empty set of resources, in which
:: we never sent a move.
::
:: NOTE: This implies that a single live build can only depend
:: on live resources from a single disc. We don't have a
:: working plan for fixing this and will need to think very
:: hard about the future.
::
last-sent=(unit [date=@da subscription=(unit subscription)])
== ==
:: root-schematic: the requested build for this duct
::
root-schematic=schematic
==
:: +build-relation: how do two builds relate to each other?
::
:: A +build-relation can be either :verified or not, and :blocked or not.
:: It is a symmetric relation between two builds, in the sense that both
:: the client and the sub will store the same relation, just pointing to
:: the other build.
::
:: If it's not :verified, then the relation is a guess based on previous
:: builds. These guesses are used to ensure that we hold onto builds we
:: expect to be used in future builds. Each time we run +make on a build,
:: it might produce new :verified sub-builds, which may have been unverified
:: until then. Once a build completes, any unverified sub-builds must be
:: cleaned up, since it turned out they weren't used by the build after all.
::
:: :blocked is used to note that a build can't be completed until that
:: sub-build has been completed. A relation can be :blocked but not :verified
:: if we're trying to promote a build, but we haven't run all its sub-builds
:: yet. In that case, we'll try to promote or run the sub-build in order to
:: determine whether we can promote the client. Until the sub-build has been
:: completed, the client is provisionally blocked on the sub-build.
::
+= build-relation
$: :: verified: do we know this relation is real, or is it only a guess?
::
verified=?
:: is this build blocked on this other build?
::
blocked=?
==
:: +build-record: information associated with the result of a completed +build
::
+= build-record
$% $: :: %tombstone: the build's result has been wiped
::
%tombstone ~
==
$: :: %value: we have the +build-result
::
%value
:: last-accessed: last time we looked at the result
::
:: This is used for LRU cache reclamation.
::
last-accessed=@da
:: build-result: the stored value of the build's product
::
=build-result
== ==
:: +build: a referentially transparent request for a build
::
:: Each unique +build will always produce the same +build-result
:: when run (if it completes). A live build consists of a sequence of
:: instances of +build with the same :schematic and increasing :date.
::
+= build
$: :: date: the formal date of this build; unrelated to time of execution
::
date=@da
:: schematic: the schematic that determines how to run this build
::
=schematic
==
:: +request-tracker: generic tracker and multiplexer for pending requests
::
++ request-tracker
|* request-type=mold
%+ map request-type
$: :: waiting: ducts blocked on this request
::
waiting=(set duct)
:: originator: the duct that kicked off the request
::
originator=duct
==
:: +subscription: a single subscription to changes on a set of resources
::
+= subscription
$: :: date: date this was made
::
date=@da
:: disc: ship and desk for all :resources
::
=disc
:: resources: we will be notified if any of these resources change
::
resources=(set resource)
==
:: +scry-request: parsed arguments to a scry operation
::
+= scry-request
$: :: vane: the vane from which to make the request
::
:: If we add other vanes in the future, this will become a fork type.
:: For now, though, Ford only knows how to make asynchronous scry
:: requests to Clay.
::
vane=%c
:: care: type of request
::
care=care:clay
:: beam: request path
::
=beam
==
:: +compiler-cache-key: content addressable build definitions
::
+= compiler-cache-key
$% [%call gate=vase sample=vase]
[%hood =beam txt=@t]
[%ride formula=hoon subject=vase]
[%slim subject-type=type formula=hoon]
[%slit gate=type sample=type]
==
:: +build-cache-key: key for the fifo cache of completed build trees
::
+= build-cache-key
$: :: id: incrementing identifier for an +anchor
::
id=@ud
:: root-build: the root build associated with this anchor
::
root-build=build
==
:: +build-receipt: result of running +make
::
:: A +build-receipt contains all information necessary to perform the
:: effects and state mutations indicated by a call to +make. If :build
:: succeeded, :result will be %build-result; otherwise, it will be %blocks.
::
:: After +make runs on a batch of builds, the resulting +build-receipt's are
:: applied one at a time.
::
+= build-receipt
$: :: build: the build we worked on
::
=build
:: result: the outcome of this build
::
$= result
$% :: %build-result: the build produced a result
::
$: %build-result
=build-result
==
:: %blocks: the build blocked on the following builds or resource
::
$: %blocks
:: builds: builds that :build blocked on
::
builds=(list build)
==
==
:: sub-builds: subbuilds of :build
::
:: While running +make on :build, we need to keep track of any
:: sub-builds that we try to access so we can keep track of
:: component linkages and cache access times.
::
sub-builds=(list build)
:: cache-access: if not ~, cache this result as :compiler-cache-key.
::
cache-access=(unit [=compiler-cache-key new=?])
==
--
=, format
|%
:: +tear: split a +term into segments delimited by `-`
::
:: Example:
:: ```
:: dojo> (tear 'foo-bar-baz')
:: ['foo' 'bar' 'baz']
:: ```
::
++ tear
|= a=term
^- (list term)
:: sym-no-heps: a parser for terms with no heps and a leading letter
::
=/ sym-no-heps (cook crip ;~(plug low (star ;~(pose low nud))))
::
(fall (rush a (most hep sym-no-heps)) /[a])
:: +segments: compute all paths from :path-part, replacing some `/`s with `-`s
::
:: For example, when passed a :path-part of 'foo-bar-baz',
:: the product will contain:
:: ```
:: dojo> (segments 'foo-bar-baz')
:: [/foo/bar/baz /foo/bar-baz /foo-bar/baz /foo-bar-baz]
:: ```
::
++ segments
|= path-part=@tas
^- (list path)
::
=/ join |=([a=@tas b=@tas] (crip "{(trip a)}-{(trip b)}"))
::
=/ torn=(list @tas) (tear path-part)
::
|- ^- (list (list @tas))
::
?< ?=(~ torn)
::
?: ?=([@ ~] torn)
~[torn]
::
%- zing
%+ turn $(torn t.torn)
|= s=(list @tas)
^- (list (list @tas))
::
?> ?=(^ s)
~[[i.torn s] [(join i.torn i.s) t.s]]
:: +build-to-tape: convert :build to a printable format
::
:: Builds often contain the standard library and large types, so
:: this function should always be called when trying to print a +build.
::
++ build-to-tape
|= =build
^- tape
~+
::
=/ enclose |=(tape "[{+<}]")
=/ date=@da date.build
=/ =schematic schematic.build
::
%- enclose
%+ welp (trip (scot %da date))
%+ welp " "
::
?+ -.schematic
:(welp "[" (trip -.schematic) " {<`@uvI`(mug schematic)>}]")
::
%$
"literal"
::
^
%- enclose
;:(welp $(build [date head.schematic]) " " $(build [date tail.schematic]))
::
%alts
;: welp
%+ roll choices.schematic
|= [choice=^schematic txt=_"[alts"]
:(welp txt " " ^$(schematic.build choice))
::
"]"
==
::
%core
:(welp "[core " (spud (en-beam (rail-to-beam source-path.schematic))) "]")
::
%hood
:(welp "[hood " (spud (en-beam (rail-to-beam source-path.schematic))) "]")
::
%plan
;: welp
"[plan "
(spud (en-beam (rail-to-beam path-to-render.schematic)))
"]"
==
::
%scry
(spud (en-beam (extract-beam resource.schematic ~)))
::
:: %slim
:: "slim {<subject-type.schematic>} {<formula.schematic>}"
::
%vale
;: welp
"[vale ["
(trip (scot %p ship.disc.schematic))
" "
(trip desk.disc.schematic)
"] "
(trip mark.schematic)
"]"
==
==
:: +rail-to-beam: convert :rail to a +beam, filling in the case with `[%ud 0]`
::
++ rail-to-beam
|= =rail
^- beam
[[ship.disc.rail desk.disc.rail [%ud 0]] spur.rail]
:: +rail-to-path: pretty-printable rail
::
++ rail-to-path
|= =rail
^- path
(en-beam (rail-to-beam rail))
:: +unify-jugs: make a new jug, unifying sets for all keys
::
:: Example:
:: ```
:: dojo> %+ unify-jugs
:: (~(gas by *(jug @tas @ud)) ~[[%a (sy 1 2 ~)] [%b (sy 4 5 ~)]])
:: (~(gas by *(jug @tas @ud)) ~[[%b (sy 5 6 ~)] [%c (sy 7 8 ~)]])
::
:: {[p=%a q={1 2 3}] [p=%b q={4 5 6}] [p=%c q={7 8}]}
:: ```
::
++ unify-jugs
|* [a=(jug) b=(jug)]
^+ a
::
=/ tapped ~(tap by b)
::
|- ^+ a
?~ tapped a
::
=/ key p.i.tapped
=/ vals ~(tap in q.i.tapped)
::
=. a
|- ^+ a
?~ vals a
::
$(vals t.vals, a (~(put ju a) key i.vals))
::
$(tapped t.tapped)
:: +path-to-resource: decode a +resource from a +wire
::
++ path-to-resource
|= =path
^- (unit resource)
::
=/ scry-request=(unit scry-request) (path-to-scry-request path)
?~ scry-request
~
=+ [vane care bem]=u.scry-request
=/ =beam bem
=/ =rail [disc=[p.beam q.beam] spur=s.beam]
`[vane care rail]
:: +scry-request-to-path: encode a +scry-request in a +wire
::
:: Example:
:: ```
:: dojo> %- scry-request-to-path
:: [%c %x [[~zod %home [%da ~2018.1.1]] /hoon/bar]])
::
:: /cx/~zod/home/~2018.1.1/bar/hoon
:: ```
::
++ scry-request-to-path
|= =scry-request
^- path
=/ =term (cat 3 [vane care]:scry-request)
[term (en-beam beam.scry-request)]
:: +path-to-scry-request: parse :path's components into :vane, :care, and :rail
::
++ path-to-scry-request
|= =path
^- (unit scry-request)
::
?~ path
~
?~ vane=((soft ,%c) (end 3 1 i.path))
~
?~ care=((soft care:clay) (rsh 3 1 i.path))
~
?~ beam=(de-beam t.path)
~
?. ?=(%da -.r.u.beam)
~
`[u.vane u.care u.beam]
:: +scry-request-to-build: convert a +scry-request to a %scry build
::
++ scry-request-to-build
|= =scry-request
^- build
:: we only operate on dates, not other kinds of +case:clay
::
?> ?=(%da -.r.beam.scry-request)
::
=, scry-request
[p.r.beam [%scry [vane care `rail`[[p q] s]:beam]]]
:: +extract-beam: obtain a +beam from a +resource
::
:: Fills case with [%ud 0] for live resources if :date is `~`.
:: For once resources, ignore :date.
::
++ extract-beam
|= [=resource date=(unit @da)] ^- beam
::
=/ =case ?~(date [%ud 0] [%da u.date])
::
=, rail.resource
[[ship.disc desk.disc case] spur]
:: +extract-disc: obtain a +disc from a +resource
::
++ extract-disc
|= =resource ^- disc
disc.rail.resource
:: +get-sub-schematics: find any schematics contained within :schematic
::
++ get-sub-schematics
|= =schematic
^- (list ^schematic)
?- -.schematic
^ ~[head.schematic tail.schematic]
%$ ~
%pin ~[schematic.schematic]
%alts choices.schematic
%bake ~
%bunt ~
%call ~[gate.schematic sample.schematic]
%cast ~[input.schematic]
%core ~
%diff ~[start.schematic end.schematic]
%dude ~[attempt.schematic]
%hood ~
%join ~[first.schematic second.schematic]
%list schematics.schematic
%mash ~[schematic.first.schematic schematic.second.schematic]
%mute [subject.schematic (turn mutations.schematic tail)]
%pact ~[start.schematic diff.schematic]
%path ~
%plan ~
%reef ~
%ride ~[subject.schematic]
%same ~[schematic.schematic]
%scry ~
%slim ~
%slit ~
%vale ~
%volt ~
%walk ~
==
:: +by-schematic: door for manipulating :by-schematic.builds.ford-state
::
:: The :dates list for each key in :builds is sorted in reverse
:: chronological order. These operations access and mutate keys and values
:: of :builds and maintain that sort order.
::
++ by-schematic
|_ builds=(map schematic (list @da))
:: +put: add a +build to :builds
::
:: If :build already exists in :builds, this is a no-op.
:: Otherwise, replace the value at the key :schematic.build
:: with a new :dates list that contains :date.build.
::
++ put
|= =build
^+ builds
%+ ~(put by builds) schematic.build
::
=/ dates (~(gut by builds) schematic.build ~)
|-
^+ dates
?~ dates
[date.build ~]
?: =(i.dates date.build)
dates
?: (gth date.build i.dates)
[date.build dates]
[i.dates $(dates t.dates)]
:: +del: remove a +build from :builds
::
:: Removes :build from :builds by replacing the value at
:: the key :schematic.build with a new :dates list with
:: :date.build omitted. If the resulting :dates list is
:: empty, then remove the key-value pair from :builds.
::
++ del
|= =build
^+ builds
=. builds
%+ ~(jab by builds) schematic.build
|= dates=(list @da)
~| build+build
=/ date-index (need (find [date.build]~ dates))
(oust [date-index 1] dates)
:: if :builds has an empty entry for :build, delete it
::
=? builds
=(~ (~(got by builds) schematic.build))
(~(del by builds) schematic.build)
::
builds
:: +find-previous: find the most recent older build with :schematic.build
::
++ find-previous
|= =build
^- (unit ^build)
::
=/ dates=(list @da) (~(gut by builds) schematic.build ~)
::
|- ^- (unit ^build)
?~ dates ~
::
?: (lth i.dates date.build)
`[i.dates schematic.build]
$(dates t.dates)
:: +find-next: find the earliest build of :schematic.build later than :build
::
++ find-next
|= =build
^- (unit ^build)
::
=/ dates=(list @da) (flop (~(gut by builds) schematic.build ~))
::
|- ^- (unit ^build)
?~ dates ~
::
?: (gth i.dates date.build)
`[i.dates schematic.build]
$(dates t.dates)
--
:: +get-request-ducts: all ducts waiting on this request
::
++ get-request-ducts
|* [tracker=(request-tracker) request=*]
^- (list duct)
::
~(tap in waiting:(~(got by tracker) request))
:: +put-request: associates a +duct with a request
::
++ put-request
|* [tracker=(request-tracker) request=* =duct]
::
%+ ~(put by tracker) request
?~ existing=(~(get by tracker) request)
[(sy duct ~) duct]
u.existing(waiting (~(put in waiting.u.existing) duct))
:: +del-request: remove a duct and produce the originating duct if empty
::
++ del-request
|* [tracker=(request-tracker) request=* =duct]
^- [(unit ^duct) _tracker]
:: remove :duct from the existing :record of this :request
::
=/ record (~(got by tracker) request)
=. waiting.record (~(del in waiting.record) duct)
:: if no more ducts wait on :request, delete it
::
?^ waiting.record
[~ (~(put by tracker) request record)]
[`originator.record (~(del by tracker) request)]
:: +parse-scaffold: produces a parser for a hoon file with +crane instances
::
:: Ford parses a superset of hoon which contains additional runes to
:: represent +crane s. This parses to a +scaffold.
::
:: src-beam: +beam of the source file we're parsing
::
++ parse-scaffold
|= src-beam=beam
::
=/ hoon-parser (vang & (en-beam src-beam))
|^ ::
%+ cook
|= a=[@ud (list ^cable) (list ^cable) (list ^crane) (list hoon)]
^- scaffold
[[[p q] s]:src-beam a]
::
%+ ifix [gay gay]
;~ plug
:: parses the zuse version, eg "/? 309"
::
;~ pose
(ifix [;~(plug net wut gap) gap] dem)
(easy zuse)
==
:: pareses the structures, eg "/- types"
::
;~ pose
(ifix [;~(plug net hep gap) gap] (most ;~(plug com gaw) cable))
(easy ~)
==
:: parses the libraries, eg "/+ lib1, lib2"
::
;~ pose
(ifix [;~(plug net lus gap) gap] (most ;~(plug com gaw) cable))
(easy ~)
==
::
(star ;~(sfix crane gap))
::
(most gap tall:hoon-parser)
==
:: +beam: parses a hood path and converts it to a beam
::
++ beam
%+ sear de-beam
;~ pfix
net
(sear plex (stag %clsg poor)):hoon-parser
==
:: +cable: parses a +^cable, a reference to something on the filesystem
::
:: This parses:
::
:: `library` -> wraps `library` around the library `library`
:: `face=library` -> wraps `face` around the library `library`
:: `*library` -> exposes `library` directly to the subject
::
++ cable
%+ cook |=(a=^cable a)
;~ pose
(stag ~ ;~(pfix tar sym))
(cook |=([face=term tis=@ file=term] [`face file]) ;~(plug sym tis sym))
(cook |=(a=term [`a a]) sym)
==
:: +crane: all runes that start with / which aren't /?, /-, /+ or //.
::
++ crane
=< apex
:: whether we allow tall form
=| allow-tall-form=?
::
|%
++ apex
%+ knee *^crane |. ~+
;~ pfix net
;~ pose
:: `/~` hoon literal
::
(stag %fssg ;~(pfix sig hoon))
:: `/$` process query string
::
(stag %fsbc ;~(pfix bus hoon))
:: `/|` first of many options that succeeds
::
(stag %fsbr ;~(pfix bar parse-alts))
:: `/=` wrap a face around a crane
::
(stag %fsts ;~(pfix tis parse-face))
:: `/.` null terminated list
::
(stag %fsdt ;~(pfix dot parse-list))
:: `/,` switch by path
::
(stag %fscm ;~(pfix com parse-switch))
:: `/&` pass through a series of mark
::
(stag %fspm ;~(pfix pad parse-pipe))
:: `/_` run a crane on each file in the current directory
::
(stag %fscb ;~(pfix cab subcrane))
:: `/;` passes date through a gate
::
(stag %fssm ;~(pfix mic parse-gate))
:: `/:` evaluate at path
::
(stag %fscl ;~(pfix col parse-at-path))
:: `/^` cast
::
(stag %fskt ;~(pfix ket parse-cast))
:: `/*` run a crane on each file with current path as prefix
::
(stag %fstr ;~(pfix tar subcrane))
:: `/!mark/ evaluate as hoon, then pass through mark
::
(stag %fszp ;~(pfix zap ;~(sfix sym net)))
:: `/mark/` passes current path through :mark
::
(stag %fszy ;~(sfix sym net))
==
==
:: +parse-alts: parse a set of alternatives
::
++ parse-alts
%+ wide-or-tall
(ifix [lit rit] (most ace subcrane))
;~(sfix (star subcrane) gap duz)
:: +parse-face: parse a face around a subcrane
::
++ parse-face
%+ wide-or-tall
;~(plug sym ;~(pfix tis subcrane))
;~(pfix gap ;~(plug sym subcrane))
:: +parse-list: parse a null terminated list of cranes
::
++ parse-list
%+ wide-or-tall
fail
;~(sfix (star subcrane) gap duz)
:: +parse-switch: parses a list of [path crane]
::
++ parse-switch
%+ wide-or-tall
fail
=- ;~(sfix (star -) gap duz)
;~(pfix gap net ;~(plug static-path subcrane))
:: +parse-pipe: parses a pipe of mark conversions
::
++ parse-pipe
%+ wide-or-tall
;~(plug (plus ;~(sfix sym pad)) subcrane)
=+ (cook |=(a=term [a ~]) sym)
;~(pfix gap ;~(plug - subcrane))
:: +parse-gate: parses a gate applied to a crane
::
++ parse-gate
%+ wide-or-tall
;~(plug ;~(sfix wide:hoon-parser mic) subcrane)
;~(pfix gap ;~(plug tall:hoon-parser subcrane))
:: +parse-at-path: parses a late bound bath
::
++ parse-at-path
%+ wide-or-tall
;~(plug ;~(sfix late-bound-path col) subcrane)
;~(pfix gap ;~(plug late-bound-path subcrane))
:: +parse-cast: parses a mold and then the subcrane to apply that mold to
::
++ parse-cast
%+ wide-or-tall
;~(plug ;~(sfix wyde:hoon-parser ket) subcrane)
;~(pfix gap ;~(plug till:hoon-parser subcrane))
:: +subcrane: parses a subcrane
::
++ subcrane
%+ wide-or-tall
apex(allow-tall-form |)
;~(pfix gap apex)
:: +wide-or-tall: parses tall form hoon if :allow-tall-form is %.y
::
++ wide-or-tall
|* [wide=rule tall=rule]
?. allow-tall-form wide
;~(pose wide tall)
:: +hoon: parses hoon as an argument to a crane
::
++ hoon
%+ wide-or-tall
(ifix [lac rac] (stag %cltr (most ace wide:hoon-parser)))
;~(pfix gap tall:hoon-parser)
--
:: +static-path: parses a path
::
++ static-path
(sear plex (stag %clsg (more net hasp))):hoon-parser
:: +late-bound-path: a path whose time varies
::
++ late-bound-path
;~ pfix net
%+ cook |=(a=truss a)
=> hoon-parser
;~ plug
(stag ~ gash)
;~(pose (stag ~ ;~(pfix cen porc)) (easy ~))
==
==
--
:: +per-event: per-event core; main build engine
::
:: This arm produces a gate that when called with state and event
:: information produces the core of Ford's main build engine.
::
:: The main build engine core has the following entry points:
::
:: +start-build start performing a build
:: +rebuild rerun a live build at a new date
:: +unblock continue a build that was waiting on a resource
:: +cancel stop trying to run a build and delete its tracking info
:: +wipe wipe the build storage to free memory
:: +keep resize caches, deleting entries if necessary
::
:: The main internal arm is +execute-loop, which is called from +start-build,
:: +rebuild, and +unblock. +execute defines Ford's build loop.
::
++ per-event
:: moves: the moves to be sent out at the end of this event, reversed
::
=| moves=(list move)
:: scry-results: responses to scry's to handle in this event
::
:: If a value is `~`, the requested resource is not available.
:: Otherwise, the value will contain a +cage.
::
=| scry-results=(map scry-request (unit cage))
:: next-builds: builds to perform in the next iteration
::
=| next-builds=(set build)
:: candidate-builds: builds which might go into next-builds
::
=| candidate-builds=(set build)
:: gate that produces the +per-event core from event information
::
:: Produces a core containing Ford's main build engine.
::
~% %f ..is ~
|= [[our=@p =duct now=@da scry=sley] state=ford-state]
::
~% %per-event + ~
|%
:: +finalize: extract moves and state from the +per-event core
::
:: Run once at the end of processing an event.
::
++ finalize
^- [(list move) ford-state]
[(flop moves) state]
:: |entry-points: externally fired arms
::
::+| entry-points
::
:: +start-build: perform a fresh +build, either live or once
::
:: This might complete the build, or the build might block on one or more
:: requests for resources. Calls +execute-loop.
::
++ start-build
~/ %start-build
|= [=build live=?]
^- [(list move) ford-state]
::
=< finalize
:: associate :duct with :build in :ducts.state
::
=. ducts.state
%+ ~(put by ducts.state) duct
:_ schematic.build
?: live
[%live in-progress=`date.build last-sent=~]
[%once in-progress=date.build]
:: register a state machine for :build in :builds.state
::
=. state (add-build build)
:: :anchor: the reason we hold onto the root of this build tree
::
=/ =anchor [%duct duct]
:: register :duct as an anchor in :requesters.build-status
::
:: This establishes :build as the root build for :duct.
::
=. builds.state
%+ ~(jab by builds.state) build
|= =build-status
build-status(requesters (~(put in requesters.build-status) anchor))
:: copy :anchor into any preexisting descendants
::
:: Sub-builds will reference :build in their :clients.build-status,
:: using `[%duct duct]` as the key. Some sub-builds might already
:: exist if we've already started running :build, so make sure they
:: know who their daddy is.
::
=. builds.state (add-anchor-to-subs anchor build)
:: run +execute on :build in a loop until it completes or blocks
::
(execute-loop (sy [build ~]))
:: +rebuild: rebuild a live build based on +resource updates
::
:: For every changed resource, run the %scry build for that
:: for that resource. Then rebuild upward using the main +execute-loop
:: until all relevant builds either complete or block on external
:: resources. Use dependency tracking information from the previous
:: run of this live build to inform the dependency tracking for this
:: new rebuild.
::
++ rebuild
~/ %rebuild
|= $: =subscription
new-date=@da
=disc
care-paths=(set [care=care:clay =path])
==
^- [(list move) ford-state]
::
~| [%rebuilding new-date disc]
::
=< finalize
:: mark this subscription as complete now that we've heard a response
::
=. pending-subscriptions.state
+:(del-request pending-subscriptions.state subscription duct)
:: for every changed resource, create a %scry build
::
=/ builds=(list build)
%+ turn ~(tap in care-paths)
|= [care=care:clay =path]
^- build
::
[new-date [%scry [%c care rail=[disc spur=(flop path)]]]]
:: sanity check; only rebuild live builds, not once builds
::
=/ duct-status (~(got by ducts.state) duct)
?> ?=(%live -.live.duct-status)
:: sanity check; only rebuild once we've completed the previous one
::
?> ?=(~ in-progress.live.duct-status)
?> ?=(^ last-sent.live.duct-status)
:: set the in-progress date for this new build
::
=. ducts.state
%+ ~(put by ducts.state) duct
duct-status(in-progress.live `new-date)
:: copy the previous build's tree as provisional sub-builds
::
:: This provides an upward rebuild path from leaves to root,
:: so that once the %scry builds complete, we'll know to rebuild
:: their clients. This process will continue up through rebuilding
:: the root build.
::
:: If the build at this new date ends up with a different set of
:: dependencies from its previous incarnation, provisional sub-builds
:: that weren't actually used will be removed in
:: +cleanup-orphaned-provisional-builds.
::
=/ old-root=build
[date.u.last-sent.live.duct-status root-schematic.duct-status]
::
=. state
::
~| [%duct-doesnt-refer-to-real-build live.duct-status]
~| [%missing-build (build-to-tape old-root)]
~| [%dates (~(get by builds-by-schematic.state) root-schematic.duct-status)]
?> (~(has by builds.state) old-root)
::
(copy-build-tree-as-provisional old-root new-date=new-date)
:: gather all the :builds, forcing reruns
::
:: The normal +gather logic would promote the previous results
:: for these %scry builds, since we have subscriptions on them.
:: We pass `force=%.y` to ensure the builds get enqueued instead
:: of promoted.
::
=. ..execute (gather (sy builds) force=%.y)
:: rebuild resource builds at the new date
::
:: This kicks off the main build loop, which will first build
:: :builds, then rebuild upward toward the root. If the whole
:: build tree completes synchronously, then this will produce
:: %made moves at the end of this event. Otherwise, it will
:: block on resources and complete during a later event.
::
(execute-loop ~)
:: +unblock: continue builds that had blocked on :resource
::
:: A build can be stymied temporarily if it depends on a resource
:: that must be fetched asynchronously. +unblock is called when
:: we receive a response to a resource request that blocked a build.
::
:: We pick up the build from where we left off, starting with the
:: %scry build that blocked on this resource last time we tried it.
::
++ unblock
~/ %unblock
|= [=scry-request scry-result=(unit cage)]
^- [(list move) ford-state]
::
=< finalize
:: place :scry-result in :scry-results.per-event
::
:: We don't want to call the actual +scry function again,
:: because we already tried that in a previous event and it
:: had no synchronous answer. This +unblock call is a result
:: of the response to the asynchronous request we made to
:: retrieve that resource from another vane.
::
:: Instead, we'll intercept any calls to +scry by looking up
:: the arguments in :scry-results.per-event. This is ok because
:: in this function we attempt to run every +build that had
:: blocked on the resource, so the information is guaranteed
:: to be used during this event before it goes out of scope.
::
=. scry-results (~(put by scry-results) scry-request scry-result)
:: mark this +scry-request as complete now that we have a response
::
=. pending-scrys.state
+:(del-request pending-scrys.state scry-request duct)
:: update :unblocked-build's state machine to reflect its new status
::
=/ unblocked-build=build (scry-request-to-build scry-request)
=. builds.state
%+ ~(jab by builds.state) unblocked-build
|= =build-status
build-status(state [%unblocked ~])
:: jump into the main build loop, starting with :unblocked-build
::
(execute-loop (sy unblocked-build ~))
:: +wipe: forcibly decimate build results from the state
::
:: +wipe decimates both the :compiler-cache and the results in
:: :builds.state. It removes the specified percentage of build results
:: from the state. For simplicity, it considers the weight of each
:: compiler cache line to be equal to the weight of a build result.
::
:: It deletes cache entries before dipping into :builds.state; it only
:: converts entries in :builds.state to %tombstone's if there aren't
:: enough entries in the compiler cache to sate the request's bloodlust.
::
:: When deleting results from :builds.state, it first sorts them by
:: their :last-accessed date so that the stalest builds are deleted first.
:: We do not touch the :build-cache directly, but because the results
:: of the builds in :build-cache live in :builds.state, the results of
:: both FIFO-cached builds and active builds are all sorted and trimmed.
::
++ wipe
~/ %wipe
|= percent-to-remove=@ud
^+ state
:: removing 0% is the same as doing nothing, so do nothing
::
?: =(0 percent-to-remove)
~& %wipe-no-op
state
::
~| [%wipe percent-to-remove=percent-to-remove]
?> (lte percent-to-remove 100)
:: find all completed builds, sorted by :last-accessed date
::
=/ completed-builds=(list build)
=- (turn - head)
%+ sort
:: filter for builds with a stored +build-result
::
%+ skim ~(tap by builds.state)
|= [=build =build-status]
^- ?
::
?=([%complete %value *] state.build-status)
:: sort by :last-accessed date
::
|= [[* a=build-status] [* b=build-status]]
^- ?
::
?> ?=([%complete %value *] state.a)
?> ?=([%complete %value *] state.b)
::
%+ lte
last-accessed.build-record.state.a
last-accessed.build-record.state.b
:: determine how many builds should remain after decimation
::
:: This formula has the property that repeated applications
:: of +wipe with anything other than 100% retention rate will
:: always eventually remove every build.
::
=/ num-completed-builds=@ud
(add (lent completed-builds) size.compiler-cache.state)
=/ percent-to-keep=@ud (sub 100 percent-to-remove)
=/ num-to-keep=@ud (div (mul percent-to-keep num-completed-builds) 100)
=/ num-to-remove=@ud (sub num-completed-builds num-to-keep)
::
|^ ^+ state
::
=+ cache-size=size.compiler-cache.state
?: (lte num-to-remove cache-size)
(remove-from-cache num-to-remove)
=. compiler-cache.state
%~ purge
(by-clock compiler-cache-key build-result)
compiler-cache.state
(tombstone-builds (sub num-to-remove cache-size))
::
++ remove-from-cache
|= count=@ud
%_ state
compiler-cache
%- %~ trim
(by-clock compiler-cache-key build-result)
compiler-cache.state
count
==
::
++ tombstone-builds
|= num-to-remove=@ud
::
~| [%wipe num-to-remove=num-to-remove]
:: the oldest :num-to-remove builds are considered stale
::
=/ stale-builds (scag num-to-remove completed-builds)
:: iterate over :stale-builds, replacing with %tombstone's
::
|- ^+ state
?~ stale-builds state
:: replace the build's entry in :builds.state with a %tombstone
::
=. builds.state
=< builds
%+ update-build-status i.stale-builds
|= =build-status
build-status(state [%complete %tombstone ~])
::
$(stale-builds t.stale-builds)
--
:: +keep: resize caches
::
:: Ford maintains two caches: a :build-cache for caching previously
:: completed build trees, and a :compiler-cache for caching various
:: compiler operations that tend to be shared among multiple builds.
::
:: To handle this command, we reset the maximum sizes of both of
:: these caches, removing entries from the caches if necessary.
::
++ keep
~/ %keep
|= [compiler-cache-size=@ud build-cache-size=@ud]
^+ state
:: pop old builds out of :build-cache and remove their cache anchors
::
=^ pops queue.build-cache.state
%. build-cache-size
~(resize (to-capped-queue build-cache-key) queue.build-cache.state)
::
=. state
|- ^+ state
?~ pops state
::
=. state (remove-anchor-from-root root-build.i.pops [%cache id.i.pops])
::
$(pops t.pops)
:: resize the :compiler-cache
::
%_ state
compiler-cache
%- %~ resize
(by-clock compiler-cache-key build-result)
compiler-cache.state
compiler-cache-size
==
:: +cancel: cancel a build
::
:: When called on a live build, removes all tracking related to the live
:: build, and no more %made moves will be sent for that build.
::
:: When called on a once build, removes all tracking related to the once
:: build, and that build will never be completed or have a %made sent.
::
:: When called on a build that isn't registered in :state, such as a
:: completed once build, or a build that has already been canceled,
:: prints and no-ops.
::
++ cancel ^+ [moves state]
::
=< finalize
::
?~ duct-status=(~(get by ducts.state) duct)
~& [%no-build-for-duct duct]
..execute
:: :duct is being canceled, so remove it unconditionally
::
=. ducts.state (~(del by ducts.state) duct)
:: if the duct was not live, cancel any in-progress builds
::
?: ?=(%once -.live.u.duct-status)
::
=/ root-build=build [in-progress.live root-schematic]:u.duct-status
::
=. ..execute (cancel-scrys root-build)
=. state (remove-anchor-from-root root-build [%duct duct])
..execute
:: if the duct was live and has an unfinished build, cancel it
::
=? ..execute ?=(^ in-progress.live.u.duct-status)
::
=/ root-build=build [u.in-progress.live root-schematic]:u.duct-status
::
=. ..execute (cancel-scrys root-build)
=. state (remove-anchor-from-root root-build [%duct duct])
..execute
:: if there is no completed build for the live duct, we're done
::
?~ last-sent=last-sent.live.u.duct-status
..execute
:: there is a completed build for the live duct, so delete it
::
=/ root-build=build [date.u.last-sent root-schematic.u.duct-status]
::
=. state (remove-anchor-from-root root-build [%duct duct])
::
?~ subscription.u.last-sent
..execute
(cancel-clay-subscription u.subscription.u.last-sent)
:: +cancel-scrys: cancel all blocked %scry sub-builds of :root-builds
::
++ cancel-scrys
|= root-build=build
^+ ..execute
::
=/ blocked-sub-scrys ~(tap in (collect-blocked-sub-scrys root-build))
::
|- ^+ ..execute
?~ blocked-sub-scrys ..execute
::
=. ..execute (cancel-scry-request i.blocked-sub-scrys)
::
$(blocked-sub-scrys t.blocked-sub-scrys)
:: +move-root-to-cache: replace :duct with a %cache anchor in :build's tree
::
++ move-root-to-cache
~/ %move-root-to-cache
|= =build
^+ state
:: obtain the new cache id and increment the :next-anchor-id in the state
::
=^ new-id next-anchor-id.build-cache.state
=/ id=@ud next-anchor-id.build-cache.state
[id +(id)]
:: replace the requester in the root build
::
=. builds.state
%+ ~(jab by builds.state) build
|= =build-status
%_ build-status
requesters
=- (~(del in -) [%duct duct])
=- (~(put in -) [%cache new-id])
requesters.build-status
==
:: enqueue :build into cache, possibly popping and deleting a stale build
::
=^ oldest queue.build-cache.state
%. [new-id build]
~(put (to-capped-queue build-cache-key) queue.build-cache.state)
::
=? state
?=(^ oldest)
(remove-anchor-from-root root-build.u.oldest [%cache id.u.oldest])
:: recursively replace :clients in :build and descendants
::
|- ^+ state
::
=/ client-status=build-status (~(got by builds.state) build)
=/ subs=(list ^build) ~(tap in ~(key by subs.client-status))
::
|- ^+ state
?~ subs state
::
=. builds.state
%+ ~(jab by builds.state) i.subs
|= =build-status
%_ build-status
clients
:: if we've already encountered :i.subs, don't overwrite
::
?: (~(has by clients.build-status) [%cache new-id])
clients.build-status
::
=/ old-clients-on-duct (~(get ju clients.build-status) [%duct duct])
::
=- (~(del by -) [%duct duct])
=- (~(put by -) [%cache new-id] old-clients-on-duct)
clients.build-status
==
::
=. state ^$(build i.subs)
::
$(subs t.subs)
:: +remove-anchor-from-root: remove :anchor from :build's tree
::
++ remove-anchor-from-root
~/ %remove-anchor-from-root
|= [=build =anchor]
^+ state
::
=. builds.state
%+ ~(jab by builds.state) build
|= =build-status
build-status(requesters (~(del in requesters.build-status) anchor))
::
=. builds.state (remove-anchor-from-subs build anchor)
::
(cleanup build)
:: +remove-anchor-from-subs: recursively remove :anchor from sub-builds
::
++ remove-anchor-from-subs
~/ %remove-anchor-from-subs
|= [=build =anchor]
^+ builds.state
::
=/ =build-status (~(got by builds.state) build)
=/ subs=(list ^build) ~(tap in ~(key by subs.build-status))
=/ client=^build build
::
|- ^+ builds.state
?~ subs builds.state
::
=/ sub-status=^build-status (~(got by builds.state) i.subs)
::
=. clients.sub-status
(~(del ju clients.sub-status) anchor client)
::
=. builds.state (~(put by builds.state) i.subs sub-status)
::
=? builds.state !(~(has by clients.sub-status) anchor)
::
^$(build i.subs)
::
$(subs t.subs)
:: +add-anchors-to-build-subs: for each sub, add all of :build's anchors
::
++ add-anchors-to-build-subs
~/ %add-anchors-to-build-subs
|= =build
^+ state
::
=/ =build-status (~(got by builds.state) build)
=/ new-anchors
~(tap in (~(put in ~(key by clients.build-status)) [%duct duct]))
=/ subs ~(tap in ~(key by subs.build-status))
::
=. state
|-
^+ state
?~ subs state
::
=. state (add-build i.subs)
::
$(subs t.subs)
::
=. builds.state
|- ^+ builds.state
?~ new-anchors builds.state
::
=. builds.state (add-anchor-to-subs i.new-anchors build)
::
$(new-anchors t.new-anchors)
::
state
:: +add-anchor-to-subs: attach :duct to :build's descendants
::
++ add-anchor-to-subs
~/ %add-anchor-to-subs
|= [=anchor =build]
^+ builds.state
::
=/ =build-status (~(got by builds.state) build)
=/ subs=(list ^build) ~(tap in ~(key by subs.build-status))
=/ client=^build build
::
|- ^+ builds.state
?~ subs builds.state
::
=/ sub-status=^build-status (~(got by builds.state) i.subs)
::
=/ already-had-anchor=? (~(has by clients.sub-status) anchor)
::
=. clients.sub-status
(~(put ju clients.sub-status) anchor client)
::
=. builds.state (~(put by builds.state) i.subs sub-status)
::
=? builds.state !already-had-anchor ^$(build i.subs)
::
$(subs t.subs)
:: +copy-build-tree-as-provisional: prepopulate new live build
::
:: Make a provisional copy of the completed old root build tree at the
:: :new time.
::
++ copy-build-tree-as-provisional
~/ %copy-build-tree-as-provisional
|= [old-root=build new-date=@da]
^+ state
~| [old-root=(build-to-tape old-root) new-date=new-date]
::
=/ old-client=build old-root
=/ new-client=build old-client(date new-date)
=. state (add-build new-client)
::
=. builds.state
%+ ~(jab by builds.state) new-client
|= =build-status
build-status(requesters (~(put in requesters.build-status) [%duct duct]))
::
=< copy-node
::
|%
++ copy-node
^+ state
::
=/ old-build-status=build-status
~| old-client=(build-to-tape old-client)
(~(got by builds.state) old-client)
::
=/ old-subs=(list build) ~(tap in ~(key by subs.old-build-status))
=/ new-subs=(list build) (turn old-subs |=(a=build a(date new-date)))
::
=. builds.state
(add-subs-to-client new-client new-subs [verified=%.n blocked=%.y])
::
|-
^+ state
?~ old-subs
state
::
=. state (add-client-to-sub i.old-subs)
=. state
copy-node(old-client i.old-subs, new-client i.old-subs(date new-date))
::
$(old-subs t.old-subs)
::
++ add-client-to-sub
|= old-sub=build
^+ state
::
=/ new-sub old-sub(date new-date)
=. state (add-build new-sub)
::
=. builds.state
%+ ~(jab by builds.state) new-sub
|= =build-status
%_ build-status
clients (~(put ju clients.build-status) [%duct duct] new-client)
==
::
state
--
:: +add-subs-to-client: register :new-subs as subs of :new-client
::
++ add-subs-to-client
~/ %add-subs-to-client
|= [new-client=build new-subs=(list build) =build-relation]
^+ builds.state
::
%+ ~(jab by builds.state) new-client
|= =build-status
%_ build-status
subs
%- ~(gas by subs.build-status)
%+ murn new-subs
|= sub=build
^- (unit (pair build ^build-relation))
::
?^ (~(get by subs.build-status) sub)
~
`[sub build-relation]
==
:: |construction: arms for performing builds
::
::+| construction
::
:: +execute-loop: +execute repeatedly until there's no more work to do
::
:: Keep running +execute until all relevant builds either complete or
:: block on external resource requests. See +execute for details of each
:: loop execution.
::
:: This implementation is for simplicity. In the longer term, we'd
:: like to just perform a single run through +execute and set a Behn timer
:: to wake us up immediately. This has the advantage that Ford stops hard
:: blocking the main Urbit event loop, letting other work be done.
::
++ execute-loop !.
~/ %execute-loop
|= builds=(set build)
^+ ..execute
::
=. ..execute (execute builds)
::
?: ?& ?=(~ next-builds)
?=(~ candidate-builds)
==
..execute
::
$(builds ~)
:: +execute: main recursive construction algorithm
::
:: Performs the three step build process: First, figure out which builds
:: we're going to run this loop through the ford algorithm. Second, run
:: the gathered builds, possibly in parallel. Third, apply the
:: +build-receipt algorithms to the ford state.
::
++ execute
~/ %execute
|= builds=(set build)
^+ ..execute
::
=. ..execute (gather builds force=%.n)
::
=^ build-receipts ..execute run-builds
::
(reduce build-receipts)
:: +gather: collect builds to be run in a batch
::
:: The +gather phase is the first of the three parts of +execute. In
:: +gather, we look through each item in :candidate-builds. If we
:: should run the candidate build this cycle through the +execute loop, we
:: place it in :next-builds. +gather runs until it has no more candidates.
::
++ gather !.
~/ %gather
|= [builds=(set build) force=?]
^+ ..execute
:: add builds that were triggered by incoming event to the candidate list
::
=. candidate-builds (~(uni in candidate-builds) builds)
::
|^ ^+ ..execute
::
?: =(~ candidate-builds)
..execute
::
=/ next=build
?< ?=(~ candidate-builds)
n.candidate-builds
=. candidate-builds (~(del in candidate-builds) next)
::
$(..execute (gather-build next))
:: +gather-build: looks at a single candidate build
::
:: This gate inspects a single build. It might move it to :next-builds,
:: or promote it using an old build. It also might add this build's
:: sub-builds to :candidate-builds.
::
++ gather-build
|= =build
^+ ..execute
~| [%duct duct]
=/ duct-status (~(got by ducts.state) duct)
:: if we already have a result for this build, don't rerun the build
::
=^ current-result builds.state (access-build-record build)
::
?: ?=([~ %value *] current-result)
(on-build-complete build)
:: place :build in :builds.state if it isn't already there
::
=. state (add-build build)
:: ignore blocked builds
::
=/ =build-status (~(got by builds.state) build)
?: ?=(%blocked -.state.build-status)
=. state (add-anchors-to-build-subs build)
::
=/ sub-scrys=(list scry-request)
~(tap in (collect-blocked-sub-scrys build))
::
=. pending-scrys.state
|- ^+ pending-scrys.state
?~ sub-scrys pending-scrys.state
::
=. pending-scrys.state
(put-request pending-scrys.state i.sub-scrys duct)
::
$(sub-scrys t.sub-scrys)
::
..execute
:: old-build: most recent previous build with :schematic.build
::
=/ old-build=(unit ^build)
?: ?& ?=(%live -.live.duct-status)
?=(^ last-sent.live.duct-status)
==
:: check whether :build was run as part of the last live build tree
::
:: If we had build this schematic as part of the build tree
:: during the last run of this live build, then we can compare
:: our result to that build. It might not be the most recent,
:: but if our sub-builds have the same results as they did then,
:: we can promote them. This is especially helpful for a %scry
:: build, because we don't have to make a new request for the
:: resource if the last live build subscribed to it.
::
:: Otherwise, default to looking up the most recent build of this
:: schematic in :builds-by-schematic.state. We'll have to rerun
:: any %scry sub-builds, but other than that, we should still be
:: able to promote its result if its sub-builds have the same
:: results as ours.
::
=/ possible-build=^build
[date.u.last-sent.live.duct-status schematic.build]
?: (~(has by builds.state) possible-build)
`possible-build
(~(find-previous by-schematic builds-by-schematic.state) build)
(~(find-previous by-schematic builds-by-schematic.state) build)
:: if no previous builds exist, we need to run :build
::
?~ old-build
(add-build-to-next build)
::
=/ old-build-status=^build-status
~| [%missing-old-build (build-to-tape u.old-build)]
~| [%build-state (turn ~(tap in ~(key by builds.state)) build-to-tape)]
(~(got by builds.state) u.old-build)
:: selectively promote scry builds
::
:: We can only promote a scry if it's not forced and we ran the same
:: scry schematic as a descendant of the root build schematic at the
:: last sent time for this duct.
::
?: ?& ?=(%scry -.schematic.build)
?| force
?!
?& ?=(%live -.live.duct-status)
?=(^ last-sent.live.duct-status)
::
=/ subscription=(unit subscription)
subscription.u.last-sent.live.duct-status
::
?~ subscription
%.n
%- ~(has in resources.u.subscription)
resource.schematic.build
== == ==
(add-build-to-next build)
:: if we don't have :u.old-build's result cached, we need to run :build
::
=^ old-build-record builds.state (access-build-record u.old-build)
?. ?=([~ %value *] old-build-record)
(add-build-to-next build)
::
=. old-build-status (~(got by builds.state) u.old-build)
::
=/ old-subs=(list ^build) ~(tap in ~(key by subs.old-build-status))
=/ new-subs=(list ^build)
(turn old-subs |=(^build +<(date date.build)))
:: link sub-builds provisionally, blocking on incomplete
::
:: We don't know that :build will end up depending on :new-subs,
:: so they're not :verified.
::
=/ split-new-subs
%+ skid new-subs
|= sub=^build
^- ?
::
?~ maybe-build-status=(~(get by builds.state) sub)
%.n
::
?& ?=(%complete -.state.u.maybe-build-status)
?=(%value -.build-record.state.u.maybe-build-status)
==
::
=/ stored-new-subs=(list ^build) -.split-new-subs
=/ un-stored-new-subs=(list ^build) +.split-new-subs
::
=. builds.state
(add-subs-to-client build stored-new-subs [verified=%.n blocked=%.n])
=. builds.state
(add-subs-to-client build un-stored-new-subs [verified=%.n blocked=%.y])
::
=. state (add-anchors-to-build-subs build)
::
?^ un-stored-new-subs
:: enqueue incomplete sub-builds to be promoted or run
::
:: When not all our sub builds have results, we can't add :build to
:: :next-builds.state. Instead, put all the remaining uncached new
:: subs into :candidate-builds.
::
:: If all of our sub-builds finish immediately (i.e. promoted) when
:: they pass through +gather-internal, they will add :build back to
:: :candidate-builds and we will run again before +execute runs
:: +make.
::
%_ ..execute
candidate-builds
(~(gas in candidate-builds) un-stored-new-subs)
==
::
=^ promotable builds.state (are-subs-unchanged old-subs new-subs)
?. promotable
(add-build-to-next build)
::
?> =(schematic.build schematic.u.old-build)
?> (~(has by builds.state) build)
(promote-build u.old-build date.build new-subs)
:: +are-subs-unchanged: checks sub-build equivalence, updating access time
::
++ are-subs-unchanged
|= [old-subs=(list build) new-subs=(list build)]
^- [? _builds.state]
::
?~ old-subs
[%.y builds.state]
?> ?=(^ new-subs)
::
=^ old-build-record builds.state (access-build-record i.old-subs)
?. ?=([~ %value *] old-build-record)
[%.n builds.state]
::
=^ new-build-record builds.state (access-build-record i.new-subs)
?. ?=([~ %value *] new-build-record)
[%.n builds.state]
::
?. =(build-result.u.old-build-record build-result.u.new-build-record)
[%.n builds.state]
$(new-subs t.new-subs, old-subs t.old-subs)
:: +add-build-to-next: run this build during the +make phase
::
++ add-build-to-next
|= =build
..execute(next-builds (~(put in next-builds) build))
:: +promote-build: promote result of :build to newer :date
::
:: Also performs relevant accounting, and possibly sends %made moves.
::
++ promote-build
|= [old-build=build new-date=@da new-subs=(list build)]
^+ ..execute
:: grab the previous result, freshening the cache
::
=^ old-build-record builds.state (access-build-record old-build)
:: we can only promote a cached result, not missing or a %tombstone
::
?> ?=([~ %value *] old-build-record)
=/ =build-result build-result.u.old-build-record
:: :new-build is :old-build at :date; promotion destination
::
=/ new-build=build old-build(date new-date)
::
=. builds.state
%+ ~(jab by builds.state) new-build
|= =build-status
^+ build-status
::
%_ build-status
:: verify linkages between :new-build and subs
::
subs
::
^- (map build build-relation)
%- my
^- (list (pair build build-relation))
%+ turn new-subs
|= sub=build
::
[sub [verified=& blocked=|]]
:: copy the old result to :new-build
::
state
[%complete [%value last-accessed=now build-result=build-result]]
==
::
(on-build-complete new-build)
--
:: +run-builds: run the builds and produce +build-receipts
::
:: Runs the builds and cleans up the build lists afterwards.
::
:: When the vere interpreter has a parallel variant of +turn, use
:: that as each build might take a while and there are no data
:: dependencies between builds here. For now, though, run them serially.
::
++ run-builds
=< $
~% %run-builds + ~
|.
^- [(list build-receipt) _..execute]
::
=/ build-receipts=(list build-receipt)
(turn ~(tap in next-builds) make)
::
=. next-builds ~
[build-receipts ..execute]
:: reduce: apply +build-receipts produce from the +make phase.
::
:: +gather produces builds to run make on. +make produces
:: +build-receipts. It is in +reduce where we take these +build-receipts
:: and apply them to ..execute.
::
++ reduce !.
~/ %reduce
|= build-receipts=(list build-receipt)
^+ ..execute
:: sort :build-receipts so blocks are processed before completions
::
:: It's possible for a build to block on a sub-build that was run
:: in the same batch. If that's the case, make sure we register
:: that the build blocked on the sub-build before registering the
:: completion of the sub-build. This way, when we do register the
:: completion of the sub-build, we will know which builds are blocked
:: on the sub-build, so we can enqueue those blocked clients to be
:: rerun.
::
=. build-receipts
%+ sort build-receipts
|= [a=build-receipt b=build-receipt]
^- ?
?=(%blocks -.result.a)
::
|^ ^+ ..execute
?~ build-receipts ..execute
::
=. ..execute (apply-build-receipt i.build-receipts)
$(build-receipts t.build-receipts)
:: +apply-build-receipt: applies a single state diff to ..execute
::
++ apply-build-receipt
|= made=build-receipt
^+ ..execute
:: process :sub-builds.made
::
=. state (track-sub-builds build.made sub-builds.made)
::
?- -.result.made
%build-result
(apply-build-result [build build-result.result cache-access]:made)
::
%blocks
(apply-blocks [build builds.result]:made)
==
:: +track-sub-builds:
::
:: For every sub-build discovered while running :build, we have to make
:: sure that we track that sub-build and that it is associated with the
:: right ducts.
::
++ track-sub-builds
|= [client=build sub-builds=(list build)]
^+ state
:: mark :sub-builds as :subs in :build's +build-status
::
=^ build-status builds.state
%+ update-build-status client
|= =build-status
%_ build-status
subs
%- ~(gas by subs.build-status)
%+ turn sub-builds
|= sub=build
::
=/ blocked=?
?~ sub-status=(~(get by builds.state) sub)
%.y
!?=([%complete %value *] state.u.sub-status)
::
[sub [verified=& blocked]]
==
::
=. state (add-anchors-to-build-subs client)
::
|- ^+ state
?~ sub-builds state
::
=. builds.state
%+ ~(jab by builds.state) i.sub-builds
|= build-status=^build-status
%_ build-status
:: freshen :last-accessed date
::
state
::
?. ?=([%complete %value *] state.build-status)
state.build-status
state.build-status(last-accessed.build-record now)
==
::
$(sub-builds t.sub-builds)
:: +apply-build-result: apply a %build-result +build-receipt to ..execute
::
:: Our build produced an actual result.
::
++ apply-build-result
|= [=build =build-result cache-access=(unit [=compiler-cache-key new=?])]
^+ ..execute
::
=? compiler-cache.state ?=(^ cache-access)
=+ by-clock=(by-clock compiler-cache-key ^build-result)
?. new.u.cache-access
=^ ignored compiler-cache.state
(~(get by-clock compiler-cache.state) compiler-cache-key.u.cache-access)
compiler-cache.state
::
%+ ~(put by-clock compiler-cache.state)
compiler-cache-key.u.cache-access
build-result
::
=. builds.state
%+ ~(jab by builds.state) build
|= =build-status
build-status(state [%complete [%value last-accessed=now build-result]])
::
(on-build-complete build)
:: +apply-blocks: apply a %blocks +build-receipt to ..execute
::
:: :build blocked. Record information about what builds it blocked on
:: and try those blocked builds as candidates in the next pass.
::
++ apply-blocks
|= [=build blocks=(list build)]
^+ ..execute
:: if a %scry blocked, register it and maybe send an async request
::
=? ..execute
?=(~ blocks)
?> ?=(%scry -.schematic.build)
=, resource.schematic.build
%- start-scry-request
[vane care [[ship.disc.rail desk.disc.rail [%da date.build]] spur.rail]]
:: we must run +apply-build-receipt on :build.made before :block
::
?< %+ lien blocks
|= block=^build
?~ maybe-build-status=(~(get by builds.state) block)
%.n
?=(%complete -.state.u.maybe-build-status)
:: transition :build's state machine to the %blocked state
::
=. builds.state
%+ ~(jab by builds.state) build
|= =build-status
build-status(state [%blocked ~])
:: enqueue :blocks to be run next
::
=. candidate-builds (~(gas in candidate-builds) blocks)
::
..execute
--
:: +make: attempt to perform :build, non-recursively
::
:: Registers component linkages between :build and its sub-builds.
:: Attempts to perform +scry if necessary. Does not directly enqueue
:: any moves.
::
++ make
~/ %make
|= =build
^- build-receipt
:: out: receipt to return to caller
::
=| out=build-receipt
:: ~& [%turbo-make (build-to-tape build)]
:: dispatch based on the kind of +schematic in :build
::
|^ =, schematic.build
::
=. build.out build
::
?- -.schematic.build
::
^ (make-autocons [head tail])
::
%$ (make-literal literal)
::
%pin (make-pin date schematic)
%alts (make-alts choices ~)
%bake (make-bake renderer query-string path-to-render)
%bunt (make-bunt disc mark)
%call (make-call gate sample)
%cast (make-cast disc mark input)
%core (make-core source-path)
%diff (make-diff disc start end)
%dude (make-dude error attempt)
%hood (make-hood source-path)
%join (make-join disc mark first second)
%list (make-list schematics)
%mash (make-mash disc mark first second)
%mute (make-mute subject mutations)
%pact (make-pact disc start diff)
%path (make-path disc prefix raw-path)
%plan (make-plan path-to-render query-string scaffold)
%reef (make-reef disc)
%ride (make-ride formula subject)
%same (make-same schematic)
%scry (make-scry resource)
%slim (make-slim subject-type formula)
%slit (make-slit gate sample)
%vale (make-vale disc mark input)
%volt (make-volt disc mark input)
%walk (make-walk disc source target)
==
:: |schematic-handlers:make: implementation of the schematics
::
:: All of these produce a value of the same type as +make itself.
::
:: +| schematic-handlers
::
++ make-autocons
~% %make-autocons ..^^$ ~
|= [head=schematic tail=schematic]
^- build-receipt
::
=/ head-build=^build [date.build head]
=/ tail-build=^build [date.build tail]
=^ head-result out (depend-on head-build)
=^ tail-result out (depend-on tail-build)
::
=| blocks=(list ^build)
=? blocks ?=(~ head-result) [head-build blocks]
=? blocks ?=(~ tail-result) [tail-build blocks]
:: if either build blocked, we're not done
::
?^ blocks
::
(return-blocks blocks)
::
?< ?=(~ head-result)
?< ?=(~ tail-result)
::
(return-result %success u.head-result u.tail-result)
::
++ make-literal
~% %make-literal ..^^$ ~
|= =cage
^- build-receipt
(return-result %success %$ cage)
::
++ make-pin
~% %make-pin ..^^$ ~
|= [date=@da =schematic]
^- build-receipt
:: pinned-sub: sub-build with the %pin date as formal date
::
=/ pinned-sub=^build [date schematic]
::
=^ result out (depend-on pinned-sub)
::
?~ result
(return-blocks ~[pinned-sub])
::
(return-result u.result)
::
++ make-alts
~% %make-alts ..^^$ ~
|= [choices=(list schematic) errors=(list tank)]
^- build-receipt
::
?~ choices
(return-error [[%leaf "%alts: all options failed"] errors])
::
=/ choice=^build [date.build i.choices]
::
=^ result out (depend-on choice)
?~ result
(return-blocks ~[choice])
::
?: ?=([%error *] u.result)
::
=/ braces [[' ' ' ' ~] ['{' ~] ['}' ~]]
=/ wrapped-error=tank
[%rose braces `(list tank)`message.u.result]
=. errors
(weld errors `(list tank)`[[%leaf "option"] wrapped-error ~])
$(choices t.choices)
::
(return-result %success %alts u.result)
::
++ make-bake
~% %make-bake ..^^$ ~
|= [renderer=term query-string=coin path-to-render=rail]
^- build-receipt
:: path-build: find the file path for the renderer source
::
=/ path-build=^build
[date.build [%path disc.path-to-render %ren renderer]]
::
=^ path-result out (depend-on path-build)
?~ path-result
(return-blocks [path-build]~)
::
|^ ^- build-receipt
:: if there's a renderer called :renderer, use it on :path-to-render
::
:: Otherwise, fall back to running the contents of :path-to-render
:: through a mark that has the same name as :renderer.
::
?: ?=([~ %success %path *] path-result)
(try-renderer-then-mark rail.u.path-result)
(try-mark ~)
:: +try-renderer-then-mark: try to render a path, then fall back to mark
::
++ try-renderer-then-mark
|= =rail
^- build-receipt
:: build a +scaffold from the renderer source
::
=/ hood-build=^build [date.build [%hood rail]]
::
=^ hood-result out (depend-on hood-build)
?~ hood-result
(return-blocks [hood-build]~)
:: if we can't find and parse the renderer, try the mark instead
::
?: ?=([~ %error *] hood-result)
(try-mark message.u.hood-result)
?> ?=([~ %success %hood *] hood-result)
:: link the renderer, passing through :path-to-render and :query-string
::
=/ plan-build=^build
:- date.build
[%plan path-to-render query-string scaffold.u.hood-result]
::
=^ plan-result out (depend-on plan-build)
?~ plan-result
(return-blocks [plan-build]~)
:: if compiling the renderer errors out, try the mark instead
::
?: ?=([~ %error *] plan-result)
(try-mark message.u.plan-result)
?> ?=([~ %success %plan *] plan-result)
:: renderers return their name as the mark
::
:: We should rethink whether we want this to be the case going
:: forward, but for now, Eyre depends on this detail to work.
::
(return-result [%success %bake renderer vase.u.plan-result])
:: +try-mark: try to cast a file's contents through a mark
::
:: :errors contains any error messages from our previous attempt to
:: run a renderer, if we made one. This way if both the renderer and
:: mark fail, the requester will see the errors of both attempts.
::
++ try-mark
|= errors=(list tank)
^- build-receipt
:: no renderer, try mark; retrieve directory listing of :path-to-render
::
:: There might be multiple files of different marks stored at
:: :path-to-render. Retrieve the directory listing for
:: :path-to-render, then check which of the path segments in
:: that directory are files (not just folders), then for each
:: file try to %cast its mark to the desired mark (:renderer).
::
:: Start by retrieving the directory listing, using :toplevel-build.
::
=/ toplevel-build=^build
[date.build [%scry %c %y path-to-render]]
::
=^ toplevel-result out (depend-on toplevel-build)
?~ toplevel-result
(return-blocks [toplevel-build]~)
::
?: ?=([~ %error *] toplevel-result)
::
=/ =path (rail-to-path path-to-render)
?~ errors
%- return-error
:- [%leaf "ford: %bake {<renderer>} on {<path>} failed:"]
message.u.toplevel-result
::
=/ braces [[' ' ' ' ~] ['{' ~] ['}' ~]]
%- return-error :~
[%leaf "ford: %bake {<renderer>} on {<path>} failed:"]
[%leaf "as-renderer"]
[%rose braces errors]
[%leaf "as-mark"]
[%rose braces message.u.toplevel-result]
==
?> ?=([~ %success %scry *] toplevel-result)
::
=/ toplevel-arch=arch ;;(arch q.q.cage.u.toplevel-result)
:: find the :sub-path-segments that could be files
::
:: Filter out path segments that aren't a +term,
:: since those aren't valid marks and therefore can't
:: be the last segment of a filepath in Clay.
::
=/ sub-path-segments=(list @ta)
(skim (turn ~(tap by dir.toplevel-arch) head) (sane %tas))
::
=/ sub-schematics=(list [sub-path=@ta =schematic])
%+ turn sub-path-segments
|= sub=@ta
:- sub
[%scry %c %y path-to-render(spur [sub spur.path-to-render])]
::
=^ maybe-schematic-results out
%- perform-schematics :*
;: weld
"ford: %bake " (trip renderer) " on "
(spud (rail-to-path path-to-render)) " contained failures:"
==
sub-schematics
%fail-on-errors
*@ta
==
?~ maybe-schematic-results
out
:: marks: list of the marks of the files at :path-to-render
::
=/ marks=(list @tas)
%+ murn u.maybe-schematic-results
|= [sub-path=@ta result=build-result]
^- (unit @tas)
::
?> ?=([%success %scry *] result)
::
=/ =arch ;;(arch q.q.cage.result)
:: if it's a directory, not a file, we can't load it
::
?~ fil.arch
~
[~ `@tas`sub-path]
:: sort marks in alphabetical order
::
=. marks (sort marks lte)
:: try to convert files to the destination mark, in order
::
=/ alts-build=^build
::
:+ date.build %alts
^= choices ^- (list schematic)
::
%+ turn marks
|= mark=term
^- schematic
::
=/ file=rail path-to-render(spur [mark spur.path-to-render])
::
[%cast disc.file renderer [%scry %c %x file]]
::
=^ alts-result out (depend-on alts-build)
?~ alts-result
(return-blocks [alts-build]~)
::
?: ?=([~ %error *] alts-result)
=/ =path (rail-to-path path-to-render)
?~ errors
%- return-error
:- [%leaf "ford: %bake {<renderer>} on {<path>} failed:"]
message.u.alts-result
::
=/ braces [[' ' ' ' ~] ['{' ~] ['}' ~]]
%- return-error :~
[%leaf "ford: %bake {<renderer>} on {<path>} failed:"]
[%leaf "as-renderer"]
[%rose braces errors]
[%leaf "as-mark"]
[%rose braces message.u.alts-result]
==
::
?> ?=([~ %success %alts *] alts-result)
::
=/ =build-result
[%success %bake (result-to-cage u.alts-result)]
::
(return-result build-result)
--
::
++ make-bunt
~% %make-bunt ..^^$ ~
|= [=disc mark=term]
^- build-receipt
:: resolve path of the mark definition file
::
=/ path-build=^build [date.build [%path disc %mar mark]]
::
=^ path-result out (depend-on path-build)
?~ path-result
(return-blocks [path-build]~)
::
?: ?=([~ %error *] path-result)
%- return-error
:_ message.u.path-result
:- %leaf
"ford: %bunt resolving path for {<mark>} on {<disc>} failed:"
::
?> ?=([~ %success %path *] path-result)
:: build the mark core from source
::
=/ core-build=^build [date.build [%core rail.u.path-result]]
::
=^ core-result out (depend-on core-build)
?~ core-result
(return-blocks [core-build]~)
::
?: ?=([~ %error *] core-result)
%- return-error
:_ message.u.core-result
:- %leaf
"ford: %bunt compiling mark {<mark>} on {<disc>} failed:"
::
?> ?=([~ %success %core *] core-result)
:: extract the sample from the mark core
::
=/ mark-vase=vase vase.u.core-result
~| %mark-vase
=+ [sample-type=p sample-value=q]:(slot 6 mark-vase)
:: if sample is wrapped in a face, unwrap it
::
=? sample-type ?=(%face -.sample-type) q.sample-type
::
=/ =cage [mark sample-type sample-value]
(return-result %success %bunt cage)
::
++ make-call
~% %make-call ..^^$ ~
|= [gate=schematic sample=schematic]
^- build-receipt
::
=/ gate-build=^build [date.build gate]
=^ gate-result out (depend-on gate-build)
::
=/ sample-build=^build [date.build sample]
=^ sample-result out (depend-on sample-build)
::
=| blocks=(list ^build)
=? blocks ?=(~ gate-result) [[date.build gate] blocks]
=? blocks ?=(~ sample-result) [[date.build sample] blocks]
?^ blocks
(return-blocks blocks)
::
?< ?=(~ gate-result)
?: ?=([~ %error *] gate-result)
%- return-error
:- [%leaf "ford: %call failed to build gate:"]
message.u.gate-result
::
?< ?=(~ sample-result)
?: ?=([~ %error *] sample-result)
%- return-error
:- [%leaf "ford: %call failed to build sample:"]
message.u.sample-result
::
=/ gate-vase=vase q:(result-to-cage u.gate-result)
=/ sample-vase=vase q:(result-to-cage u.sample-result)
:: run %slit to get the resulting type of calculating the gate
::
=/ slit-schematic=schematic [%slit gate-vase sample-vase]
=/ slit-build=^build [date.build slit-schematic]
=^ slit-result out (depend-on slit-build)
?~ slit-result
(return-blocks [date.build slit-schematic]~)
::
?: ?=([~ %error *] slit-result)
%- return-error
:- [%leaf "ford: %call failed type calculation"]
message.u.slit-result
::
?> ?=([~ %success %slit *] slit-result)
::
=/ =compiler-cache-key [%call gate-vase sample-vase]
=^ cached-result out (access-cache compiler-cache-key)
?^ cached-result
(return-result u.cached-result)
::
?> &(?=(^ q.gate-vase) ?=(^ +.q.gate-vase))
=/ val
(mong [q.gate-vase q.sample-vase] intercepted-scry)
::
?- -.val
%0
(return-result %success %call [type.u.slit-result p.val])
::
%1
=/ blocked-paths=(list path) ;;((list path) p.val)
(blocked-paths-to-receipt %call blocked-paths)
::
%2
(return-error [[%leaf "ford: %call execution failed:"] p.val])
==
::
++ make-cast
~% %make-cast ..^^$ ~
|= [=disc mark=term input=schematic]
^- build-receipt
::
=/ input-build=^build [date.build input]
::
=^ input-result out (depend-on input-build)
?~ input-result
(return-blocks [input-build]~)
::
?: ?=([~ %error *] input-result)
%- return-error
:_ message.u.input-result
:- %leaf
;: weld
"ford: %cast " (trip mark) " on [" (trip (scot %p ship.disc))
" " (trip desk.disc) "] failed on input:"
==
::
?> ?=([~ %success *] input-result)
::
=/ result-cage=cage (result-to-cage u.input-result)
::
=/ translation-path-build=^build
[date.build [%walk disc p.result-cage mark]]
=^ translation-path-result out
(depend-on translation-path-build)
::
?~ translation-path-result
(return-blocks [translation-path-build]~)
::
?: ?=([~ %error *] translation-path-result)
%- return-error
:_ message.u.translation-path-result
:- %leaf
;: weld
"ford: %cast " (trip mark) " on [" (trip (scot %p ship.disc))
" " (trip desk.disc) "] failed:"
==
::
?> ?=([~ %success %walk *] translation-path-result)
::
=/ translation-path=(list mark-action)
results.u.translation-path-result
::
|^ ^- build-receipt
?~ translation-path
(return-result %success %cast result-cage)
::
=^ action-result out
=, i.translation-path
?- -.i.translation-path
%grow (run-grow source target result-cage)
%grab (run-grab source target result-cage)
==
::
?- -.action-result
%success
%_ $
translation-path t.translation-path
result-cage cage.action-result
==
::
%blocks
(return-blocks blocks.action-result)
::
%error
(return-error [leaf+"ford: failed to %cast" tang.action-result])
==
::
+= action-result
$% :: translation was successful and here's a cage for you
[%success =cage]
:: it was an error. sorry.
[%error =tang]
:: we block on a build
[%blocks blocks=(list ^build)]
==
::
++ run-grab
|= [source-mark=term target-mark=term input-cage=cage]
^- [action-result _out]
::
=/ mark-path-build=^build
[date.build [%path disc %mar target-mark]]
::
=^ mark-path-result out
(depend-on mark-path-build)
?~ mark-path-result
[[%blocks [mark-path-build]~] out]
::
?. ?=([~ %success %path *] mark-path-result)
%- cast-wrap-error :*
source-mark
target-mark
;: weld
"ford: %cast failed to find path for mark " (trip source-mark)
" during +grab:"
==
mark-path-result
==
::
=/ mark-core-build=^build [date.build [%core rail.u.mark-path-result]]
::
=^ mark-core-result out (depend-on mark-core-build)
?~ mark-core-result
[[%blocks ~[mark-core-build]] out]
:: find +grab within the destination mark core
::
=/ grab-build=^build
:- date.build
[%ride [%limb %grab] [%$ (result-to-cage u.mark-core-result)]]
::
=^ grab-result out (depend-on grab-build)
?~ grab-result
[[%blocks [grab-build]~] out]
::
?. ?=([~ %success %ride *] grab-result)
=/ =path (rail-to-path rail.u.mark-path-result)
%- cast-wrap-error :*
source-mark
target-mark
:(weld "ford: %cast failed to ride " (spud path) " during +grab:")
grab-result
==
:: find an arm for the input's mark within the +grab core
::
=/ grab-mark-build=^build
:- date.build
[%ride [%limb source-mark] [%$ %noun vase.u.grab-result]]
::
=^ grab-mark-result out (depend-on grab-mark-build)
?~ grab-mark-result
[[%blocks [grab-mark-build]~] out]
::
?. ?=([~ %success %ride *] grab-mark-result)
=/ =path (rail-to-path rail.u.mark-path-result)
%- cast-wrap-error :*
source-mark
target-mark
:(weld "ford: %cast failed to ride " (spud path) " during +grab:")
grab-mark-result
==
:: slam the +mark-name:grab gate on the result of running :input
::
=/ call-build=^build
:- date.build
[%call gate=[%$ %noun vase.u.grab-mark-result] sample=[%$ input-cage]]
::
=^ call-result out (depend-on call-build)
?~ call-result
[[%blocks [call-build]~] out]
::
?. ?=([~ %success %call *] call-result)
=/ =path (rail-to-path rail.u.mark-path-result)
%- cast-wrap-error :*
source-mark
target-mark
:(weld "ford: %cast failed to call +grab arm in " (spud path) ":")
call-result
==
::
[[%success [mark vase.u.call-result]] out]
:: +grow: grow from the input mark to the destination mark
::
++ run-grow
|= [source-mark=term target-mark=term input-cage=cage]
^- [action-result _out]
::
=/ starting-mark-path-build=^build
[date.build [%path disc %mar source-mark]]
::
=^ starting-mark-path-result out
(depend-on starting-mark-path-build)
?~ starting-mark-path-result
[[%blocks [starting-mark-path-build]~] out]
::
?. ?=([~ %success %path *] starting-mark-path-result)
%- cast-wrap-error :*
source-mark
target-mark
;: weld
"ford: %cast failed to find path for mark " (trip source-mark)
" during +grow:"
==
starting-mark-path-result
==
:: grow the value from the initial mark to the final mark
::
:: Replace the input mark's sample with the input's result,
:: then fire the mark-name:grow arm to produce a result.
::
=/ grow-build=^build
:- date.build
:+ %ride
formula=`hoon`[%tsld [%wing ~[target-mark]] [%wing ~[%grow]]]
^= subject
^- schematic
:* %mute
^- schematic
[%core rail.u.starting-mark-path-result]
^= mutations
^- (list [wing schematic])
[[%& 6]~ [%$ input-cage]]~
==
::
=^ grow-result out (depend-on grow-build)
?~ grow-result
[[%blocks [grow-build]~] out]
::
?. ?=([~ %success %ride *] grow-result)
=/ =path (rail-to-path rail.u.starting-mark-path-result)
%- cast-wrap-error :*
source-mark
target-mark
:(weld "ford: %cast failed to ride " (spud path) " during +grow:")
grow-result
==
:: make sure the product nests in the sample of the destination mark
::
=/ bunt-build=^build [date.build [%bunt disc target-mark]]
::
=^ bunt-result out (depend-on bunt-build)
?~ bunt-result
[[%blocks [bunt-build]~] out]
::
?. ?=([~ %success %bunt *] bunt-result)
%- cast-wrap-error :*
source-mark
target-mark
:(weld "ford: %cast failed to bunt " (trip target-mark) ":")
bunt-result
==
::
?. (~(nest ut p.q.cage.u.bunt-result) | p.vase.u.grow-result)
=* src source-mark
=* dst target-mark
:_ out
:- %error
:_ ~
:- %leaf
;: weld
"ford: %cast from " (trip src) " to " (trip dst)
" failed: nest fail"
==
::
[[%success mark vase.u.grow-result] out]
::
++ cast-wrap-error
|= $: source-mark=term
target-mark=term
description=tape
result=(unit build-result)
==
^- [action-result _out]
::
?> ?=([~ %error *] result)
::
:_ out
:- %error
:* :- %leaf
;: weld
"ford: %cast failed while trying to cast from "
(trip source-mark) " to " (trip target-mark) ":"
==
[%leaf description]
message.u.result
==
--
::
++ make-core
~% %make-core ..^^$ ~
|= source-path=rail
^- build-receipt
:: convert file at :source-path to a +scaffold
::
=/ hood-build=^build [date.build [%hood source-path]]
::
=^ hood-result out (depend-on hood-build)
?~ hood-result
(return-blocks [hood-build]~)
::
?: ?=(%error -.u.hood-result)
%- return-error
:- [%leaf "ford: %core on {<(rail-to-path source-path)>} failed:"]
message.u.hood-result
:: build the +scaffold into a program
::
?> ?=([%success %hood *] u.hood-result)
::
=/ plan-build=^build
[date.build [%plan source-path `coin`[%many ~] scaffold.u.hood-result]]
::
=^ plan-result out (depend-on plan-build)
?~ plan-result
(return-blocks [plan-build]~)
::
?: ?=(%error -.u.plan-result)
%- return-error
:- [%leaf "ford: %core on {<(rail-to-path source-path)>} failed:"]
message.u.plan-result
::
?> ?=([%success %plan *] u.plan-result)
(return-result %success %core vase.u.plan-result)
::
++ make-diff
~% %make-diff ..^^$ ~
|= [=disc start=schematic end=schematic]
^- build-receipt
:: run both input schematics as an autocons build
::
=/ sub-build=^build [date.build [start end]]
::
=^ sub-result out (depend-on sub-build)
?~ sub-result
(return-blocks [sub-build]~)
::
?. ?=([~ %success ^ ^] sub-result)
(wrap-error sub-result)
?. ?=([%success *] head.u.sub-result)
(wrap-error `head.u.sub-result)
?. ?=([%success *] tail.u.sub-result)
(wrap-error `tail.u.sub-result)
::
=/ start-cage=cage (result-to-cage head.u.sub-result)
=/ end-cage=cage (result-to-cage tail.u.sub-result)
:: if the marks aren't the same, we can't diff them
::
?. =(p.start-cage p.end-cage)
%- return-error :_ ~ :- %leaf
"ford: %diff failed: mark mismatch: %{<p.start-cage>} / %{<p.end-cage>}"
:: if the values are the same, the diff is null
::
?: =(q.q.start-cage q.q.end-cage)
=/ =build-result
[%success %diff [%null [%atom %n ~] ~]]
::
(return-result build-result)
::
=/ mark-path-build=^build [date.build [%path disc %mar p.start-cage]]
::
=^ mark-path-result out (depend-on mark-path-build)
?~ mark-path-result
(return-blocks [mark-path-build]~)
::
?: ?=([~ %error *] mark-path-result)
%- return-error
:- [%leaf "ford: %diff failed on {<disc>}:"]
message.u.mark-path-result
::
?> ?=([~ %success %path *] mark-path-result)
::
=/ mark-build=^build [date.build [%core rail.u.mark-path-result]]
::
=^ mark-result out (depend-on mark-build)
?~ mark-result
(return-blocks [mark-build]~)
::
?: ?=([~ %error *] mark-result)
%- return-error
:- [%leaf "ford: %diff failed on {<disc>}:"]
message.u.mark-result
::
?> ?=([~ %success %core *] mark-result)
::
?. (slab %grad p.vase.u.mark-result)
%- return-error :_ ~ :- %leaf
"ford: %diff failed: %{<p.start-cage>} mark has no +grad arm"
::
=/ grad-build=^build
[date.build [%ride [%limb %grad] [%$ %noun vase.u.mark-result]]]
::
=^ grad-result out (depend-on grad-build)
?~ grad-result
(return-blocks [grad-build]~)
::
?: ?=([~ %error *] grad-result)
%- return-error
:- [%leaf "ford: %diff failed on {<disc>}:"]
message.u.grad-result
::
?> ?=([~ %success %ride *] grad-result)
:: if +grad produced a @tas, convert to that mark and diff those
::
?@ q.vase.u.grad-result
=/ mark=(unit @tas) ((sand %tas) q.vase.u.grad-result)
?~ mark
%- return-error :_ ~ :- %leaf
"ford: %diff failed: %{<p.start-cage>} mark has invalid +grad arm"
::
=/ diff-build=^build
:- date.build
:^ %diff
disc
[%cast disc u.mark [%$ start-cage]]
[%cast disc u.mark [%$ end-cage]]
::
=^ diff-result out (depend-on diff-build)
?~ diff-result
(return-blocks [diff-build]~)
::
?. ?=([~ %success %diff *] diff-result)
(wrap-error diff-result)
::
=/ =build-result
[%success %diff cage.u.diff-result]
::
(return-result build-result)
:: +grad produced a cell, which should be a core with a +form arm
::
?. (slab %form p.vase.u.grad-result)
%- return-error :_ ~ :- %leaf
"ford: %diff failed: %{<p.start-cage>} mark has no +form:grab arm"
:: the +grab core should also contain a +diff arm
::
?. (slab %diff p.vase.u.grad-result)
%- return-error :_ ~ :- %leaf
"ford: %diff failed: %{<p.start-cage>} mark has no +diff:grab arm"
::
=/ diff-build=^build
:- date.build
:+ %call
::
^= gate
:+ %ride
::
formula=`hoon`[%tsld [%wing ~[%diff]] [%wing ~[%grad]]]
::
^= subject
:+ %mute
::
subject=`schematic`[%$ %noun vase.u.mark-result]
::
^= mutations
^- (list [wing schematic])
[[%& 6]~ [%$ start-cage]]~
::
sample=`schematic`[%$ end-cage]
::
=^ diff-result out (depend-on diff-build)
?~ diff-result
(return-blocks [diff-build]~)
::
?. ?=([~ %success %call *] diff-result)
(wrap-error diff-result)
::
=/ form-build=^build
[date.build [%ride [%limb %form] [%$ %noun vase.u.grad-result]]]
::
=^ form-result out (depend-on form-build)
?~ form-result
(return-blocks [form-build]~)
::
?. ?=([~ %success %ride *] form-result)
(wrap-error form-result)
::
=/ mark=(unit @tas) ((soft @tas) q.vase.u.form-result)
?~ mark
%- return-error :_ ~ :- %leaf
"ford: %diff failed: invalid +form result: {(text vase.u.form-result)}"
::
=/ =build-result
[%success %diff [u.mark vase.u.diff-result]]
::
(return-result build-result)
::
++ make-dude
~% %make-dude ..^^$ ~
|= [error=tank attempt=schematic]
^- build-receipt
::
=/ attempt-build=^build [date.build attempt]
=^ attempt-result out (depend-on attempt-build)
?~ attempt-result
::
(return-blocks ~[[date.build attempt]])
::
?. ?=([%error *] u.attempt-result)
(return-result u.attempt-result)
::
(return-error [error message.u.attempt-result])
::
++ make-hood
~% %make-hood ..^^$ ~
|= source-rail=rail
^- build-receipt
::
=/ scry-build=^build [date.build [%scry [%c %x source-rail]]]
=^ scry-result out (depend-on scry-build)
?~ scry-result
::
(return-blocks ~[scry-build])
::
?: ?=([~ %error *] scry-result)
=/ =path (rail-to-path source-rail)
%- return-error
:- [%leaf "ford: %hood failed for {<path>}:"]
message.u.scry-result
=+ as-cage=(result-to-cage u.scry-result)
:: hoon files must be atoms to parse
::
?. ?=(@ q.q.as-cage)
=/ =path (rail-to-path source-rail)
%- return-error
:_ ~
:- %leaf
"ford: %hood: path {<path>} not an atom"
::
=/ src-beam=beam [[ship.disc desk.disc [%ud 0]] spur]:source-rail
::
=/ =compiler-cache-key [%hood src-beam q.q.as-cage]
=^ cached-result out (access-cache compiler-cache-key)
?^ cached-result
(return-result u.cached-result)
::
=/ parsed
((full (parse-scaffold src-beam)) [1 1] (trip q.q.as-cage))
::
?~ q.parsed
=/ =path (rail-to-path source-rail)
%- return-error
:- :- %leaf
%+ weld "ford: %hood: syntax error at "
"[{<p.p.parsed>} {<q.p.parsed>}] in {<path>}"
~
::
(return-result %success %hood p.u.q.parsed)
::
++ make-join
~% %make-join ..^^$ ~
|= [disc=disc mark=term first=schematic second=schematic]
^- build-receipt
::
=/ initial-build=^build
[date.build [first second] [%path disc %mar mark]]
::
=^ initial-result out (depend-on initial-build)
?~ initial-result
(return-blocks [initial-build]~)
::
?. ?=([~ %success [%success ^ ^] %success %path *] initial-result)
(wrap-error initial-result)
?. ?=([%success *] head.head.u.initial-result)
(wrap-error `head.head.u.initial-result)
?. ?=([%success *] tail.head.u.initial-result)
(wrap-error `tail.head.u.initial-result)
::
=/ first-cage=cage (result-to-cage head.head.u.initial-result)
=/ second-cage=cage (result-to-cage tail.head.u.initial-result)
=/ mark-path=rail rail.tail.u.initial-result
:: TODO: duplicate logic with +make-pact and others
::
=/ mark-build=^build [date.build [%core mark-path]]
::
=^ mark-result out (depend-on mark-build)
?~ mark-result
(return-blocks [mark-build]~)
::
?: ?=([~ %error *] mark-result)
%- return-error
:- [%leaf "ford: %join to {<mark>} on {<disc>} failed:"]
message.u.mark-result
::
?> ?=([~ %success %core *] mark-result)
::
=/ mark-vase=vase vase.u.mark-result
::
?. (slab %grad p.mark-vase)
%- return-error :_ ~ :- %leaf
"ford: %join failed: %{<mark>} mark has no +grad arm"
::
=/ grad-build=^build
[date.build [%ride [%limb %grad] [%$ %noun mark-vase]]]
::
=^ grad-result out (depend-on grad-build)
?~ grad-result
(return-blocks [grad-build]~)
::
?: ?=([~ %error *] grad-result)
%- return-error
:- [%leaf "ford: %join to {<mark>} on {<disc>} failed:"]
message.u.grad-result
::
?> ?=([~ %success %ride *] grad-result)
::
=/ grad-vase=vase vase.u.grad-result
:: if +grad produced a mark, delegate %join behavior to that mark
::
?@ q.grad-vase
:: if +grad produced a term, make sure it's a valid mark
::
=/ grad-mark=(unit term) ((sand %tas) q.grad-vase)
?~ grad-mark
%- return-error :_ ~ :- %leaf
"ford: %join failed: %{<mark>} mark invalid +grad"
:: todo: doesn't catch full cycles of +grad arms, only simple cases
::
?: =(u.grad-mark mark)
%- return-error :_ ~ :- %leaf
"ford: %join failed: %{<mark>} mark +grad arm refers to self"
::
=/ join-build=^build
[date.build [%join disc u.grad-mark [%$ first-cage] [%$ second-cage]]]
::
=^ join-result out (depend-on join-build)
?~ join-result
(return-blocks [join-build]~)
::
?: ?=([~ %error *] join-result)
%- return-error
:- [%leaf "ford: %join to {<mark>} on {<disc>} failed:"]
message.u.join-result
::
?> ?=([~ %success %join *] join-result)
::
(return-result u.join-result)
:: make sure the +grad core has a +form arm
::
?. (slab %form p.grad-vase)
%- return-error :_ ~ :- %leaf
"ford: %join failed: no +form:grad in %{<mark>} mark"
:: make sure the +grad core has a +join arm
::
?. (slab %join p.grad-vase)
%- return-error :_ ~ :- %leaf
"ford: %join failed: no +join:grad in %{<mark>} mark"
:: fire the +form:grad arm, which should produce a mark
::
=/ form-build=^build
[date.build [%ride [%limb %form] [%$ %noun grad-vase]]]
::
=^ form-result out (depend-on form-build)
?~ form-result
(return-blocks [form-build]~)
::
?. ?=([~ %success %ride *] form-result)
(wrap-error form-result)
::
=/ form-mark=(unit term) ((soft @tas) q.vase.u.form-result)
?~ form-mark
%- return-error :_ ~ :- %leaf
"ford: %join failed: %{<mark>} mark invalid +form:grad"
:: the mark produced by +form:grad should match both diffs
::
?. &(=(u.form-mark p.first-cage) =(u.form-mark p.second-cage))
%- return-error :_ ~ :- %leaf
"ford: %join failed: mark mismatch"
:: if the diffs are identical, just produce the first
::
?: =(q.q.first-cage q.q.second-cage)
(return-result %success %join first-cage)
:: call the +join:grad gate on the two diffs
::
=/ diff-build=^build
:- date.build
:+ %call
:+ %ride
[%limb %join]
[%$ %noun grad-vase]
[%$ %noun (slop q.first-cage q.second-cage)]
::
=^ diff-result out (depend-on diff-build)
?~ diff-result
(return-blocks [diff-build]~)
::
?: ?=([~ %error *] diff-result)
%- return-error
:- [%leaf "ford: %join to {<mark>} on {<disc>} failed:"]
message.u.diff-result
::
?> ?=([~ %success %call *] diff-result)
:: the result was a unit; if `~`, use %null mark; otherwise grab tail
::
=/ =build-result
:+ %success %join
?@ q.vase.u.diff-result
[%null vase.u.diff-result]
[u.form-mark (slot 3 vase.u.diff-result)]
::
(return-result build-result)
::
++ make-list
~% %make-list ..^^$ ~
|= schematics=(list schematic)
^- build-receipt
::
=/ key-and-schematics
(turn schematics |=(=schematic [~ schematic]))
:: depend on builds of each schematic
::
=^ maybe-schematic-results out
(perform-schematics "" key-and-schematics %ignore-errors *~)
?~ maybe-schematic-results
out
:: return all builds
::
=/ =build-result
:+ %success %list
:: the roll above implicitly flopped the results
::
(flop (turn u.maybe-schematic-results tail))
(return-result build-result)
::
++ make-mash
~% %make-mash ..^^$ ~
|= $: disc=disc
mark=term
first=[disc=disc mark=term =schematic]
second=[disc=disc mark=term =schematic]
==
^- build-receipt
::
=/ initial-build=^build
[date.build [schematic.first schematic.second] [%path disc %mar mark]]
::
=^ initial-result out (depend-on initial-build)
?~ initial-result
(return-blocks [initial-build]~)
:: TODO: duplicate logic with +make-join
::
?. ?=([~ %success [%success ^ ^] %success %path *] initial-result)
(wrap-error initial-result)
?. ?=([%success *] head.head.u.initial-result)
(wrap-error `head.head.u.initial-result)
?. ?=([%success *] tail.head.u.initial-result)
(wrap-error `tail.head.u.initial-result)
::
=/ first-cage=cage (result-to-cage head.head.u.initial-result)
=/ second-cage=cage (result-to-cage tail.head.u.initial-result)
=/ mark-path=rail rail.tail.u.initial-result
:: TODO: duplicate logic with +make-pact and others
::
=/ mark-build=^build [date.build [%core mark-path]]
::
=^ mark-result out (depend-on mark-build)
?~ mark-result
(return-blocks [mark-build]~)
::
?. ?=([~ %success %core *] mark-result)
(wrap-error mark-result)
::
=/ mark-vase=vase vase.u.mark-result
::
?. (slab %grad p.mark-vase)
%- return-error :_ ~ :- %leaf
"ford: %mash failed: %{<mark>} mark has no +grad arm"
::
=/ grad-build=^build
[date.build [%ride [%limb %grad] [%$ %noun mark-vase]]]
::
=^ grad-result out (depend-on grad-build)
?~ grad-result
(return-blocks [grad-build]~)
::
?. ?=([~ %success %ride *] grad-result)
(wrap-error grad-result)
::
=/ grad-vase=vase vase.u.grad-result
:: if +grad produced a mark, delegate %mash behavior to that mark
::
?@ q.grad-vase
:: if +grad produced a term, make sure it's a valid mark
::
=/ grad-mark=(unit term) ((sand %tas) q.grad-vase)
?~ grad-mark
%- return-error :_ ~ :- %leaf
"ford: %mash failed: %{<mark>} mark invalid +grad"
::
=/ mash-build=^build
:- date.build
:- %mash
:^ disc u.grad-mark
[disc.first mark.first [%$ first-cage]]
[disc.second mark.second [%$ second-cage]]
::
=^ mash-result out (depend-on mash-build)
?~ mash-result
(return-blocks [mash-build]~)
::
?. ?=([~ %success %mash *] mash-result)
(wrap-error mash-result)
::
=/ =build-result
[%success %mash cage.u.mash-result]
::
(return-result build-result)
::
?. (slab %form p.grad-vase)
%- return-error :_ ~ :- %leaf
"ford: %mash failed: %{<mark>} mark has no +form:grad"
::
?. (slab %mash p.grad-vase)
%- return-error :_ ~ :- %leaf
"ford: %mash failed: %{<mark>} mark has no +mash:grad"
::
=/ form-build=^build
[date.build [%ride [%limb %form] [%$ %noun grad-vase]]]
::
=^ form-result out (depend-on form-build)
?~ form-result
(return-blocks [form-build]~)
::
?. ?=([~ %success %ride *] form-result)
(wrap-error form-result)
::
=/ form-mark=(unit term) ((soft @tas) q.vase.u.form-result)
?~ form-mark
%- return-error :_ ~ :- %leaf
"ford: %mash failed: %{<mark>} mark invalid +form:grad"
::
?. &(=(u.form-mark p.first-cage) =(u.form-mark p.second-cage))
%- return-error :_ ~ :- %leaf
"ford: %mash failed: mark mismatch"
::
?: =(q.q.first-cage q.q.second-cage)
=/ =build-result
[%success %mash [%null [%atom %n ~] ~]]
::
(return-result build-result)
:: call the +mash:grad gate on two [ship desk diff] triples
::
=/ mash-build=^build
:- date.build
:+ %call
:+ %ride
[%limb %mash]
[%$ %noun grad-vase]
:+ %$ %noun
%+ slop
;: slop
[[%atom %p ~] ship.disc.first]
[[%atom %tas ~] desk.disc.first]
q.first-cage
==
;: slop
[[%atom %p ~] ship.disc.second]
[[%atom %tas ~] desk.disc.second]
q.second-cage
==
::
=^ mash-result out (depend-on mash-build)
?~ mash-result
(return-blocks [mash-build]~)
::
?. ?=([~ %success %call *] mash-result)
(wrap-error mash-result)
::
=/ =build-result
[%success %mash [u.form-mark vase.u.mash-result]]
::
(return-result build-result)
::
++ make-mute
~% %make-mute ..^^$ ~
|= [subject=schematic mutations=(list [=wing =schematic])]
^- build-receipt
:: run the subject build to produce the noun to be mutated
::
=/ subject-build=^build [date.build subject]
=^ subject-result out (depend-on subject-build)
?~ subject-result
(return-blocks [subject-build]~)
::
?. ?=([~ %success *] subject-result)
(wrap-error subject-result)
::
=/ subject-cage=cage (result-to-cage u.subject-result)
::
=/ subject-vase=vase q.subject-cage
::
=^ maybe-schematic-results out
%- perform-schematics :*
"ford: %mute contained failures:"
mutations
%fail-on-errors
*wing
==
?~ maybe-schematic-results
out
:: all builds succeeded; retrieve vases from results
::
=/ successes=(list [=wing =vase])
%+ turn u.maybe-schematic-results
|= [=wing result=build-result]
^- [^wing vase]
::
?> ?=([%success *] result)
::
[wing q:(result-to-cage result)]
:: create and run a +build to apply all mutations in order
::
=/ ride-build=^build
:- date.build
:+ %ride
:: formula: a `%_` +hoon that applies a list of mutations
::
:: The hoon ends up looking like:
:: ```
:: %_ +2
:: wing-1 +6
:: wing-2 +14
:: ...
:: ==
:: ```
::
^= formula
^- hoon
:+ %cncb [%& 2]~
=/ axis 3
::
|- ^- (list [wing hoon])
?~ successes ~
::
:- [wing.i.successes [%$ (peg axis 2)]]
$(successes t.successes, axis (peg axis 3))
:: subject: list of :subject-vase and mutations, as literal schematic
::
:: The subject ends up as a vase of something like this:
:: ```
:: :~ original-subject
:: mutant-1
:: mutant-2
:: ...
:: ==
:: ```
::
^= subject ^- schematic
:+ %$ %noun
^- vase
%+ slop subject-vase
|- ^- vase
?~ successes [[%atom %n ~] ~]
::
(slop vase.i.successes $(successes t.successes))
::
=^ ride-result out (depend-on ride-build)
?~ ride-result
(return-blocks [ride-build]~)
::
?. ?=([~ %success %ride *] ride-result)
(wrap-error ride-result)
::
=/ =build-result
[%success %mute p.subject-cage vase.u.ride-result]
::
(return-result build-result)
::
++ make-pact
~% %make-pact ..^^$ ~
|= [disc=disc start=schematic diff=schematic]
^- build-receipt
:: first, build the inputs
::
=/ initial-build=^build [date.build start diff]
::
=^ initial-result out (depend-on initial-build)
?~ initial-result
(return-blocks [initial-build]~)
::
?> ?=([~ %success ^ ^] initial-result)
=/ start-result=build-result head.u.initial-result
=/ diff-result=build-result tail.u.initial-result
::
?. ?=(%success -.start-result)
(wrap-error `start-result)
?. ?=(%success -.diff-result)
(wrap-error `diff-result)
::
=/ start-cage=cage (result-to-cage start-result)
=/ diff-cage=cage (result-to-cage diff-result)
::
=/ start-mark=term p.start-cage
=/ diff-mark=term p.diff-cage
:: load the starting mark from the filesystem
::
=/ mark-path-build=^build [date.build [%path disc %mar start-mark]]
::
=^ mark-path-result out
(depend-on mark-path-build)
::
?~ mark-path-result
(return-blocks [mark-path-build]~)
::
?. ?=([~ %success %path *] mark-path-result)
(wrap-error mark-path-result)
::
=/ mark-build=^build [date.build [%core rail.u.mark-path-result]]
::
=^ mark-result out (depend-on mark-build)
?~ mark-result
(return-blocks [mark-build]~)
::
?. ?=([~ %success %core *] mark-result)
(wrap-error mark-result)
::
=/ mark-vase=vase vase.u.mark-result
:: fire the +grad arm of the mark core
::
?. (slab %grad p.mark-vase)
%- return-error :_ ~ :- %leaf
"ford: %pact failed: %{<start-mark>} mark has no +grad arm"
::
=/ grad-build=^build
[date.build [%ride [%limb %grad] [%$ %noun mark-vase]]]
::
=^ grad-result out (depend-on grad-build)
?~ grad-result
(return-blocks [grad-build]~)
::
?. ?=([~ %success %ride *] grad-result)
(wrap-error grad-result)
::
=/ grad-vase=vase vase.u.grad-result
:: +grad can produce a term or a core
::
:: If a mark's +grad arm produces a mark (as a +term),
:: it means we should use that mark's machinery to run %pact.
:: In this way, a mark can delegate its patching machinery to
:: another mark.
::
:: First we cast :start-cage to the +grad mark, then we run
:: a new %pact build on the result of that, which will use the
:: +grad mark's +grad arm. Finally we cast the %pact result back to
:: :start-mark, since we're trying to produce a patched version of
:: the initial marked value (:start-cage).
::
?@ q.grad-vase
:: if +grad produced a term, make sure it's a valid mark
::
=/ grad-mark=(unit term) ((sand %tas) q.grad-vase)
?~ grad-mark
%- return-error :_ ~ :- %leaf
"ford: %pact failed: %{<start-mark>} mark invalid +grad"
:: cast :start-cage to :grad-mark, %pact that, then cast back to start
::
=/ cast-build=^build
:- date.build
:^ %cast disc start-mark
:^ %pact disc
:^ %cast disc u.grad-mark
[%$ start-cage]
[%$ diff-cage]
::
=^ cast-result out (depend-on cast-build)
?~ cast-result
(return-blocks [cast-build]~)
::
?. ?=([~ %success %cast *] cast-result)
(wrap-error cast-result)
::
=/ =build-result
[%success %pact cage.u.cast-result]
::
(return-result build-result)
:: +grad produced a core; make sure it has a +form arm
::
:: +grad can produce a core containing +pact and +form
:: arms. +form:grad, which produces a mark (as a term), is used
:: to verify that the diff is of the correct mark.
::
:: +pact:grad produces a gate that gets slammed with the diff
:: as its sample and produces a mutant version of :start-cage
:: by applying the diff.
::
?. (slab %form p.grad-vase)
%- return-error :_ ~ :- %leaf
"ford: %pact failed: no +form:grad in %{<start-mark>} mark"
:: we also need a +pact arm in the +grad core
::
?. (slab %pact p.grad-vase)
%- return-error :_ ~ :- %leaf
"ford: %pact failed: no +pact:grad in %{<start-mark>} mark"
:: fire the +form arm in the core produced by +grad
::
=/ form-build=^build
[date.build [%ride [%limb %form] [%$ %noun grad-vase]]]
::
=^ form-result out (depend-on form-build)
?~ form-result
(return-blocks [form-build]~)
::
?. ?=([~ %success %ride *] form-result)
(wrap-error form-result)
:: +form:grad should produce a mark
::
=/ form-mark=(unit @tas) ((soft @tas) q.vase.u.form-result)
?~ form-mark
%- return-error :_ ~ :- %leaf
"ford: %pact failed: %{<start-mark>} mark invalid +form:grad"
:: mark produced by +form:grad needs to match the mark of the diff
::
?. =(u.form-mark diff-mark)
%- return-error :_ ~ :- %leaf
"ford: %pact failed: %{<start-mark>} mark invalid +form:grad"
:: call +pact:grad on the diff
::
=/ pact-build=^build
:- date.build
:+ %call
^- schematic
:+ %ride
[%tsld [%limb %pact] [%limb %grad]]
^- schematic
:+ %mute
^- schematic
[%$ %noun mark-vase]
^- (list [wing schematic])
[[%& 6]~ [%$ start-cage]]~
^- schematic
[%$ diff-cage]
::
=^ pact-result out (depend-on pact-build)
?~ pact-result
(return-blocks [pact-build]~)
::
?. ?=([~ %success %call *] pact-result)
(wrap-error pact-result)
::
=/ =build-result
[%success %pact start-mark vase.u.pact-result]
::
(return-result build-result)
::
++ make-path
~% %make-path ..^^$ ~
|= [disc=disc prefix=@tas raw-path=@tas]
^- build-receipt
:: possible-spurs: flopped paths to which :raw-path could resolve
::
=/ possible-spurs=(list spur) (turn (segments raw-path) flop)
:: rails-and-schematics: scrys to check each path in :possible-paths
::
=/ rails-and-schematics=(list [=rail =schematic])
%+ turn possible-spurs
|= possible-spur=spur
^- [rail schematic]
:: full-spur: wrap :possible-spur with :prefix and /hoon suffix
::
=/ full-spur=spur :(welp /hoon possible-spur /[prefix])
::
:- [disc full-spur]
[%scry %c %x `rail`[disc full-spur]]
:: depend on builds of each schematic
::
=^ maybe-schematic-results out
%- perform-schematics :*
;: weld
"ford: %path resolution of " (trip raw-path) "at prefix "
(trip prefix) " contained failures:"
==
rails-and-schematics
%filter-errors
*rail
==
?~ maybe-schematic-results
out
:: matches: builds that completed with a successful result
::
=/ matches u.maybe-schematic-results
:: if no matches, error out
::
?~ matches
=/ =beam
[[ship.disc desk.disc [%da date.build]] /hoon/[raw-path]/[prefix]]
::
%- return-error
:_ ~
:- %leaf
(weld "%path: no matches for " (spud (en-beam beam)))
:: if exactly one path matches, succeed with the matching path
::
?: ?=([* ~] matches)
(return-result %success %path key.i.matches)
:: multiple paths matched; error out
::
%- return-error
::
:- [%leaf "multiple matches for %path: "]
:: tmi; cast :matches back to +list
::
%+ roll `_u.maybe-schematic-results`matches
|= [[key=rail result=build-result] message=tang]
^- tang
:: beam: reconstruct request from :kid's schematic and date
::
=/ =beam [[ship.disc desk.disc [%da date.build]] spur.key]
::
[[%leaf (spud (en-beam beam))] message]
::
++ make-plan
~% %make-plan ..^^$ ~
|= [path-to-render=rail query-string=coin =scaffold]
^- build-receipt
:: blocks: accumulator for blocked sub-builds
::
=| blocks=(list ^build)
:: error-message: accumulator for failed sub-builds
::
=| error-message=tang
::
|^ :: imports: structure and library +cables, with %sur/%lib prefixes
::
=/ imports=(list [prefix=?(%sur %lib) =cable])
%+ welp
(turn structures.scaffold |=(cable [%sur +<]))
(turn libraries.scaffold |=(cable [%lib +<]))
:: path-builds: %path sub-builds to resolve import paths
::
=/ path-builds (gather-path-builds imports)
::
=^ path-results ..$ (resolve-builds path-builds)
?^ blocks
(return-blocks blocks)
::
?^ error-message
(return-error error-message)
:: tmi; remove type specializations
::
=> .(blocks *(list ^build), error-message *tang)
:: core-builds: %core sub-builds to produce library vases
::
=/ core-builds (gather-core-builds path-results)
::
=^ core-results ..$ (resolve-builds core-builds)
?^ blocks
(return-blocks blocks)
::
?^ error-message
(return-error error-message)
:: reef-build: %reef build to produce standard library
::
=/ reef-build=^build [date.build [%reef disc.path-to-render]]
::
=^ reef-result out (depend-on reef-build)
?~ reef-result
(return-blocks [reef-build]~)
::
?. ?=([~ %success %reef *] reef-result)
(wrap-error reef-result)
:: subject: tuple of imports and standard library
::
=/ subject=vase
(link-imports imports vase.u.reef-result core-results)
:: tmi; remove type specializations
::
=> .(blocks *(list ^build), error-message *tang)
:: iterate over each crane
::
=^ crane-result ..$
(compose-cranes [%noun subject] cranes.scaffold)
?: ?=(%error -.crane-result)
(return-error message.crane-result)
?: ?=(%block -.crane-result)
(return-blocks builds.crane-result)
:: combined-hoon: source hoons condensed into a single +hoon
::
=/ combined-hoon=hoon [%tssg sources.scaffold]
:: compile :combined-hoon against :subject
::
=/ compile=^build
[date.build [%ride combined-hoon [%$ subject.crane-result]]]
::
=^ compiled out (depend-on compile)
:: compilation blocked; produce block on sub-build
::
?~ compiled
(return-blocks ~[compile])
:: compilation failed; error out
::
?. ?=([~ %success %ride *] compiled)
(wrap-error compiled)
:: compilation succeeded: produce resulting +vase
::
(return-result %success %plan vase.u.compiled)
:: +compose-result: the result of a single composition
::
+= compose-result
$% [%subject subject=cage]
[%block builds=(list ^build)]
[%error message=tang]
==
:: +compose-cranes: runs each crane and composes the results
::
:: For each crane in :cranes, runs it and composes its result into a
:: new subject, which is returned if there are no errors or blocks.
::
++ compose-cranes
|= [subject=cage cranes=(list crane)]
^- $: compose-result
_..compose-cranes
==
::
?~ cranes
[[%subject subject] ..compose-cranes]
::
=^ result ..compose-cranes (run-crane subject i.cranes)
?+ -.result [result ..compose-cranes]
::
%subject
$(cranes t.cranes, subject [%noun (slop q.subject.result q.subject)])
==
:: +run-crane: runs an individual :crane against :subject
::
++ run-crane
|= [subject=cage =crane]
^- compose-cranes
::
|^ ?- -.crane
%fssg (run-fssg +.crane)
%fsbc (run-fsbc +.crane)
%fsbr (run-fsbr +.crane)
%fsts (run-fsts +.crane)
%fscm (run-fscm +.crane)
%fspm (run-fspm +.crane)
%fscb (run-fscb +.crane)
%fsdt (run-fsdt +.crane)
%fssm (run-fssm +.crane)
%fscl (run-fscl +.crane)
%fskt (run-fskt +.crane)
%fstr (run-fstr +.crane)
%fszp (run-fszp +.crane)
%fszy (run-fszy +.crane)
==
:: +run-fssg: runs the `/~` rune
::
++ run-fssg
|= =hoon
^- compose-cranes
::
=/ ride-build=^build
[date.build [%ride hoon [%$ subject]]]
=^ ride-result out (depend-on ride-build)
?~ ride-result
[[%block [ride-build]~] ..run-crane]
?: ?=([~ %error *] ride-result)
[[%error [leaf+"/~ failed: " message.u.ride-result]] ..run-crane]
?> ?=([~ %success %ride *] ride-result)
[[%subject %noun vase.u.ride-result] ..run-crane]
:: +run-fsbc: runs the `/$` rune
::
++ run-fsbc
|= =hoon
^- compose-cranes
::
=/ query-compile-build=^build
[date.build [%ride ((jock |) query-string) [%$ %noun !>(~)]]]
=^ query-compile-result out (depend-on query-compile-build)
?~ query-compile-result
[[%block [query-compile-build]~] ..run-crane]
?: ?=([~ %error *] query-compile-result)
:- [%error [leaf+"/; failed: " message.u.query-compile-result]]
..run-crane
?> ?=([~ %success %ride *] query-compile-result)
::
=/ =beam
=, path-to-render
[[ship.disc desk.disc [%da date.build]] spur]
=+ arguments=(slop !>(beam) vase.u.query-compile-result)
::
=/ call-build=^build
[date.build [%call [%ride hoon [%$ subject]] [%$ %noun arguments]]]
=^ call-result out (depend-on call-build)
?~ call-result
[[%block [call-build]~] ..run-crane]
?: ?=([~ %error *] call-result)
[[%error [leaf+"/; failed: " message.u.call-result]] ..run-crane]
?> ?=([~ %success %call *] call-result)
::
[[%subject %noun vase.u.call-result] ..run-crane]
:: +run-fsbr: runs the `/|` rune
::
++ run-fsbr
|= choices=(list ^crane)
^- compose-cranes
::
?~ choices
[[%error [leaf+"/| failed: out of options"]~] ..run-crane]
::
=^ child ..run-crane (run-crane subject i.choices)
?. ?=([%error *] child)
[child ..run-crane]
$(choices t.choices)
:: +run-fsts: runs the `/=` rune
::
++ run-fsts
|= [face=term sub-crane=^crane]
^- compose-cranes
::
=^ child ..run-crane (run-crane subject sub-crane)
?. ?=([%subject *] child)
[child ..run-crane]
:_ ..run-crane
:* %subject
p.subject.child
[[%face face p.q.subject.child] q.q.subject.child]
==
:: +run-fscm: runs the `/,` rune
::
++ run-fscm
|= cases=(list [=spur crane=^crane])
^- compose-cranes
::
?~ cases
[[%error [leaf+"/, failed: no match"]~] ..run-crane]
::
?. .= spur.i.cases
(scag (lent spur.i.cases) (flop spur.path-to-render))
$(cases t.cases)
::
(run-crane subject crane.i.cases)
:: +run-fspm: runs the `/&` rune
::
++ run-fspm
|= [marks=(list mark) sub-crane=^crane]
^- compose-cranes
::
=^ child ..run-crane (run-crane subject sub-crane)
?. ?=([%subject *] child)
[child ..run-crane]
::
=/ cast-build=^build
:- date.build
|-
^- schematic
?~ marks
:: TODO: If we were keeping track of the mark across runes, this
:: wouldn't have %noun here. This is a case where it might matter.
::
[%$ subject.child]
[%cast disc.source-rail.scaffold i.marks $(marks t.marks)]
=^ cast-result out (depend-on cast-build)
?~ cast-result
[[%block [cast-build]~] ..run-crane]
::
?: ?=([~ %error *] cast-result)
[[%error [leaf+"/& failed: " message.u.cast-result]] ..run-crane]
?> ?=([~ %success %cast *] cast-result)
::
[[%subject cage.u.cast-result] ..run-crane]
:: +run-fscb: runs the `/_` rune
::
++ run-fscb
|= sub-crane=^crane
^- compose-cranes
:: perform a scry to get the contents of +path-to-render
::
=/ toplevel-build=^build
[date.build [%scry [%c %y path-to-render]]]
::
=^ toplevel-result out (depend-on toplevel-build)
?~ toplevel-result
[[%block ~[toplevel-build]] ..run-crane]
::
?: ?=([~ %error *] toplevel-result)
:- [%error [leaf+"/_ failed: " message.u.toplevel-result]]
..run-crane
?> ?=([~ %success %scry *] toplevel-result)
::
=/ toplevel-arch=arch ;;(arch q.q.cage.u.toplevel-result)
:: sub-path: each possible sub-directory to check
::
=/ sub-paths=(list @ta)
(turn ~(tap by dir.toplevel-arch) head)
:: for each directory in :toplevel-arch, issue a sub-build
::
=/ sub-builds=(list ^build)
%+ turn sub-paths
|= sub=@ta
^- ^build
:- date.build
[%scry [%c %y path-to-render(spur [sub spur.path-to-render])]]
:: results: accumulator for results of sub-builds
::
=| $= results
(list [kid=^build sub-path=@ta results=(unit build-result)])
:: resolve all the :sub-builds
::
=/ subs-results
|- ^+ [results out]
?~ sub-builds [results out]
?> ?=(^ sub-paths)
::
=/ kid=^build i.sub-builds
=/ sub-path=@ta i.sub-paths
::
=^ result out (depend-on kid)
=. results [[kid sub-path result] results]
::
$(sub-builds t.sub-builds, sub-paths t.sub-paths)
:: apply mutations from depending on sub-builds
::
=: results -.subs-results
out +.subs-results
==
:: split :results into completed :mades and incomplete :blocks
::
=+ ^= split-results
(skid results |=([* * r=(unit build-result)] ?=(^ r)))
::
=/ mades=_results -.split-results
=/ blocks=_results +.split-results
:: if any builds blocked, produce them all in %blocks
::
?^ blocks
[[%block (turn `_results`blocks head)] ..run-crane]
:: find the first error and return it if exists
::
=/ errors=_results
%+ skim results
|= [* * r=(unit build-result)]
?=([~ %error *] r)
?^ errors
?> ?=([~ %error *] results.i.errors)
[[%error message.u.results.i.errors] ..run-crane]
:: get a list of valid sub-paths
::
:: :results is now a list of the :build-result of %cy on each path
:: in :toplevel-arch. What we want is to now filter this list so
:: that we filter files out.
::
=/ sub-paths=(list [=rail sub-path=@ta])
%+ murn results
|= [build=^build sub-path=@ta result=(unit build-result)]
^- (unit [rail @ta])
::
?> ?=([@da %scry %c %y *] build)
?> ?=([~ %success %scry *] result)
=/ =arch ;;(arch q.q.cage.u.result)
::
?~ dir.arch
~
`[rail.resource.schematic.build sub-path]
:: keep track of the original value so we can reset it
::
=/ old-path-to-render path-to-render
:: apply each of the filtered :sub-paths to the :sub-crane.
::
=^ crane-results ..run-crane
%+ roll sub-paths
|= $: [=rail sub-path=@ta]
$= accumulator
[(list [sub-path=@ta =compose-result]) _..run-crane]
==
=. ..run-crane +.accumulator
=. path-to-render rail
=^ result ..run-crane (run-crane subject sub-crane)
[[[sub-path result] -.accumulator] ..run-crane]
:: set :path-to-render back
::
=. path-to-render old-path-to-render
:: if any sub-cranes error, return the first error
::
=/ error-list=(list [@ta =compose-result])
%+ skim crane-results
|= [@ta =compose-result]
=(%error -.compose-result)
::
?^ error-list
[compose-result.i.error-list ..run-crane]
:: if any sub-cranes block, return all blocks
::
=/ block-list=(list ^build)
=| block-list=(list ^build)
|-
^+ block-list
?~ crane-results
block-list
?. ?=(%block -.compose-result.i.crane-results)
$(crane-results t.crane-results)
=. block-list
(weld builds.compose-result.i.crane-results block-list)
$(crane-results t.crane-results)
::
?^ block-list
[[%block block-list] ..run-crane]
:: put the data in map order
::
=/ result-map=(map @ta vase)
%- my
%+ turn crane-results
|= [path=@ta =compose-result]
^- (pair @ta vase)
::
?> ?=([%subject *] compose-result)
[path q.subject.compose-result]
:: convert the map into a flat format for return
::
:: This step flattens the values out of the map for return. Let's
:: say we're doing a /_ over a directory of files that just have a
:: single @ud in them. We want the return value of /_ to have the
:: nest in (map @ta @ud) instead of returning a (map @ta vase).
::
=/ as-vase=vase
|-
^- vase
::
?~ result-map
[[%atom %n `0] 0]
::
%+ slop
(slop [[%atom %ta ~] p.n.result-map] q.n.result-map)
(slop $(result-map l.result-map) $(result-map r.result-map))
::
[[%subject %noun as-vase] ..run-crane]
:: +run-fsdt: runs the `/.` rune
::
++ run-fsdt
|= sub-cranes=(list ^crane)
^- compose-cranes
::
=^ list-results ..run-crane
%+ roll sub-cranes
|= $: sub-crane=^crane
accumulator=[(list compose-result) _..run-crane]
==
=. ..run-crane +.accumulator
=^ result ..run-crane (run-crane subject sub-crane)
[[result -.accumulator] ..run-crane]
:: if any sub-cranes error, return the first error
::
=/ error-list=(list compose-result)
%+ skim list-results
|= =compose-result
=(%error -.compose-result)
::
?^ error-list
[i.error-list ..run-crane]
:: if any sub-cranes block, return all blocks
::
=/ block-list=(list ^build)
=| block-list=(list ^build)
|-
^+ block-list
?~ list-results
block-list
?. ?=(%block -.i.list-results)
$(list-results t.list-results)
=. block-list (weld builds.i.list-results block-list)
$(list-results t.list-results)
::
?^ block-list
[[%block block-list] ..run-crane]
:: concatenate all the results together with null termination
::
=. list-results (flop list-results)
::
=/ final-result=vase
|-
^- vase
?~ list-results
[[%atom %n `~] 0]
?> ?=(%subject -.i.list-results)
(slop q.subject.i.list-results $(list-results t.list-results))
::
[[%subject %noun final-result] ..run-crane]
:: +run-fssm: runs the `/;` rune
::
++ run-fssm
|= [=hoon sub-crane=^crane]
^- compose-cranes
::
=^ child ..run-crane (run-crane subject sub-crane)
?. ?=([%subject *] child)
[child ..run-crane]
::
=/ call-build=^build
[date.build [%call [%ride hoon [%$ subject]] [%$ subject.child]]]
=^ call-result out (depend-on call-build)
?~ call-result
[[%block [call-build]~] ..run-crane]
?: ?=([~ %error *] call-result)
[[%error [leaf+"/; failed: " message.u.call-result]] ..run-crane]
?> ?=([~ %success %call *] call-result)
::
[[%subject %noun vase.u.call-result] ..run-crane]
:: +run-fscl: runs the `/:` rune
::
++ run-fscl
|= [=truss sub-crane=^crane]
^- compose-cranes
::
=/ beam-to-render=beam
[[ship.disc desk.disc %ud 0] spur]:path-to-render
::
=/ hoon-parser (vang & (en-beam beam-to-render))
::
=+ tuz=(posh:hoon-parser truss)
?~ tuz
[[%error [leaf+"/: failed: bad tusk: {<truss>}"]~] ..run-crane]
=+ pax=(plex:hoon-parser %clsg u.tuz)
?~ pax
[[%error [leaf+"/: failed: bad path: {<u.tuz>}"]~] ..run-crane]
=+ bem=(de-beam u.pax)
?~ bem
[[%error [leaf+"/: failed: bad beam: {<u.pax>}"]~] ..run-crane]
::
=. path-to-render [[p q] s]:u.bem
(run-crane subject sub-crane)
:: +run-fskt: runs the `/^` rune
::
++ run-fskt
|= [=spec sub-crane=^crane]
^- compose-cranes
::
=^ child ..run-crane (run-crane subject sub-crane)
?. ?=([%subject *] child)
[child ..run-crane]
::
=/ bunt-build=^build
[date.build [%ride [%kttr spec] [%$ subject]]]
=^ bunt-result out (depend-on bunt-build)
?~ bunt-result
[[%block [bunt-build]~] ..run-crane]
?: ?=([~ %error *] bunt-result)
[[%error [leaf+"/^ failed: " message.u.bunt-result]] ..run-crane]
?> ?=([~ %success %ride *] bunt-result)
::
?. (~(nest ut p.vase.u.bunt-result) | p.q.subject.child)
[[%error [leaf+"/^ failed: nest-fail"]~] ..run-crane]
:_ ..run-crane
[%subject %noun [p.vase.u.bunt-result q.q.subject.child]]
:: +run-fstr: runs the `/*` rune
::
:: TODO: some duplicate code with +run-fscb
::
++ run-fstr
|= sub-crane=^crane
^- compose-cranes
::
=/ tree-build=^build
[date.build [%scry [%c %t path-to-render]]]
::
=^ tree-result out (depend-on tree-build)
?~ tree-result
[[%block ~[tree-build]] ..run-crane]
::
?: ?=([~ %error *] tree-result)
:- [%error [%leaf "/* failed: "] message.u.tree-result]
..run-crane
?> ?=([~ %success %scry *] tree-result)
::
=/ file-list=(list path) ;;((list path) q.q.cage.u.tree-result)
:: trim file extensions off the file paths
::
:: This is pretty ugly, but Ford expects :path-to-render not to
:: have a file extension, so we need to trim it off each path.
::
=. file-list
:: deduplicate since multiple files could share a trimmed path
::
=- ~(tap in (~(gas in *(set path)) `(list path)`-))
%+ turn file-list
|= =path
^+ path
(scag (sub (lent path) 1) path)
::
=/ old-path-to-render path-to-render
:: apply each of the paths in :file-list to the :sub-crane
::
=^ crane-results ..run-crane
%+ roll file-list
|= $: =path
$= accumulator
[(list [=path =compose-result]) _..run-crane]
==
=. ..run-crane +.accumulator
=. spur.path-to-render (flop path)
::
=^ result ..run-crane (run-crane subject sub-crane)
[[[path result] -.accumulator] ..run-crane]
::
=. path-to-render old-path-to-render
:: if any sub-cranes error, return the first error
::
=/ error-list=(list [=path =compose-result])
%+ skim crane-results
|= [=path =compose-result]
=(%error -.compose-result)
::
?^ error-list
[compose-result.i.error-list ..run-crane]
:: if any sub-cranes block, return all blocks
::
=/ block-list=(list ^build)
=| block-list=(list ^build)
|- ^+ block-list
?~ crane-results block-list
::
?. ?=(%block -.compose-result.i.crane-results)
$(crane-results t.crane-results)
=. block-list
(weld builds.compose-result.i.crane-results block-list)
::
$(crane-results t.crane-results)
::
?^ block-list
[[%block block-list] ..run-crane]
::
=/ result-map=(map path vase)
%- my
%+ turn crane-results
|= [=path =compose-result]
^- (pair ^path vase)
::
?> ?=(%subject -.compose-result)
[path q.subject.compose-result]
::
=/ as-vase
=/ path-type -:!>(*path)
|- ^- vase
?~ result-map [[%atom %n `0] 0]
::
%+ slop
(slop [path-type p.n.result-map] q.n.result-map)
(slop $(result-map l.result-map) $(result-map r.result-map))
::
[[%subject %noun as-vase] ..run-crane]
:: +run-fszp: runs the `/!mark/` "rune"
::
++ run-fszp
|= =mark
^- compose-cranes
::
=/ hoon-path=rail
=, path-to-render
[disc [%hoon spur]]
::
=/ hood-build=^build [date.build [%hood hoon-path]]
=^ hood-result out (depend-on hood-build)
?~ hood-result
[[%block [hood-build]~] ..run-crane]
?: ?=([~ %error *] hood-result)
[[%error [leaf+"/! failed: " message.u.hood-result]] ..run-crane]
?> ?=([~ %success %hood *] hood-result)
::
=/ plan-build=^build
:- date.build
[%plan path-to-render query-string scaffold.u.hood-result]
=^ plan-result out (depend-on plan-build)
?~ plan-result
[[%block [plan-build]~] ..run-crane]
?: ?=([~ %error *] plan-result)
[[%error [leaf+"/! failed: " message.u.plan-result]] ..run-crane]
?> ?=([~ %success %plan *] plan-result)
:: if :mark is %noun, don't perform mark translation; just return
::
:: If we were to verify the product type with %noun, this would
:: cast to *, which would overwrite :vase.u.plan-result's actual
:: product type
::
?: =(%noun mark)
[[%subject %noun vase.u.plan-result] ..run-crane]
::
=/ vale-build=^build
:- date.build
[%vale disc.source-rail.scaffold mark q.vase.u.plan-result]
=^ vale-result out (depend-on vale-build)
?~ vale-result
[[%block [vale-build]~] ..run-crane]
?: ?=([~ %error *] vale-result)
[[%error [leaf+"/! failed: " message.u.vale-result]] ..run-crane]
?> ?=([~ %success %vale *] vale-result)
::
[[%subject cage.u.vale-result] ..run-crane]
:: +run-fszy: runs the `/mark/` "rune"
::
++ run-fszy
|= =mark
^- compose-cranes
::
=/ bake-build=^build
:- date.build
[%bake mark query-string path-to-render]
=^ bake-result out (depend-on bake-build)
?~ bake-result
[[%block [bake-build]~] ..run-crane]
?: ?=([~ %error *] bake-result)
:_ ..run-crane
[%error [leaf+"/{(trip mark)}/ failed: " message.u.bake-result]]
?> ?=([~ %success %bake *] bake-result)
::
[[%subject cage.u.bake-result] ..run-crane]
--
:: +gather-path-builds: produce %path builds to resolve import paths
::
++ gather-path-builds
|= imports=(list [prefix=?(%sur %lib) =cable])
^- (list ^build)
::
%+ turn imports
|= [prefix=?(%sur %lib) =cable]
^- ^build
[date.build [%path disc.source-rail.scaffold prefix file-path.cable]]
:: +resolve-builds: run a list of builds and collect results
::
:: If a build blocks, put its +tang in :error-message and stop.
:: All builds that block get put in :blocks. Results of
:: successful builds are produced in :results.
::
++ resolve-builds
=| results=(list build-result)
|= builds=(list ^build)
^+ [results ..^$]
::
?~ builds
[results ..^$]
::
=^ result out (depend-on i.builds)
?~ result
=. blocks [i.builds blocks]
$(builds t.builds)
::
?. ?=(%success -.u.result)
=. error-message [[%leaf "%plan failed: "] message.u.result]
[results ..^$]
::
=. results [u.result results]
$(builds t.builds)
:: +gather-core-builds: produce %core builds from resolved paths
::
++ gather-core-builds
|= path-results=(list build-result)
^- (list ^build)
%+ turn path-results
|= result=build-result
^- ^build
::
?> ?=([%success %path *] result)
::
[date.build [%core rail.result]]
:: +link-imports: link libraries and structures with standard library
::
:: Prepends each library vase onto the standard library vase.
:: Wraps a face around each library to prevent namespace leakage
:: unless imported as *lib-name.
::
++ link-imports
|= $: imports=(list [?(%lib %sur) =cable])
reef=vase
core-results=(list build-result)
==
^- vase
::
=/ subject=vase reef
::
=/ core-vases=(list vase)
%+ turn core-results
|= result=build-result
^- vase
?> ?=([%success %core *] result)
vase.result
:: link structures and libraries into a subject for compilation
::
|- ^+ subject
?~ core-vases subject
?< ?=(~ imports)
:: cons this vase onto the head of the subject
::
=. subject
%- slop :_ subject
:: check if the programmer named the library
::
?~ face.cable.i.imports
:: no face assigned to this library, so use vase as-is
::
i.core-vases
:: use the library name as a face to prevent namespace leakage
::
^- vase
[[%face u.face.cable.i.imports p.i.core-vases] q.i.core-vases]
::
$(core-vases t.core-vases, imports t.imports)
--
::
++ make-reef
~% %make-reef ..^^$ ~
|= =disc
^- build-receipt
::
=/ hoon-scry
[date.build [%scry %c %x [disc /hoon/hoon/sys]]]
::
=^ hoon-scry-result out (depend-on hoon-scry)
::
=/ arvo-scry
[date.build [%scry %c %x [disc /hoon/arvo/sys]]]
::
=^ arvo-scry-result out (depend-on arvo-scry)
::
=/ zuse-scry
[date.build [%scry %c %x [disc /hoon/zuse/sys]]]
::
=^ zuse-scry-result out (depend-on zuse-scry)
::
=| blocks=(list ^build)
=? blocks ?=(~ hoon-scry-result) [hoon-scry blocks]
=? blocks ?=(~ arvo-scry-result) [arvo-scry blocks]
=? blocks ?=(~ zuse-scry-result) [zuse-scry blocks]
::
?^ blocks
(return-blocks blocks)
::
?. ?=([~ %success %scry *] hoon-scry-result)
(wrap-error hoon-scry-result)
::
?. ?=([~ %success %scry *] arvo-scry-result)
(wrap-error arvo-scry-result)
::
?. ?=([~ %success %scry *] zuse-scry-result)
(wrap-error zuse-scry-result)
:: short-circuit to :pit if asked for current %home desk
::
:: This avoids needing to recompile the kernel if we're asked
:: for the kernel we're already running. Note that this fails
:: referential transparency if |autoload is turned off.
::
?: ?& |(=(disc [our %home]) =(disc [our %base]))
:: is :date.build the latest commit on the %home desk?
::
?| =(now date.build)
::
=/ =beam [[our %home [%da date.build]] /hoon/hoon/sys]
::
.= (scry [%141 %noun] ~ %cw beam)
(scry [%141 %noun] ~ %cw beam(r [%da now]))
== ==
::
(return-result %success %reef pit)
:: omit case from path to prevent cache misses
::
=/ hoon-path=path
/(scot %p ship.disc)/(scot %tas desk.disc)/hoon/hoon/sys
=/ hoon-hoon=(each hoon tang)
%- mule |.
(rain hoon-path ;;(@t q.q.cage.u.hoon-scry-result))
?: ?=(%| -.hoon-hoon)
(return-error leaf+"ford: %reef failed to compile hoon" p.hoon-hoon)
::
=/ arvo-path=path
/(scot %p ship.disc)/(scot %tas desk.disc)/hoon/arvo/sys
=/ arvo-hoon=(each hoon tang)
%- mule |.
(rain arvo-path ;;(@t q.q.cage.u.arvo-scry-result))
?: ?=(%| -.arvo-hoon)
(return-error leaf+"ford: %reef failed to compile arvo" p.arvo-hoon)
::
=/ zuse-path=path
/(scot %p ship.disc)/(scot %tas desk.disc)/hoon/zuse/sys
=/ zuse-hoon=(each hoon tang)
%- mule |.
(rain zuse-path ;;(@t q.q.cage.u.zuse-scry-result))
?: ?=(%| -.zuse-hoon)
(return-error leaf+"ford: %reef failed to compile zuse" p.zuse-hoon)
::
=/ zuse-build=^build
:* date.build
%ride p.zuse-hoon
:: hoon for `..is` to grab the :pit out of the arvo core
::
%ride [%cnts ~[[%& 1] %is] ~]
%ride p.arvo-hoon
%ride [%$ 7]
%ride p.hoon-hoon
[%$ %noun !>(~)]
==
::
=^ zuse-build-result out (depend-on zuse-build)
?~ zuse-build-result
(return-blocks [zuse-build]~)
::
?. ?=([~ %success %ride *] zuse-build-result)
(wrap-error zuse-build-result)
::
(return-result %success %reef vase.u.zuse-build-result)
::
++ make-ride
~% %make-ride ..^^$ ~
|= [formula=hoon =schematic]
^- build-receipt
::
=^ result out (depend-on [date.build schematic])
?~ result
(return-blocks [date.build schematic]~)
::
=* subject-vase q:(result-to-cage u.result)
=/ slim-schematic=^schematic [%slim p.subject-vase formula]
=^ slim-result out (depend-on [date.build slim-schematic])
?~ slim-result
(return-blocks [date.build slim-schematic]~)
::
?: ?=([~ %error *] slim-result)
%- return-error
:* [%leaf "ford: %ride failed to compute type:"]
message.u.slim-result
==
::
?> ?=([~ %success %slim *] slim-result)
::
=/ =compiler-cache-key [%ride formula subject-vase]
=^ cached-result out (access-cache compiler-cache-key)
?^ cached-result
(return-result u.cached-result)
::
=/ val
(mock [q.subject-vase nock.u.slim-result] intercepted-scry)
:: val is a toon, which might be a list of blocks.
::
?- -.val
::
%0
(return-result %success %ride [type.u.slim-result p.val])
::
%1
=/ blocked-paths=(list path) ;;((list path) p.val)
(blocked-paths-to-receipt %ride blocked-paths)
::
%2
(return-error [[%leaf "ford: %ride failed to execute:"] p.val])
==
::
++ make-same
~% %make-same ..^^$ ~
|= =schematic
^- build-receipt
::
=^ result out (depend-on [date.build schematic])
::
?~ result
(return-blocks [date.build schematic]~)
(return-result u.result)
::
++ make-scry
~% %make-scry ..^^$ ~
|= =resource
^- build-receipt
:: construct a full +beam to make the scry request
::
=/ =beam (extract-beam resource `date.build)
=/ =scry-request [vane.resource care.resource beam]
:: perform scry operation if we don't already know the result
::
:: Look up :scry-request in :scry-results.per-event to avoid
:: rerunning a previously blocked +scry.
::
=/ scry-response
?: (~(has by scry-results) scry-request)
(~(get by scry-results) scry-request)
(scry [%141 %noun] ~ `@tas`(cat 3 [vane care]:resource) beam)
:: scry blocked
::
?~ scry-response
(return-blocks ~)
:: scry failed
::
?~ u.scry-response
%- return-error
:~ leaf+"scry failed for"
leaf+:(weld "%c" (trip care.resource) " " (spud (en-beam beam)))
==
:: scry succeeded
::
(return-result %success %scry u.u.scry-response)
::
++ make-slim
~% %make-slim ..^^$ ~
|= [subject-type=type formula=hoon]
^- build-receipt
::
=/ =compiler-cache-key [%slim subject-type formula]
=^ cached-result out (access-cache compiler-cache-key)
?^ cached-result
(return-result u.cached-result)
::
=/ compiled=(each (pair type nock) tang)
(mule |.((~(mint ut subject-type) [%noun formula])))
::
%_ out
result
?- -.compiled
%| [%build-result %error [leaf+"ford: %slim failed: " p.compiled]]
%& [%build-result %success %slim p.compiled]
==
==
:: TODO: Take in +type instead of +vase?
::
++ make-slit
~% %make-slit ..^^$ ~
|= [gate=vase sample=vase]
^- build-receipt
::
=/ =compiler-cache-key [%slit p.gate p.sample]
=^ cached-result out (access-cache compiler-cache-key)
?^ cached-result
(return-result u.cached-result)
::
=/ product=(each type tang)
(mule |.((slit p.gate p.sample)))
::
%_ out
result
?- -.product
%| :* %build-result %error
:* (~(dunk ut p.sample) %have)
(~(dunk ut (~(peek ut p.gate) %free 6)) %want)
leaf+"ford: %slit failed:"
p.product
==
==
%& [%build-result %success %slit p.product]
==
==
::
++ make-volt
~% %make-volt ..^^$ ~
|= [=disc mark=term input=*]
^- build-receipt
::
=/ bunt-build=^build [date.build [%bunt disc mark]]
::
=^ bunt-result out (depend-on bunt-build)
?~ bunt-result
(return-blocks [bunt-build]~)
::
?: ?=([~ %error *] bunt-result)
%- return-error
:- [%leaf "ford: %volt {<mark>} on {<disc>} failed:"]
message.u.bunt-result
::
?> ?=([~ %success %bunt *] bunt-result)
::
=/ =build-result
[%success %volt [mark p.q.cage.u.bunt-result input]]
::
(return-result build-result)
::
++ make-vale
~% %make-vale ..^^$ ~
:: TODO: better docs
::
|= [=disc mark=term input=*]
^- build-receipt
:: don't validate for the %noun mark
::
?: =(%noun mark)
=/ =build-result [%success %vale [%noun %noun input]]
::
(return-result build-result)
::
=/ path-build [date.build [%path disc %mar mark]]
::
=^ path-result out (depend-on path-build)
?~ path-result
(return-blocks [path-build]~)
::
?: ?=([~ %error *] path-result)
%- return-error
:- leaf+"ford: %vale failed while searching for {<mark>}:"
message.u.path-result
::
?> ?=([~ %success %path *] path-result)
::
=/ bunt-build=^build [date.build [%bunt disc mark]]
::
=^ bunt-result out (depend-on bunt-build)
?~ bunt-result
(return-blocks [bunt-build]~)
::
?. ?=([~ %success %bunt *] bunt-result)
(wrap-error bunt-result)
::
=/ mark-sample=vase q.cage.u.bunt-result
::
=/ call-build=^build
:^ date.build
%call
^= gate
:* %ride
:: (ream 'noun:grab')
formula=`hoon`[%tsld [%wing ~[%noun]] [%wing ~[%grab]]]
subject=`schematic`[%core rail.u.path-result]
==
sample=[%$ %noun %noun input]
::
=^ call-result out (depend-on call-build)
?~ call-result
(return-blocks [call-build]~)
::
?: ?=([~ %error *] call-result)
::
%- return-error
=/ =beam
[[ship.disc desk.disc %da date.build] spur.rail.u.path-result]
:* :- %leaf
"ford: %vale failed: invalid input for mark: {<(en-beam beam)>}"
message.u.call-result
==
::
?> ?=([~ %success %call *] call-result)
=/ product=vase vase.u.call-result
:: +grab might produce the wrong type
::
?. (~(nest ut p.mark-sample) | p.product)
%- return-error
:~ leaf+"ford: %vale failed"
leaf+"+grab has wrong type in mark {<mark>} on disc {<disc>}"
==
::
=/ =build-result
[%success %vale [mark p.mark-sample q.product]]
::
(return-result build-result)
::
++ make-walk
~% %make-walk ..^^$ ~
|= [=disc source=term target=term]
^- build-receipt
:: define some types used in this gate
::
=> |%
:: +load-node: a queued arm to run from a mark core
::
+= load-node [type=?(%grab %grow) mark=term]
:: edge-jug: directed graph from :source mark to :target marks
::
:: :source can be converted to :target either by running
:: its own +grow arm, or by running the target's +grab arm.
::
+= edge-jug (jug source=term [target=term arm=?(%grow %grab)])
:: mark-path: a path through the mark graph
::
:: +mark-path represents a series of mark translation
:: operations to be performed to 'walk' from one mark to another.
::
:: +mark-action is defined in Zuse. It represents a conversion
:: from a source mark to a target mark, and it specifies
:: whether it will use +grow or +grab.
::
+= mark-path (list mark-action)
--
::
|^ ^- build-receipt
?: =(source target)
(return-result %success %walk ~)
:: load all marks.
::
=^ marks-result out
(load-marks-reachable-from [[%grow source] [%grab target] ~])
?~ -.marks-result
out
:: find a path through the graph
::
:: Make a list of individual mark translation actions which will
:: take us from :source to :term.
::
=/ path (find-path-through u.-.marks-result)
:: if there is no path between these marks, give an error message
::
?~ path
:: we failed; surface errors from +load-marks-reachable-from
::
=/ braces [[' ' ' ' ~] ['{' ~] ['}' ~]]
=/ errors=(list tank)
%- zing
%+ turn ~(tap in +.marks-result)
|= [mark=term err=tang]
^- tang
:~ [%leaf :(weld "while compiling " (trip mark) ":")]
[%rose braces err]
==
::
%_ out
result
:* %build-result %error
:* :- %leaf
;: weld
"ford: no mark path from " (trip source) " to "
(trip target)
==
errors
== ==
==
::
(return-result %success %walk path)
:: +load-marks-reachable-from: partial mark graph loading
::
:: While we can just load all marks in the %/mar directory, this is
:: rather slow. What we do instead is traverse forwards and backwards
:: from the source and target marks: we start at the source mark,
:: check all the grow arms, and then check their grow arms. At the
:: same time, we start from the target mark, check all the grab arms,
:: and then check their grab arms. This gives us a much smaller
:: dependency set than loading the entire %/mar directory.
::
++ load-marks-reachable-from
|= queued-nodes=(list load-node)
:: list of nodes in the graph that we've already checked
::
=| visited=(set load-node)
:: graph of the available edges
::
=| =edge-jug
:: compile-failures: mark files which didn't compile
::
=| compile-failures=(map term tang)
::
|-
^- [[(unit ^edge-jug) _compile-failures] _out]
:: no ?~ to prevent tmi
::
?: =(~ queued-nodes)
[[`edge-jug compile-failures] out]
::
=/ nodes-and-schematics
%+ turn queued-nodes
|= =load-node
^- [^load-node schematic]
:- load-node
[%path disc %mar mark.load-node]
:: get the path for each mark name
::
:: For %path builds, any ambiguous path is just filtered out.
::
=^ maybe-path-results out
%- perform-schematics :*
;: weld
"ford: %walk from " (trip source) " to " (trip target)
" contained failures:"
==
nodes-and-schematics
%filter-errors
*load-node
==
?~ maybe-path-results
[[~ ~] out]
::
=/ nodes-and-cores
%+ turn u.maybe-path-results
|= [=load-node =build-result]
^- [^load-node schematic]
::
?> ?=([%success %path *] build-result)
::
:- load-node
[%core rail.build-result]
::
=^ maybe-core-results out
%- perform-schematics :*
;: weld
"ford: %walk from " (trip source) " to " (trip target)
" contained failures:"
==
nodes-and-cores
%ignore-errors
*load-node
==
?~ maybe-core-results
[[~ ~] out]
:: clear the queue before we process the new results
::
=. queued-nodes ~
::
=/ cores u.maybe-core-results
::
|-
?~ cores
^$
:: mark this node as visited
::
=. visited (~(put in visited) key.i.cores)
:: add core errors to compile failures
::
=? compile-failures ?=([%error *] result.i.cores)
%+ ~(put by compile-failures) mark.key.i.cores
message.result.i.cores
::
=/ target-arms=(list load-node)
?. ?=([%success %core *] result.i.cores)
~
?: =(%grow type.key.i.cores)
(get-arms-of-type %grow vase.result.i.cores)
(get-arms-of-type %grab vase.result.i.cores)
:: filter places we know we've already been.
::
=. target-arms
%+ skip target-arms ~(has in visited)
=. queued-nodes (weld target-arms queued-nodes)
::
=. edge-jug
|-
?~ target-arms
edge-jug
::
=. edge-jug
?- type.i.target-arms
::
%grab
(~(put ju edge-jug) mark.i.target-arms [mark.key.i.cores %grab])
::
%grow
(~(put ju edge-jug) mark.key.i.cores [mark.i.target-arms %grow])
==
$(target-arms t.target-arms)
::
$(cores t.cores)
::
++ get-arms-of-type
|= [type=?(%grab %grow) =vase]
^- (list load-node)
:: it is valid for this node to not have a +grow arm.
::
?. (slob type p.vase)
~
::
%+ turn
(sloe p:(slap vase [%limb type]))
|= arm=term
[type arm]
:: +find-path-through: breadth first search over the mark graph
::
++ find-path-through
|= edges=edge-jug
^- mark-path
:: the source node starts out visited
=/ visited-nodes=(set mark) [source ~ ~]
:: these paths are flopped so we're always inserting to the front.
=| path-queue=(qeu mark-path)
:: start the queue with all the edges which start at the source mark
::
=. path-queue
=/ start-links (find-links-in-edges edges source)
::
|-
^+ path-queue
?~ start-links
path-queue
::
=. path-queue (~(put to path-queue) [i.start-links]~)
::
$(start-links t.start-links)
::
|-
^- mark-path
::
?: =(~ path-queue)
:: no path found
~
=^ current path-queue [p q]:~(get to path-queue)
?> ?=(^ current)
::
?: =(target target.i.current)
:: we have a completed path. paths in the queue are backwards
(flop current)
::
=+ next-steps=(find-links-in-edges edges target.i.current)
:: filter out already visited nodes
::
=. next-steps
%+ skip next-steps
|= link=mark-action
(~(has in visited-nodes) source.link)
:: then add the new ones to the set of already visited nodes
::
=. visited-nodes
(~(gas in visited-nodes) (turn next-steps |=(mark-action source)))
:: now all next steps go in the queue
::
=. path-queue
%- ~(gas to path-queue)
%+ turn next-steps
|= new-link=mark-action
[new-link current]
::
$
:: +find-links-in-edges: gets edges usable by +find-path-through
::
:: This deals with disambiguating between %grab and %grow so we always
:: pick %grab over %grow.
::
++ find-links-in-edges
|= [edges=edge-jug source=term]
^- (list mark-action)
::
=+ links=~(tap in (~(get ju edges) source))
::
=| results=(set mark-action)
|-
^- (list mark-action)
?~ links
~(tap in results)
::
?- arm.i.links
%grab
:: if :results has a %grow entry, remove it before adding our %grab
=/ grow-entry=mark-action [%grow source target.i.links]
=? results (~(has in results) grow-entry)
(~(del in results) grow-entry)
::
=. results (~(put in results) [%grab source target.i.links])
$(links t.links)
::
%grow
:: if :results has a %grab entry, don't add a %grow entry
?: (~(has in results) [%grab source target.i.links])
$(links t.links)
::
=. results (~(put in results) [%grow source target.i.links])
$(links t.links)
==
--
:: |utilities:make: helper arms
::
::+| utilities
::
:: +perform-schematics: helper function that performs a list of builds
::
:: We often need to run a list of builds. This helper method will
:: depend on all :builds, will return a +build-receipt of either the
:: blocks or the first error, or a list of all completed results.
::
:: This is a wet gate so individual callers can associate their own
:: key types with schematics.
::
++ perform-schematics
|* $: failure=tape
builds=(list [key=* =schematic])
on-error=?(%fail-on-errors %filter-errors %ignore-errors)
key-bunt=*
==
^- $: (unit (list [key=_key-bunt result=build-result]))
_out
==
::
|^ =^ results out
=| results=(list [_key-bunt ^build (unit build-result)])
|-
^+ [results out]
::
?~ builds
[results out]
::
=/ sub-build=^build [date.build schematic.i.builds]
=^ result out (depend-on sub-build)
=. results [[key.i.builds sub-build result] results]
::
$(builds t.builds)
?: =(%fail-on-errors on-error)
(check-errors results)
?: =(%filter-errors on-error)
(filter-errors results)
(handle-rest results)
::
++ check-errors
|= results=(list [_key-bunt ^build (unit build-result)])
::
=/ braces [[' ' ' ' ~] ['{' ~] ['}' ~]]
=/ errors=(list tank)
%+ murn results
|= [* * result=(unit build-result)]
^- (unit tank)
?. ?=([~ %error *] result)
~
`[%rose braces message.u.result]
::
?^ errors
:- ~
%- return-error
:- [%leaf failure]
errors
::
(handle-rest results)
::
++ filter-errors
|= results=(list [_key-bunt ^build (unit build-result)])
=. results
%+ skip results
|= [* * r=(unit build-result)]
?=([~ %error *] r)
(handle-rest results)
::
++ handle-rest
|= results=(list [_key-bunt ^build (unit build-result)])
:: if any sub-builds blocked, produce all blocked sub-builds
::
=/ blocks=(list ^build)
%+ murn `(list [* ^build (unit build-result)])`results
|= [* sub=^build result=(unit build-result)]
^- (unit ^build)
?^ result
~
`sub
::
?^ blocks
[~ (return-blocks blocks)]
::
:_ out
:- ~
%+ turn results
|* [key=_key-bunt ^build result=(unit build-result)]
^- [_key-bunt build-result]
[key (need result)]
--
:: +wrap-error: wrap an error message around a failed sub-build
::
++ wrap-error
|= result=(unit build-result)
^- build-receipt
::
?> ?=([~ %error *] result)
=/ message=tang
[[%leaf "ford: {<-.schematic.build>} failed: "] message.u.result]
::
(return-error message)
:: +return-blocks: exit +make as a blocked build
::
++ return-blocks
|= builds=(list ^build)
^- build-receipt
out(result [%blocks builds])
:: +return-error: exit +make with a specific failure message
::
++ return-error
|= =tang
^- build-receipt
out(result [%build-result %error tang])
:: +return-result: exit +make with a completed build
::
++ return-result
|= =build-result
^- build-receipt
out(result [%build-result build-result])
::
++ access-cache
|= =compiler-cache-key
^- [(unit build-result) _out]
::
?~ entry=(~(get by lookup.compiler-cache.state) compiler-cache-key)
[~ out(cache-access `[compiler-cache-key new=%.y])]
::
[`val.u.entry out(cache-access `[compiler-cache-key new=%.n])]
::
++ depend-on
|= kid=^build
^- [(unit build-result) _out]
::
?: =(kid build)
~| [%depend-on-self (build-to-tape kid)]
!!
::
=. sub-builds.out [kid sub-builds.out]
:: +access-build-record will mutate :results.state
::
:: It's okay to ignore this because the accessed-builds get gathered
:: and merged during the +reduce step.
::
=/ maybe-build-record -:(access-build-record kid)
?~ maybe-build-record
[~ out]
::
=* build-record u.maybe-build-record
?: ?=(%tombstone -.build-record)
[~ out]
::
[`build-result.build-record out]
:: +blocked-paths-to-receipt: handle the %2 case for mock
::
:: Multiple schematics handle +toon instances. This handles the %2 case
:: for a +toon and transforms it into a +build-receipt so we depend on
:: the blocked paths correctly.
::
++ blocked-paths-to-receipt
|= [name=term blocked-paths=(list path)]
^- build-receipt
::
=/ blocks-or-failures=(list (each ^build tank))
%+ turn blocked-paths
|= =path
::
=/ scry-request=(unit scry-request) (path-to-scry-request path)
?~ scry-request
[%| [%leaf "ford: {<name>}: invalid scry path: {<path>}"]]
::
=* case r.beam.u.scry-request
::
?. ?=(%da -.case)
[%| [%leaf "ford: {<name>}: invalid case in scry path: {<path>}"]]
::
=/ date=@da p.case
::
=/ resource=(unit resource) (path-to-resource path)
?~ resource
:- %|
[%leaf "ford: {<name>}: invalid resource in scry path: {<path>}"]
::
=/ sub-schematic=schematic [%pin date %scry u.resource]
::
[%& `^build`[date sub-schematic]]
::
=/ failed=tang
%+ murn blocks-or-failures
|= block=(each ^build tank)
^- (unit tank)
?- -.block
%& ~
%| `p.block
==
::
?^ failed
:: some failed
::
out(result [%build-result %error failed])
:: no failures
::
=/ blocks=(list ^build)
%+ turn blocks-or-failures
|= block=(each ^build tank)
?> ?=(%& -.block)
::
p.block
::
=. out
%+ roll blocks
|= [block=^build accumulator=_out]
=. out accumulator
+:(depend-on [date.block schematic.block])
::
(return-blocks blocks)
--
:: |utilities:per-event: helper arms
::
::+| utilities
::
:: +add-build: store a fresh, unstarted build in the state
::
++ add-build
~/ %add-build
|= =build
^+ state
:: don't overwrite an existing entry
::
?: (~(has by builds.state) build)
state
::
%_ state
builds-by-schematic
(~(put by-schematic builds-by-schematic.state) build)
::
builds
%+ ~(put by builds.state) build
=| =build-status
build-status(state [%untried ~])
==
:: +remove-builds: remove builds and their sub-builds
::
++ remove-builds
~/ %remove-builds
|= builds=(list build)
::
|^ ^+ state
::
?~ builds
state
::
?~ maybe-build-status=(~(get by builds.state) i.builds)
$(builds t.builds)
=/ subs ~(tap in ~(key by subs.u.maybe-build-status))
::
=^ removed state (remove-single-build i.builds u.maybe-build-status)
?. removed
$(builds t.builds)
::
$(builds (welp t.builds subs))
:: +remove-build: stop storing :build in the state
::
:: Removes all linkages to and from sub-builds
::
++ remove-single-build
|= [=build =build-status]
^+ [removed=| state]
:: never delete a build that something depends on
::
?^ clients.build-status
[removed=| state]
?^ requesters.build-status
[removed=| state]
:: nothing depends on :build, so we'll remove it
::
:- removed=&
::
%_ state
builds-by-schematic
(~(del by-schematic builds-by-schematic.state) build)
::
builds
(~(del by builds.state) build)
==
--
:: +update-build-status: replace :build's +build-status by running a function
::
++ update-build-status
~/ %update-build-status
|= [=build update-func=$-(build-status build-status)]
^- [build-status builds=_builds.state]
::
=/ original=build-status
~| [%update-build (build-to-tape build)]
(~(got by builds.state) build)
=/ mutant=build-status (update-func original)
::
[mutant (~(put by builds.state) build mutant)]
:: +intercepted-scry: augment real scry with local %scry build results
::
:: Try to deduplicate requests for possibly remote resources by looking up
:: the result in local state if the real scry has no synchronous
:: answer (it produced `~`).
::
++ intercepted-scry
%- sloy ^- slyd
~/ %intercepted-scry
|= [ref=* (unit (set monk)) =term =beam]
^- (unit (unit (cask milt)))
:: if the actual scry produces a value, use that value; otherwise use local
::
=/ scry-response (scry +<.$)
::
?^ scry-response
scry-response
::
=/ vane=(unit %c) ((soft ,%c) (end 3 1 term))
?~ vane
~
=/ care=(unit care:clay) ((soft care:clay) (rsh 3 1 term))
?~ care
~
?. ?=(%da -.r.beam)
~
=/ =resource [u.vane u.care rail=[[p.beam q.beam] s.beam]]
=/ =build [date=p.r.beam %scry resource]
:: look up the scry result from our permanent state
::
:: Note: we can't freshen :build's :last-accessed date because
:: we can't mutate :state from this gate. %scry results might get
:: deleted during %wipe more quickly than they should because of this.
::
=/ local-result -:(access-build-record build)
?~ local-result
~
?: ?=(%tombstone -.u.local-result)
~
::
=/ local-cage=cage (result-to-cage build-result.u.local-result)
:: if :local-result does not nest in :type, produce an error
::
?. -:(nets:wa +.ref `type`p.q.local-cage)
[~ ~]
::
[~ ~ local-cage]
:: +unblock-clients-on-duct: unblock and produce clients blocked on :build
::
++ unblock-clients-on-duct
=| unblocked=(list build)
~% %unblock-clients-on-duct +>+ ~
|= =build
^+ [unblocked builds.state]
::
=/ =build-status
~| [%unblocking (build-to-tape build)]
(~(got by builds.state) build)
::
=/ clients=(list ^build) ~(tap in (~(get ju clients.build-status) [%duct duct]))
::
|-
^+ [unblocked builds.state]
?~ clients
[unblocked builds.state]
::
=^ client-status builds.state
%+ update-build-status i.clients
|= client-status=^build-status
::
=. subs.client-status
%+ ~(jab by subs.client-status) build
|= original=build-relation
original(blocked |)
::
=? state.client-status
?& ?=(%blocked -.state.client-status)
::
?!
%- ~(any by subs.client-status)
|=(build-relation &(blocked verified))
==
::
[%unblocked ~]
client-status
::
=? unblocked !?=(%blocked -.state.client-status)
[i.clients unblocked]
::
$(clients t.clients)
:: +on-build-complete: handles completion of any build
::
++ on-build-complete
~/ %on-build-complete
|= =build
^+ ..execute
::
=. ..execute (cleanup-orphaned-provisional-builds build)
::
=/ duct-status (~(got by ducts.state) duct)
::
=/ =build-status (~(got by builds.state) build)
?: (~(has in requesters.build-status) [%duct duct])
(on-root-build-complete build)
::
=^ unblocked-clients builds.state (unblock-clients-on-duct build)
=. candidate-builds (~(gas in candidate-builds) unblocked-clients)
::
..execute
:: +on-root-build-complete: handle completion or promotion of a root build
::
:: When a build completes for a duct, we might have to send a %made move
:: on the requesting duct and also do duct and build book-keeping.
::
++ on-root-build-complete
~/ %on-root-build-complete
|= =build
^+ ..execute
::
=; res=_..execute
=/ duct-status=(unit duct-status)
(~(get by ducts.state.res) duct)
?~ duct-status res
:: debugging assertions to try to track down failure in
:: +copy-build-tree-as-provisional
::
~| [%failed-to-preserve-live-build (build-to-tape build)]
?> ?=(%live -.live.u.duct-status)
~| %failed-2
?> ?=(^ last-sent.live.u.duct-status)
~| %failed-3
?> .= build
[date.u.last-sent.live.u.duct-status root-schematic.u.duct-status]
~| %failed-4
?> (~(has by builds.state.res) build)
::
res
::
=/ =build-status (~(got by builds.state) build)
=/ =duct-status (~(got by ducts.state) duct)
:: make sure we have something to send
::
?> ?=([%complete %value *] state.build-status)
:: send a %made move unless it's an unchanged live build
::
=? moves
?!
?& ?=(%live -.live.duct-status)
?=(^ last-sent.live.duct-status)
::
=/ last-build-status
%- ~(got by builds.state)
[date.u.last-sent.live.duct-status schematic.build]
::
?> ?=(%complete -.state.last-build-status)
?& ?=(%value -.build-record.state.last-build-status)
::
.= build-result.build-record.state.last-build-status
build-result.build-record.state.build-status
== ==
:_ moves
^- move
::
:* duct %give %made date.build %complete
build-result.build-record.state.build-status
==
::
?- -.live.duct-status
%once
=. ducts.state (~(del by ducts.state) duct)
=. state (move-root-to-cache build)
::
..execute
::
%live
:: clean up previous build
::
=? state ?=(^ last-sent.live.duct-status)
=/ old-build=^build build(date date.u.last-sent.live.duct-status)
~? =(date.build date.old-build)
:+ "old and new builds have same date, will probably crash!"
(build-to-tape build)
(build-to-tape old-build)
::
(remove-anchor-from-root old-build [%duct duct])
::
=/ resource-list=(list [=disc resources=(set resource)])
~(tap by (collect-live-resources build))
:: we can only handle a single subscription
::
:: In the long term, we need Clay's interface to change so we can
:: subscribe to multiple desks at the same time.
::
?: (lth 1 (lent resource-list))
=. ..execute
%+ send-incomplete build :~
[%leaf "root build {(build-to-tape build)}"]
[%leaf "on duct:"]
[%leaf "{<duct>}"]
[%leaf "tried to subscribe to multiple discs:"]
[%leaf "{<resource-list>}"]
==
:: delete this instead of caching it, since it wasn't right
::
=. ducts.state (~(del by ducts.state) duct)
=. state (remove-anchor-from-root build [%duct duct])
..execute
::
=/ subscription=(unit subscription)
?~ resource-list
~
`[date.build disc.i.resource-list resources.i.resource-list]
::
=? ..execute ?=(^ subscription)
(start-clay-subscription u.subscription)
::
=. ducts.state
%+ ~(put by ducts.state) duct
%_ duct-status
live
[%live in-progress=~ last-sent=`[date.build subscription]]
==
::
..execute
==
:: +send-incomplete: emit a move indicating we can't complete :build
::
++ send-incomplete
|= [=build message=tang]
^+ ..execute
::
=. moves
:_ moves
`move`[duct %give %made date.build %incomplete message]
::
..execute
:: +cleanup-orphaned-provisional-builds: delete extraneous sub-builds
::
:: Remove unverified linkages to sub builds. If a sub-build has no other
:: clients on this duct, then it is orphaned and we remove the duct from
:: its subs and call +cleanup on it.
::
++ cleanup-orphaned-provisional-builds
~/ %cleanup-orphaned-provisional-builds
|= =build
^+ ..execute
::
=/ =build-status (~(got by builds.state) build)
::
=/ orphans=(list ^build)
%+ murn ~(tap by subs.build-status)
|= [sub=^build =build-relation]
^- (unit ^build)
::
?: verified.build-relation
~
`sub
:: remove links to orphans in :build's +build-status
::
=^ build-status builds.state
%+ update-build-status build
|= build-status=^build-status
%_ build-status
subs
::
|- ^+ subs.build-status
?~ orphans subs.build-status
::
=. subs.build-status (~(del by subs.build-status) i.orphans)
::
$(orphans t.orphans)
==
::
=/ =anchor [%duct duct]
::
|- ^+ ..execute
?~ orphans ..execute
:: remove link to :build in :i.orphan's +build-status
::
=^ orphan-status builds.state
%+ update-build-status i.orphans
|= orphan-status=_build-status
%_ orphan-status
clients (~(del ju clients.orphan-status) anchor build)
==
::
?: (~(has by clients.orphan-status) anchor)
$(orphans t.orphans)
:: :build was the last client on this duct so remove it
::
=. builds.state (remove-anchor-from-subs i.orphans anchor)
=. state (cleanup i.orphans)
$(orphans t.orphans)
:: +access-build-record: access a +build-record, updating :last-accessed
::
:: Usage:
:: ```
:: =^ maybe-build-record builds.state (access-build-record build)
:: ```
::
++ access-build-record
~/ %access-build-record
|= =build
^- [(unit build-record) _builds.state]
::
?~ maybe-build-status=(~(get by builds.state) build)
[~ builds.state]
::
=/ =build-status u.maybe-build-status
::
?. ?=(%complete -.state.build-status)
[~ builds.state]
::
?: ?=(%tombstone -.build-record.state.build-status)
[`build-record.state.build-status builds.state]
::
=. last-accessed.build-record.state.build-status now
::
:- `build-record.state.build-status
(~(put by builds.state) build build-status)
:: +cleanup: try to clean up a build and its sub-builds
::
++ cleanup
~/ %cleanup
|= =build
^+ state
:: does this build even exist?!
::
?~ maybe-build-status=(~(get by builds.state) build)
state
::
=/ =build-status u.maybe-build-status
:: never delete a build that something depends on
::
?^ clients.build-status
state
?^ requesters.build-status
state
::
(remove-builds ~[build])
:: +collect-live-resources: produces all live resources from sub-scrys
::
++ collect-live-resources
~/ %collect-live-resources
|= =build
^- (jug disc resource)
::
?: ?=(%scry -.schematic.build)
=* resource resource.schematic.build
(my [(extract-disc resource) (sy [resource]~)]~)
::
?: ?=(%pin -.schematic.build)
~
::
=/ subs
~| [%collect-live-resource (build-to-tape build)]
~(tap in ~(key by subs:(~(got by builds.state) build)))
=| resources=(jug disc resource)
|-
?~ subs
resources
::
=/ sub-resources=(jug disc resource) ^$(build i.subs)
=. resources (unify-jugs resources sub-resources)
$(subs t.subs)
:: +collect-blocked-resources: produces all blocked resources from sub-scrys
::
++ collect-blocked-sub-scrys
~/ %collect-blocked-sub-scrys
|= =build
^- (set scry-request)
::
?: ?=(%scry -.schematic.build)
=, resource.schematic.build
=/ =scry-request
:+ vane care
^- beam
[[ship.disc.rail desk.disc.rail [%da date.build]] spur.rail]
(sy [scry-request ~])
:: only recurse on blocked sub-builds
::
=/ subs=(list ^build)
%+ murn ~(tap by subs:(~(got by builds.state) build))
|= [sub=^build =build-relation]
^- (unit ^build)
::
?. blocked.build-relation
~
`sub
::
=| scrys=(set scry-request)
|-
^+ scrys
?~ subs
scrys
::
=. scrys (~(uni in scrys) ^$(build i.subs))
$(subs t.subs)
:: +start-clay-subscription: listen for changes in the filesystem
::
++ start-clay-subscription
~/ %start-clay-subscription
|= =subscription
^+ ..execute
::
=/ already-subscribed=?
(~(has by pending-subscriptions.state) subscription)
::
=. pending-subscriptions.state
(put-request pending-subscriptions.state subscription duct)
:: don't send a duplicate move if we're already subscribed
::
?: already-subscribed
..execute
::
=/ =wire (clay-subscription-wire [date disc]:subscription)
::
=/ =note
:: request-contents: the set of [care path]s to subscribe to in clay
::
=/ request-contents=(set [care:clay path])
%- sy ^- (list [care:clay path])
%+ murn ~(tap in `(set resource)`resources.subscription)
|= =resource ^- (unit [care:clay path])
::
`[care.resource (flop spur.rail.resource)]
:: if :request-contents is `~`, this code is incorrect
::
?< ?=(~ request-contents)
:: their: requestee +ship
::
=+ [their desk]=disc.subscription
::
:^ %c %warp ship=their
^- riff:clay
[desk `[%mult `case`[%da date.subscription] request-contents]]
::
=. moves [`move`[duct [%pass wire note]] moves]
::
..execute
:: +cancel-clay-subscription: remove a subscription on :duct
::
++ cancel-clay-subscription
~/ %cancel-clay-subscription
|= =subscription
^+ ..execute
::
=^ originator pending-subscriptions.state
(del-request pending-subscriptions.state subscription duct)
:: if there are still other ducts on this subscription, don't send a move
::
?~ originator
..execute
::
=/ =wire (clay-subscription-wire [date disc]:subscription)
::
=/ =note
=+ [their desk]=disc.subscription
[%c %warp ship=their `riff:clay`[desk ~]]
::
=. moves [`move`[u.originator [%pass wire note]] moves]
::
..execute
:: +clay-sub-wire: the wire to use for a clay subscription
::
:: While it is possible for two different root builds to make
:: subscriptions with the same wire, those wires will always be associated
:: with different ducts, so there's no risk of duplicates.
::
++ clay-subscription-wire
|= [date=@da =disc]
^- wire
::
=+ [their desk]=disc
::
/clay-sub/(scot %p their)/[desk]/(scot %da date)
:: +start-scry-request: kick off an asynchronous request for a resource
::
++ start-scry-request
|= =scry-request
^+ ..execute
:: if we are the first block depending on this scry, send a move
::
=/ already-started=? (~(has by pending-scrys.state) scry-request)
::
=. pending-scrys.state
(put-request pending-scrys.state scry-request duct)
:: don't send a duplicate move if we've already sent one
::
?: already-started
..execute
::
=/ =wire (scry-request-wire scry-request)
::
=/ =note
=, scry-request
=/ =disc [p q]:beam
:* %c %warp their=ship.disc desk.disc
`[%sing care case=r.beam (flop s.beam)]
==
::
=. moves [`move`[duct [%pass wire note]] moves]
::
..execute
:: +cancel-scry-request: cancel a pending asynchronous scry request
::
++ cancel-scry-request
|= =scry-request
^+ ..execute
::
=^ originator pending-scrys.state
(del-request pending-scrys.state scry-request duct)
:: if there are still other ducts on this subscription, don't send a move
::
?~ originator
..execute
::
=/ =wire (scry-request-wire scry-request)
::
=/ =note
=+ [their desk]=[p q]:beam.scry-request
[%c %warp ship=their `riff:clay`[desk ~]]
::
=. moves [`move`[u.originator [%pass wire note]] moves]
::
..execute
:: +scry-request-wire
::
++ scry-request-wire
|= =scry-request
^- wire
(welp /scry-request (scry-request-to-path scry-request))
--
--
::
:: end the =~
::
. ==
::
:::: vane interface
::
:: begin with a default +axle as a blank slate
::
=| ax=axle
:: a vane is activated with identity, the current date, entropy,
:: and a namespace function
::
|= [our=ship now=@da eny=@uvJ scry-gate=sley]
=* ford-gate .
:: allow jets to be registered within this core
::
~% %ford ..is ~
|%
:: +call: handle a +task:able from arvo
::
:: Ford can be tasked with:
::
:: %build: perform a build
:: %keep: resize caches
:: %kill: cancel a build
:: %wipe: clear memory
::
:: Most requests get converted into operations to be performed inside
:: the +per-event core, which is Ford's main build engine.
::
++ call
|= [=duct type=* wrapped-task=(hobo task:able)]
^- [(list move) _ford-gate]
:: unwrap :task from :wrapped-task
::
=/ task=task:able
?. ?=(%soft -.wrapped-task)
wrapped-task
;;(task:able p.wrapped-task)
:: we wrap +per-event with a call that binds our event args
::
=* this-event (per-event [our duct now scry-gate] state.ax)
::
?- -.task
:: %build: request to perform a build
::
%build
:: perform the build indicated by :task
::
:: We call :start-build on :this-event, which is the |per-event core
:: with the our event-args already bound. :start-build performs the
:: build and produces a pair of :moves and a mutant :state.
:: We update our :state and produce it along with :moves.
::
=/ =build [now schematic.task]
=^ moves state.ax (start-build:this-event build live.task)
::
[moves ford-gate]
::
:: %keep: keep :count cache entries
::
%keep
::
=. state.ax (keep:this-event [compiler-cache build-cache]:task)
::
[~ ford-gate]
::
:: %kill: cancel a %build
::
%kill
::
=^ moves state.ax cancel:this-event
::
[moves ford-gate]
::
:: %trim: in response to memory pressure
::
%trim
::
?. =(0 p.task)
:: low-priority: remove 50% of cache/stored-builds
::
~> %slog.[0 leaf+"ford: trim: pruning caches"]
=. state.ax (wipe:this-event 50)
[~ ford-gate]
::
:: high-priority: remove 100% of cache/stored-builds
::
:: We use %keep to ensure that cache-keys are also purged,
:: then restore original limits to allow future caching.
::
:: XX cancel in-progress builds?
::
~> %slog.[0 leaf+"ford: trim: clearing caches"]
=/ b-max max-size.queue.build-cache.state.ax
=/ c-max max-size.compiler-cache.state.ax
=. state.ax (keep:this-event 0 0)
=. state.ax (keep:this-event c-max b-max)
[~ ford-gate]
::
:: %vega: learn of kernel upgrade
::
:: XX clear cache, rebuild live builds
::
%vega
::
[~ ford-gate]
::
:: %wipe: wipe stored builds, clearing :percent-to-remove of the entries
::
%wipe
::
=. state.ax (wipe:this-event percent-to-remove.task)
::
[~ ford-gate]
::
%wegh
:_ ford-gate
:_ ~
:^ duct %give %mass
^- mass
:+ %ford %|
:~ builds+&+builds.state.ax
compiler-cache+&+compiler-cache.state.ax
dot+&+ax
==
==
:: +take: receive a response from another vane
::
:: A +take is a response to a request that Ford made of another vane.
::
:: Ford decodes the type of response based on the +wire in the +take.
:: The possibilities are:
::
:: %clay-sub: Clay notification of an update to a subscription
::
:: If Ford receives this, it will rebuild one or more live builds,
:: taking into account the new date and changed resources.
::
:: %scry-request: Clay response to a request for a resource
::
:: If Ford receives this, it will continue building one or more builds
:: that were blocked on this resource.
::
:: The +sign gets converted into operations to be performed inside
:: the +per-event core, which is Ford's main build engine.
::
++ take
|= [=wire =duct wrapped-sign=(hypo sign)]
^- [(list move) _ford-gate]
:: unwrap :sign, ignoring unneeded +type in :p.wrapped-sign
::
=/ =sign q.wrapped-sign
:: :wire must at least contain a tag for dispatching
::
?> ?=([@ *] wire)
::
|^ ^- [(list move) _ford-gate]
::
=^ moves state.ax
?+ i.wire ~|([%bad-take-wire wire] !!)
%clay-sub take-rebuilds
%scry-request take-unblocks
==
::
[moves ford-gate]
:: +take-rebuilds: rebuild all live builds affected by the Clay changes
::
++ take-rebuilds
^- [(list move) ford-state]
::
?> ?=([@tas %wris *] sign)
=* case-sign p.sign
=* care-paths-sign q.sign
=+ [ship desk date]=(raid:wired t.wire ~[%p %tas %da])
=/ disc [ship desk]
::
=/ =subscription
~| [%ford-take-bad-clay-sub wire=wire duct=duct]
=/ =duct-status (~(got by ducts.state.ax) duct)
?> ?=(%live -.live.duct-status)
?> ?=(^ last-sent.live.duct-status)
?> ?=(^ subscription.u.last-sent.live.duct-status)
u.subscription.u.last-sent.live.duct-status
::
=/ ducts=(list ^duct)
~| [%ford-take-missing-subscription subscription]
(get-request-ducts pending-subscriptions.state.ax subscription)
::
=| moves=(list move)
|- ^+ [moves state.ax]
?~ ducts [moves state.ax]
::
=* event-args [[our i.ducts now scry-gate] state.ax]
=* rebuild rebuild:(per-event event-args)
=^ duct-moves state.ax
(rebuild subscription p.case-sign disc care-paths-sign)
::
$(ducts t.ducts, moves (weld moves duct-moves))
:: +take-unblocks: unblock all builds waiting on this scry request
::
++ take-unblocks
^- [(list move) ford-state]
::
?> ?=([@tas %writ *] sign)
=* riot-sign p.sign
:: scry-request: the +scry-request we had previously blocked on
::
=/ =scry-request
~| [%ford-take-bad-scry-request wire=wire duct=duct]
(need (path-to-scry-request t.wire))
:: scry-result: parse a (unit cage) from :sign
::
:: If the result is `~`, the requested resource was not available.
::
=/ scry-result=(unit cage)
?~ riot-sign
~
`r.u.riot-sign
::
=/ ducts=(list ^duct)
~| [%ford-take-missing-scry-request scry-request]
(get-request-ducts pending-scrys.state.ax scry-request)
::
=| moves=(list move)
|- ^+ [moves state.ax]
?~ ducts [moves state.ax]
::
=* event-args [[our i.ducts now scry-gate] state.ax]
:: unblock the builds that had blocked on :resource
::
=* unblock unblock:(per-event event-args)
=^ duct-moves state.ax (unblock scry-request scry-result)
::
$(ducts t.ducts, moves (weld moves duct-moves))
--
:: +load: migrate old state to new state (called on vane reload)
::
:: Trim builds completely in case a change to our code invalidated an
:: old build result.
::
++ load
|= old=axle
^+ ford-gate
::
=. ax old
=. ford-gate +:(call ~[/ford-load-self] *type %trim 0)
ford-gate
:: +stay: produce current state
::
++ stay `axle`ax
:: +scry: request a path in the urbit namespace
::
++ scry
|= *
[~ ~]
--
Reference in New Issue View Git Blame Copy Permalink