mirror of
https://github.com/urbit/shrub.git
synced 2024-12-30 07:35:19 +03:00
6364 lines
208 KiB
Plaintext
6364 lines
208 KiB
Plaintext
:: 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)
|
|
::
|
|
?~ val=(~(get by tracker) request)
|
|
~
|
|
~(tap in waiting.u.val)
|
|
:: +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-build 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-build build)
|
|
=/ subs=(list ^build) ~(tap in ~(key by subs.build-status))
|
|
=/ client=^build build
|
|
::
|
|
|- ^+ builds.state
|
|
?~ subs builds.state
|
|
::
|
|
=/ sub-status=^build-status (got-build 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-build 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-build build)
|
|
=/ subs=(list ^build) ~(tap in ~(key by subs.build-status))
|
|
=/ client=^build build
|
|
::
|
|
|- ^+ builds.state
|
|
?~ subs builds.state
|
|
::
|
|
=/ sub-status=^build-status (got-build 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 (got-build 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-build 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 (got-build 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-build 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
|
|
::
|
|
:: +got-build: lookup :build in state, asserting presence
|
|
::
|
|
++ got-build
|
|
|= =build
|
|
^- build-status
|
|
~| [%ford-missing-build build=(build-to-tape build) duct=duct]
|
|
(~(got by builds.state) build)
|
|
:: +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 (got-build 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 meta)))
|
|
:: 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 (got-build 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-build 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-build 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-build build)
|
|
::
|
|
=/ orphans=(list ^build)
|
|
%+ murn ~(tap by subs.build-status)
|
|
|= [sub=^build =build-relation]
|
|
^- (unit ^build)
|
|
::
|
|
?: verified.build-relation
|
|
~
|
|
`sub
|
|
:: dequeue orphans in case we were about to run them
|
|
::
|
|
=/ orphan-set (~(gas in *(set ^build)) orphans)
|
|
=. next-builds (~(dif in next-builds) orphan-set)
|
|
=. candidate-builds (~(dif in candidate-builds) orphan-set)
|
|
:: 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 ~(tap in ~(key by subs:(got-build 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-build 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 dud=(unit goof) type=* wrapped-task=(hobo task:able)]
|
|
^- [(list move) _ford-gate]
|
|
?^ dud
|
|
~|(%ford-call-dud (mean tang.u.dud))
|
|
::
|
|
=/ task=task:able ((harden task:able) 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 dud=(unit goof) wrapped-sign=(hypo sign)]
|
|
^- [(list move) _ford-gate]
|
|
?^ dud
|
|
~|(%ford-take-dud (mean tang.u.dud))
|
|
:: 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]
|
|
::
|
|
~| [%ford-take-rebuilds wire=wire duct=duct]
|
|
?> ?=([@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]
|
|
:: ignore spurious clay updates
|
|
::
|
|
:: Due to asynchronicity of Clay notifications, we might get a
|
|
:: subscription update on an already-canceled duct. This is
|
|
:: normal; no-op.
|
|
::
|
|
?~ duct-status=(~(get by ducts.state.ax) duct)
|
|
[~ state.ax]
|
|
::
|
|
=/ =subscription
|
|
?> ?=(%live -.live.u.duct-status)
|
|
(need subscription:(need last-sent.live.u.duct-status))
|
|
::
|
|
=/ ducts=(list ^duct)
|
|
:: sanity check; there must be at least one duct per 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]
|
|
::
|
|
~| [%ford-take-unblocks wire=wire duct=duct]
|
|
?> ?=([@tas %writ *] sign)
|
|
=* riot-sign p.sign
|
|
:: scry-request: the +scry-request we had previously blocked on
|
|
::
|
|
=/ =scry-request (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
|
|
:: if spurious Clay response, :ducts will be empty, causing no-op
|
|
::
|
|
=/ ducts=(list ^duct)
|
|
(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
|
|
|= *
|
|
[~ ~]
|
|
--
|