shrub/lib/kiln.hoon

479 lines
17 KiB
Plaintext
Raw Normal View History

2015-05-12 03:31:37 +03:00
:: :: ::
2015-06-05 03:27:01 +03:00
:::: /hoon/kiln/lib :: ::
2015-05-12 03:31:37 +03:00
:: :: ::
/? 310 :: version
:: :: ::
:::: :: ::
:: :: ::
|% :: ::
++ kiln-part ,[%kiln %0 kiln-pith] :: kiln state
++ kiln-pith ::
$: rem=(map desk kiln-desk) ::
2015-05-26 04:20:45 +03:00
syn=(map hood-sync ,[let=@ud ust=bone]) ::
== ::
2015-05-12 03:31:37 +03:00
++ kiln-desk :: per-desk state
$: auto=? :: escalate on failure
gem=germ :: strategy
her=@p :: from ship
sud=@tas :: from desk
cas=case :: at case
== ::
:: :: ::
:::: :: ::
:: :: ::
2015-06-12 06:52:42 +03:00
++ hood-mount ::
$: pax=path ::
pot=term ::
2015-05-12 03:31:37 +03:00
== ::
2015-06-18 02:44:00 +03:00
++ hood-unmount ::
$|(term [span path]) ::
2015-05-12 03:31:37 +03:00
++ hood-sync ::
$: syd=desk ::
her=ship ::
sud=desk ::
== ::
2015-06-04 00:18:13 +03:00
++ hood-unsync ::
$: syd=desk ::
her=ship ::
sud=desk ::
== ::
2015-05-12 03:31:37 +03:00
++ hood-merge ::
$: syd=desk ::
ali=ship ::
sud=desk ::
gim=?(%auto germ) ::
== ::
2015-06-01 23:46:36 +03:00
++ hood-cp [input=path output=path] ::
++ hood-mv [input=path output=path] ::
2015-05-12 03:31:37 +03:00
-- ::
:: :: ::
:::: :: ::
!: :: ::
2015-05-12 23:10:22 +03:00
|% :: kiln library
2015-05-12 03:31:37 +03:00
++ kiln-work :: work in kiln
2015-05-28 09:51:32 +03:00
|= [bowl kiln-part]
2015-05-12 03:31:37 +03:00
?> =(src our)
=> |% :: arvo structures
++ card ::
$% [%exec wire @p beak (unit silk)] ::
[%info wire @p @tas nori] ::
2015-06-12 06:52:42 +03:00
[%mont wire @tas @p @tas path] ::
2015-06-18 02:44:00 +03:00
[%ogre wire $|(@tas beam)] ::
2015-05-12 03:31:37 +03:00
[%merg wire @p @tas @p @tas germ] ::
[%poke wire dock pear] ::
2015-05-26 04:20:45 +03:00
[%warp wire sock riff] ::
2015-05-12 03:31:37 +03:00
== ::
++ pear :: poke fruit
$% [%talk-command command:talk] ::
[%hood-merge hood-merge] ::
== ::
++ move (pair bone card) :: user-level move
--
|_ moz=(list move)
++ abet :: resolve
[(flop moz) `kiln-part`+>+>->]
::
++ emit |=(card %_(+> moz [[ost +<] moz])) :: return card
++ emil :: return cards
|= (list card)
^+ +>
?~(+< +> $(+< t.+<, +> (emit i.+<)))
::
2015-06-12 06:52:42 +03:00
++ poke-mount
|= hood-mount
=+ bem=(tome pax)
?~ bem
2015-06-18 02:44:00 +03:00
=+ "can't mount bad path: {<pax>}"
2015-06-12 06:52:42 +03:00
abet:(spam leaf/- ~)
abet:(emit %mont /mount pot p.u.bem q.u.bem (flop s.u.bem))
2015-05-12 03:31:37 +03:00
::
2015-06-18 02:44:00 +03:00
++ poke-unmount
|= mon=hood-unmount
?^ mon
=+ bem=(tome mon)
?~ bem
=+ "can't unmount bad path: {<mon>}"
abet:(spam leaf/- ~)
abet:(emit %ogre /unmount-beam [[p q %ud 0] s]:u.bem)
abet:(emit %ogre /unmount-point mon)
::
2015-05-12 03:31:37 +03:00
++ poke-sync ::
2015-05-26 04:20:45 +03:00
|= hos=hood-sync
2015-05-27 20:53:33 +03:00
?: (~(has by syn) hos)
=+ "already syncing from {<sud.hos>} on {<her.hos>} to {<syd.hos>}"
abet:(spam leaf/- ~)
2015-05-26 04:20:45 +03:00
abet:abet:start:(auto hos)
2015-05-12 03:31:37 +03:00
::
2015-06-04 00:18:13 +03:00
++ poke-unsync ::
|= hus=hood-unsync
?. (~(has by syn) hus)
=+ "not syncing from {<sud.hus>} on {<her.hus>} to {<syd.hus>}"
abet:(spam leaf/- ~)
%* . abet:abet:stop:(auto hus)
syn (~(del by syn) hus)
==
::
2015-05-12 03:31:37 +03:00
++ poke-merge ::
|= hood-merge
abet:abet:(merge:(work syd) ali sud gim)
::
2015-05-28 05:46:58 +03:00
++ do-info
|= [mez=tape tor=toro]
2015-06-10 02:35:04 +03:00
abet:(emit:(spam leaf/mez ~) %info /kiln our tor)
2015-06-04 00:18:13 +03:00
::
++ poke-rm |=(a=path (do-info "removed" (fray a)))
2015-05-28 05:46:58 +03:00
++ poke-cp
|= [input=path output=path]
%+ do-info "copied"
2015-05-28 05:46:58 +03:00
?> =(-:(flop input) -:(flop output))
(foal output -:(flop input) %noun .^(%cx input)) :: XX type
::
++ poke-mv
|= [input=path output=path]
%+ do-info "moved"
2015-05-28 05:46:58 +03:00
?> =(-:(flop input) -:(flop output))
%+ furl (fray output)
(foal output -:(flop input) %noun .^(%cx input))
::
++ poke-label
|= [syd=desk lab=@tas]
=+ pax=/(scot %p our)/[syd]/[lab]
(do-info "labeled {(spud pax)}" [syd %| lab])
::
++ poke-schedule
|= [where=path tym=@da eve=@t]
=. where (welp where /sched)
%+ do-info "scheduled"
=+ old=;;((map ,@da cord) (fall (file where) ~))
(foal where %sched !>((~(put by old) tym eve)))
::
2015-05-12 03:31:37 +03:00
++ take |=(way=wire ?>(?=([@ ~] way) (work i.way))) :: general handler
++ take-mere ::
|= [way=wire are=(each (set path) (pair term tang))]
abet:abet:(mere:(take way) are)
::
++ take-made ::
2015-05-26 23:56:21 +03:00
|= [way=wire dep=@uvH reg=gage]
2015-05-12 03:31:37 +03:00
abet:abet:(made:(take way) dep reg)
::
++ take-coup-fancy ::
|= [way=wire saw=(unit tang)]
abet:abet:(coup-fancy:(take way) saw)
::
2015-05-26 04:20:45 +03:00
++ take-mere-sync ::
|= [way=wire mes=(each (set path) (pair term tang))]
?> ?=([@ @ @ ~] way)
=+ ^- hos=hood-sync
:* syd=(slav %tas i.way)
her=(slav %p i.t.way)
sud=(slav %tas i.t.t.way)
==
abet:abet:(mere:(auto hos) mes)
::
++ take-writ ::
|= [way=wire rot=riot]
?> ?=([@ @ @ ~] way)
=+ ^- hos=hood-sync
:* syd=(slav %tas i.way)
her=(slav %p i.t.way)
sud=(slav %tas i.t.t.way)
==
abet:abet:(writ:(auto hos) rot)
::
++ spam
|= mes=(list tank)
%- emit
2015-06-02 02:25:22 +03:00
[%poke /kiln/spam [our %talk] (said our %kiln now eny mes)]
2015-05-26 04:20:45 +03:00
::
++ auto
|= hood-sync
=+ (fall (~(get by syn) syd her sud) [let=*@ud ust=ost])
|%
++ abet
..auto(syn (~(put by syn) [syd her sud] let ust))
::
++ blab
|= new=(list move)
^+ +>
+>.$(moz (welp new moz))
::
++ spam |*(* %_(+> ..auto (^spam +<)))
2015-06-04 00:18:13 +03:00
++ stop
=> (spam leaf/"ended autosync from {<sud>} on {<her>} to {<syd>}" ~)
%- blab :_ ~
:* ust %warp
/kiln/sync/[syd]/(scot %p her)/[sud]
[our her] sud ~
==
::
2015-05-26 04:20:45 +03:00
++ start
2015-06-09 18:23:40 +03:00
:: XX remove feedback for demo
:: =. . %- spam
:: [leaf/"activated sync from {<sud>} on {<her>} to {<syd>}" ~]
2015-05-26 04:20:45 +03:00
%- blab :_ ~
:* ost %warp
/kiln/sync/[syd]/(scot %p her)/[sud]
[our her] sud ~ %sing %w [%da now] /
2015-05-26 04:20:45 +03:00
==
::
++ writ
|= rot=riot
?~ rot
%^ spam
2015-06-03 02:17:55 +03:00
leaf/"bad %writ response on sync"
2015-05-26 04:20:45 +03:00
leaf/"from {<sud>} on {<her>} to {<syd>}"
~
=. let ?. ?=(%w p.p.u.rot) let ((hard ,@ud) q.q.r.u.rot)
%- blab :_ ~
:* ost %merg
/kiln/sync/[syd]/(scot %p her)/[sud]
2015-05-27 03:06:21 +03:00
our syd her sud
?: =(0 .^(%cw /(scot %p our)/[syd]/(scot %da now)))
2015-05-27 03:06:21 +03:00
%init
%mate
2015-05-26 04:20:45 +03:00
==
::
++ mere
|= mes=(each (set path) (pair term tang))
=. let +(let)
=. +>.$
%- spam
?: ?=(%& -.mes)
2015-06-20 01:14:19 +03:00
[leaf/"sync succeeded from {<sud>} on {<her>} to {<syd>}" ~]
2015-06-02 00:58:40 +03:00
?+ p.p.mes
2015-06-03 02:17:55 +03:00
:* leaf/"sync failed from {<sud>} on {<her>} to {<syd>}"
2015-06-02 00:58:40 +03:00
leaf/"please manually merge the desks with"
leaf/":+merge %{(trip syd)} {(scow %p her)} %{(trip sud)}"
leaf/""
leaf/"error code: {<p.p.mes>}"
q.p.mes
==
::
%no-ali-desk
2015-06-03 02:17:55 +03:00
:~ leaf/"sync activated from {<sud>} on {<her>} to {<syd>}"
leaf/"note: {<sud>} on {<her>} is a blank desk"
2015-06-02 00:58:40 +03:00
==
2015-05-26 04:20:45 +03:00
==
%- blab :_ ~
:* ost %warp
/kiln/sync/[syd]/(scot %p her)/[sud]
[our her] sud ~ %sing %y [%ud let] /
==
--
::
2015-05-12 03:31:37 +03:00
++ work :: state machine
|= syd=desk
=+ ^- kiln-desk
%+ fall (~(get by rem) syd)
=+ *kiln-desk
2015-05-28 06:54:20 +03:00
%_(- cas [%da now])
2015-05-12 03:31:37 +03:00
|%
++ abet :: resolve
..work(rem (~(put by rem) syd auto gem her sud cas))
::
2015-05-26 04:20:45 +03:00
++ blab
2015-05-12 03:31:37 +03:00
|= new=(list move)
^+ +>
+>.$(moz (welp new moz))
::
++ win . :: successful poke
++ lose
^+ .
~| %kiln-work-fail
2015-05-27 03:06:21 +03:00
.
2015-05-12 03:31:37 +03:00
::
2015-05-26 23:56:21 +03:00
++ ford-fail
2015-05-28 05:46:58 +03:00
|=(tan=tang ~|(%ford-fail (mean tan)))
2015-05-12 03:31:37 +03:00
::
2015-05-26 23:56:21 +03:00
++ unwrap-tang
|* res=(each ,* tang)
?: ?=(%& -.res)
p.res
(ford-fail p.res)
::
++ gage-to-cages
|= gag=gage ^- (list (pair cage cage))
(unwrap-tang (gage-to-tage gag))
::
++ gage-to-tage
|= gag=gage
^- (each (list (pair cage cage)) tang)
?. ?=(%tabl -.gag)
(mule |.(`~`(ford-fail >%strange-gage< ~)))
=< ?+(. [%& .] [@ *] .)
|- ^- ?((list ,[cage cage]) (each ,~ tang))
?~ p.gag ~
=* hed i.p.gag
?- -.p.hed
%tabl (mule |.(`~`(ford-fail >%strange-gage< ~)))
%| (mule |.(`~`(ford-fail p.p.hed)))
%& ?- -.q.hed
%tabl (mule |.(`~`(ford-fail >%strange-gage< ~)))
%| (mule |.(`~`(ford-fail p.q.hed)))
%& =+ $(p.gag t.p.gag)
?+(- [[p.p p.q]:hed -] [@ *] -)
== ==
2015-05-12 03:31:37 +03:00
::
++ perform ::
^+ .
(blab [ost %merg /kiln/[syd] our syd her sud gem] ~)
::
2015-05-14 00:18:43 +03:00
++ fancy-merge :: send to self
2015-05-12 03:31:37 +03:00
|= [syd=desk her=@p sud=desk gem=?(%auto germ)]
^+ +>
%- blab :_ ~
2015-05-14 00:18:43 +03:00
[ost %poke /kiln/fancy/[^syd] [our %hood] %hood-merge [syd her sud gem]]
2015-05-12 03:31:37 +03:00
::
2015-05-26 04:20:45 +03:00
++ spam |*(* +>(..work (^spam +<)))
2015-05-12 03:31:37 +03:00
++ merge
|= [her=@p sud=@tas gim=?(%auto germ)]
^+ +>
2015-05-28 06:54:20 +03:00
=. cas [%da now]
2015-05-12 03:31:37 +03:00
?. ?=(%auto gim)
perform(auto |, gem gim, her her, sud sud)
2015-05-28 06:54:20 +03:00
?: =(0 .^(%cw /(scot %p our)/[syd]/(scot %da now)))
2015-05-12 03:31:37 +03:00
=> $(gim %init)
.(auto &)
=> $(gim %fine)
.(auto &)
::
++ coup-fancy
|= saw=(unit tang)
?~ saw
=> (spam leaf/"%melding %{(trip sud)} into scratch space" ~)
%- blab :_ ~
[ost %merg /kiln/[syd] our (cat 3 syd '-scratch') her sud gem]
=+ :- "failed to set up conflict resolution scratch space"
"I'm out of ideas"
lose:(spam leaf/-< leaf/-> ~)
::
++ mere
|= are=(each (set path) (pair term tang))
^+ +>
?: =(%meld gem)
?: ?=(%& -.are)
?. auto
2015-06-03 02:17:55 +03:00
=+ "merged with strategy {<gem>}"
2015-05-12 03:31:37 +03:00
win:(spam leaf/- ?~(p.are ~ [>`(set path)`p.are< ~]))
=+ "mashing conflicts"
=> .(+>.$ (spam leaf/- ~))
=+ tic=(cat 3 syd '-scratch')
%- blab :_ ~
:* ost %exec /kiln/[syd]
2015-05-28 06:54:20 +03:00
our [our tic %da now] ~ %tabl
2015-05-12 03:31:37 +03:00
^- (list (pair silk silk))
%+ turn (~(tap in p.are))
|= pax=path
^- (pair silk silk)
:- [%$ %path -:!>(*path) pax]
2015-05-28 06:54:20 +03:00
=+ base=[%file [our tic %da now] (flop pax)]
2015-05-12 03:31:37 +03:00
=+ alis=[%file [her sud cas] (flop pax)]
2015-05-28 06:54:20 +03:00
=+ bobs=[%file [our syd %da now] (flop pax)]
2015-05-12 03:31:37 +03:00
=+ dali=[%diff base alis]
=+ dbob=[%diff base bobs]
=+ ^- for=mark
=+ (slag (dec (lent pax)) pax)
?~(- %$ i.-)
[%mash for [her sud dali] [our syd dbob]]
==
=+ "failed to merge with strategy {<p.p.are>}"
lose:(spam leaf/- q.p.are)
?: ?=(%& -.are)
2015-06-03 02:17:55 +03:00
=+ "merged with strategy {<gem>}"
2015-05-12 03:31:37 +03:00
win:(spam leaf/- ?~(p.are ~ [>`(set path)`p.are< ~]))
?. auto
=+ "failed to merge with strategy {<p.p.are>}"
lose:(spam leaf/- q.p.are)
?+ gem
(spam leaf/"strange auto" >gem< ~)
::
%init
=+ :- "auto merge failed on strategy %init"
"I'm out of ideas"
lose:(spam leaf/-< leaf/-> [>p.p.are< q.p.are])
::
%fine
?. ?=(%bad-fine-merge p.p.are)
=+ "auto merge failed on strategy %fine"
lose:(spam leaf/- >p.p.are< q.p.are)
=> (spam leaf/"%fine merge failed, trying %meet" ~)
perform(gem %meet)
::
%meet
?. ?=(%meet-conflict p.p.are)
=+ "auto merge failed on strategy %meet"
lose:(spam leaf/- >p.p.are< q.p.are)
=> (spam leaf/"%meet merge failed, trying %mate" ~)
perform(gem %mate)
::
%mate
?. ?=(%mate-conflict p.p.are)
=+ "auto merge failed on strategy %mate"
lose:(spam leaf/- >p.p.are< q.p.are)
=> .(gem %meld)
=+ tic=(cat 3 syd '-scratch')
=> =+ :- "%mate merge failed with conflicts,"
"setting up scratch space at %{(trip tic)}"
[tic=tic (spam leaf/-< leaf/-> ~)]
(fancy-merge tic our syd %auto)
==
::
++ made
2015-05-26 23:56:21 +03:00
|= [dep=@uvH reg=gage]
2015-05-12 03:31:37 +03:00
^+ +>
?: ?=(%| -.reg)
=+ "failed to mash"
lose:(spam leaf/- p.reg)
=+ ^- can=(list (pair path (unit miso)))
2015-05-26 23:56:21 +03:00
%+ turn (gage-to-cages reg)
2015-05-12 03:31:37 +03:00
|= [pax=cage dif=cage]
^- (pair path (unit miso))
?. ?=(%path p.pax)
~| "strange path mark: {<p.pax>}"
!!
[((hard path) q.q.pax) ?:(?=(%null p.dif) ~ `[%dif dif])]
=+ notated=(skid can |=([path a=(unit miso)] ?=(^ a)))
=+ annotated=(turn `(list (pair path ,*))`-.notated head)
=+ unnotated=(turn `(list (pair path ,*))`+.notated head)
=+ (trip (cat 3 syd '-scratch'))
=+ ^- tan=(list tank)
%- zing
^- (list (list tank))
:~ :~ leaf/""
leaf/"done setting up scratch space in %{-}"
leaf/"please resolve the following conflicts and run"
2015-05-12 23:10:22 +03:00
leaf/":+merge %{(trip syd)} {<our>} %{-}"
2015-05-12 03:31:37 +03:00
==
?~ annotated
~
:~ leaf/""
leaf/"annotated conflicts in:"
>`(list path)`annotated<
==
?~ unnotated
~
:~ leaf/""
leaf/"some conflicts could not be annotated."
leaf/"for these, the scratch space contains"
leaf/"the most recent common ancestor of the"
leaf/"conflicting content."
leaf/""
leaf/"unannotated conflicts in:"
>`(list path)`unnotated<
==
==
=< win
%- blab:(spam tan)
:_ ~
2015-05-26 04:20:45 +03:00
:* ost %info /kiln/[syd]
2015-05-12 03:31:37 +03:00
our (cat 3 syd '-scratch')
%& *cart
%+ murn can
|= [p=path q=(unit miso)]
`(unit (pair path miso))`?~(q ~ `[p u.q])
==
--
--
--