From 9b310e1ad53b60234139c52c06d2e286c68f98c4 Mon Sep 17 00:00:00 2001 From: Greg Pfeil Date: Fri, 17 Jan 2025 14:53:06 -0700 Subject: [PATCH 1/5] Add a failing transcript for 2805 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit It shows that we can’t pass numbers to `run`. (This also touches more of `all-base-hashes.output.md` than I would have expected, but it does add some definitions to base.u.) --- .../all-base-hashes.output.md | 161 +++++++++--------- unison-src/transcripts-using-base/base.u | 12 +- unison-src/transcripts-using-base/fix-2805.md | 20 +++ .../transcripts-using-base/fix-2805.output.md | 57 +++++++ 4 files changed, 173 insertions(+), 77 deletions(-) create mode 100644 unison-src/transcripts-using-base/fix-2805.md create mode 100644 unison-src/transcripts-using-base/fix-2805.output.md diff --git a/unison-src/transcripts-using-base/all-base-hashes.output.md b/unison-src/transcripts-using-base/all-base-hashes.output.md index d60d5ae872..c736299cb4 100644 --- a/unison-src/transcripts-using-base/all-base-hashes.output.md +++ b/unison-src/transcripts-using-base/all-base-hashes.output.md @@ -2743,243 +2743,252 @@ scratch/main> find.verbose 779. -- #13fpchr37ua0pr38ssr7j22pudmseuedf490aok18upagh0f00kg40guj9pgl916v9qurqrvu53f3lpsvi0s82hg3dtjacanrpjvs38 fromHex : Text -> Bytes - 780. -- #od69b4q2upcvsdjhb7ra8unq1r8t7924mra5j5s8f7n173bmslp8dprhgt1mjdj49qj10h2gj91eflke1avj0qlecus1mdevufm3hho + 780. -- #b5ljjbncgukq958frsqtuebv9b1ack0blhqcue5km6k15gotubesaj6bv3ii61f676qcfq5rimmjtrihio7pnk8r9noe3s3v7lk4i5o + getArgs : '{IO, Exception} [Text] + + 781. -- #od69b4q2upcvsdjhb7ra8unq1r8t7924mra5j5s8f7n173bmslp8dprhgt1mjdj49qj10h2gj91eflke1avj0qlecus1mdevufm3hho getBuffering : Handle ->{IO, Exception} BufferMode - 781. -- #fupr0p6pmt834qep0jp18h9jhf4uadmtrsndpfac3kpkf4q4foqnqi6dmc6u4mgs9aubl8issknu89taqhi1mvaeg1ctbt3uf2lidh8 + 782. -- #fupr0p6pmt834qep0jp18h9jhf4uadmtrsndpfac3kpkf4q4foqnqi6dmc6u4mgs9aubl8issknu89taqhi1mvaeg1ctbt3uf2lidh8 getBytes : Handle -> Nat ->{IO, Exception} Bytes - 782. -- #qgocu5n2e7urg44ch4m8upn24efh6jk4cmp8bjsvhnenhahq8nniauav0ihpqa31p57v8fhqdep4fh5dj7nj1uul7596us04dr6dqng + 783. -- #qgocu5n2e7urg44ch4m8upn24efh6jk4cmp8bjsvhnenhahq8nniauav0ihpqa31p57v8fhqdep4fh5dj7nj1uul7596us04dr6dqng getChar : Handle ->{IO, Exception} Char - 783. -- #t92if409jh848oifd8v6bbu6o0hd0916rc3rbdlj4vf46oll2tradqrilk6r28mmm19dao5sh8l349qrhc59qopv4u1hba3ndfiitq8 + 784. -- #t92if409jh848oifd8v6bbu6o0hd0916rc3rbdlj4vf46oll2tradqrilk6r28mmm19dao5sh8l349qrhc59qopv4u1hba3ndfiitq8 getEcho : Handle ->{IO, Exception} Boolean - 784. -- #5nc47o8abjut8sab84ltouhiv3mtid9poipn2b53q3bpceebdimb4sb1e7lkrmu3bn3ivgcqe568upqqh5clrqgkhfdsji58kcdrt4g + 785. -- #5nc47o8abjut8sab84ltouhiv3mtid9poipn2b53q3bpceebdimb4sb1e7lkrmu3bn3ivgcqe568upqqh5clrqgkhfdsji58kcdrt4g getLine : Handle ->{IO, Exception} Text - 785. -- #l9pfqiqb3u9o8qo7jnaajph1qh0jbodih4vtuqti53vjmtp4diddidt8r2qa826918bt7b1cf873oo511tkivfkg35fo5o4kh5j35r0 + 786. -- #l9pfqiqb3u9o8qo7jnaajph1qh0jbodih4vtuqti53vjmtp4diddidt8r2qa826918bt7b1cf873oo511tkivfkg35fo5o4kh5j35r0 getSomeBytes : Handle -> Nat ->{IO, Exception} Bytes - 786. -- #mdhva408l4fji5h23okmhk5t4dakt1lokuie28nsdspal45lbhe06vkmcu8hf8jplse56o576ogn72j7k5nbph06nl36o957qn25tvo + 787. -- #mdhva408l4fji5h23okmhk5t4dakt1lokuie28nsdspal45lbhe06vkmcu8hf8jplse56o576ogn72j7k5nbph06nl36o957qn25tvo getTempDirectory : '{IO, Exception} Text - 787. -- #vniqolukf0296u5dc6d68ngfvi9quuuklcsjodnfm0tm8atslq19sidso2uqnbf4g6h23qck69dpd0oceb9539ufoo12rhdcdd934lo + 788. -- #vniqolukf0296u5dc6d68ngfvi9quuuklcsjodnfm0tm8atslq19sidso2uqnbf4g6h23qck69dpd0oceb9539ufoo12rhdcdd934lo handlePosition : Handle ->{IO, Exception} Nat - 788. -- #85s6gvfbpv8lhgq8m36h7ebvan4lljiu2ffehbgese5c11h3vpqlcssts8svi2qo2c5d68oeke092puta1ng84982hiid972hss9m40 + 789. -- #85s6gvfbpv8lhgq8m36h7ebvan4lljiu2ffehbgese5c11h3vpqlcssts8svi2qo2c5d68oeke092puta1ng84982hiid972hss9m40 handshake : Tls ->{IO, Exception} () - 789. -- #128490j1tmitiu3vesv97sqspmefobg1am38vos9p0vt4s1bhki87l7kj4cctquffkp40eanmr9ummfglj9i7s25jrpb32ob5sf2tio + 790. -- #128490j1tmitiu3vesv97sqspmefobg1am38vos9p0vt4s1bhki87l7kj4cctquffkp40eanmr9ummfglj9i7s25jrpb32ob5sf2tio hex : Bytes -> Text - 790. -- #ttjui80dbufvf3vgaddmcr065dpgl0rtp68i5cdht6tq4t2vk3i2vg60hi77rug368qijgijf8oui27te7o5oq0t0osm6dg65c080i0 + 791. -- #ttjui80dbufvf3vgaddmcr065dpgl0rtp68i5cdht6tq4t2vk3i2vg60hi77rug368qijgijf8oui27te7o5oq0t0osm6dg65c080i0 id : a -> a - 791. -- #0lj5fufff9ocn6lfgc3sv23aup971joh61ei6llu7djblug7tmv2avijc91ing6jmm42hu3akdefl1ttdvepk69sc8jslih1g80npg8 + 792. -- #0lj5fufff9ocn6lfgc3sv23aup971joh61ei6llu7djblug7tmv2avijc91ing6jmm42hu3akdefl1ttdvepk69sc8jslih1g80npg8 isDirectory : Text ->{IO, Exception} Boolean - 792. -- #flakrb6iks7vgijtm8dhipj14v57tk96nq5uj3uluplpoamb1etufn7rsjrelaj3letaa0e2aivq95794nv2b8a8vqbqdumd6i0fvpo + 793. -- #flakrb6iks7vgijtm8dhipj14v57tk96nq5uj3uluplpoamb1etufn7rsjrelaj3letaa0e2aivq95794nv2b8a8vqbqdumd6i0fvpo isFileEOF : Handle ->{IO, Exception} Boolean - 793. -- #5qan8ssedn9pouru70v1a06tkivapiv0es8k6v3hjpmkmboekktnh30ia7asmevglf4pu8ujb0t9vsctjsjtam160o9bn9g02uciui8 + 794. -- #5qan8ssedn9pouru70v1a06tkivapiv0es8k6v3hjpmkmboekktnh30ia7asmevglf4pu8ujb0t9vsctjsjtam160o9bn9g02uciui8 isFileOpen : Handle ->{IO, Exception} Boolean - 794. -- #2a11371klrv2i8726knma0l3g14on4m2ucihpg65cjj9k930aefg65ovvg0ak4uv3i9evtnu0a5249q3i8ugheqd65cnmgquc1a88n0 + 795. -- #2a11371klrv2i8726knma0l3g14on4m2ucihpg65cjj9k930aefg65ovvg0ak4uv3i9evtnu0a5249q3i8ugheqd65cnmgquc1a88n0 isNone : Optional a -> Boolean - 795. -- #jsqdsol9g3qnkub2f2ogertbiieldlkqh859vn5qovub6halelfmpv1tc50u1n23kotgd9nnejnn0n6foef8aqfcp615ashd0cfi3j8 + 796. -- #jsqdsol9g3qnkub2f2ogertbiieldlkqh859vn5qovub6halelfmpv1tc50u1n23kotgd9nnejnn0n6foef8aqfcp615ashd0cfi3j8 isSeekable : Handle ->{IO, Exception} Boolean - 796. -- #gop2v9s6l24ii1v6bf1nks2h0h18pato0vbsf4u3el18s7mp1jfnp4c7fesdf9sunnlv5f5a9fjr1s952pte87mf63l1iqki9bp0mio + 797. -- #gop2v9s6l24ii1v6bf1nks2h0h18pato0vbsf4u3el18s7mp1jfnp4c7fesdf9sunnlv5f5a9fjr1s952pte87mf63l1iqki9bp0mio List.all : (a ->{ε} Boolean) -> [a] ->{ε} Boolean - 797. -- #thvdk6pgdi019on95nttjhg3rbqo7aq5lv9fqgehg00657utkitc1k5r9bfl7soqdrqd82tjmesn5ocb6d30ire6vkl0ad6rcppg5vo + 798. -- #thvdk6pgdi019on95nttjhg3rbqo7aq5lv9fqgehg00657utkitc1k5r9bfl7soqdrqd82tjmesn5ocb6d30ire6vkl0ad6rcppg5vo List.filter : (a ->{g} Boolean) -> [a] ->{g} [a] - 798. -- #ca71f74kmn16u76lch7ropsgou2t3lbtc5hr06858l97qkhk0b4ado1pnii4hqfannelbgv4qruv4f1iqn43kgkbsq8lpjmo3mnrp38 + 799. -- #ca71f74kmn16u76lch7ropsgou2t3lbtc5hr06858l97qkhk0b4ado1pnii4hqfannelbgv4qruv4f1iqn43kgkbsq8lpjmo3mnrp38 List.foldLeft : (b ->{g} a ->{g} b) -> b -> [a] ->{g} b - 799. -- #o1gssqn32qvl4pa79a0lko5ksvbn0rtv8u5g9jpd73ig94om2r4nlbcqa4nd968q74ios37eg0ol36776praolimpch8jsbohg47j2o + 800. -- #o1gssqn32qvl4pa79a0lko5ksvbn0rtv8u5g9jpd73ig94om2r4nlbcqa4nd968q74ios37eg0ol36776praolimpch8jsbohg47j2o List.forEach : [a] -> (a ->{e} ()) ->{e} () - 800. -- #atruig2897q7u699k1u4ruou8epfb9qsok7ojkm5om67fhhaqgdi597jr7dvr09h9qndupc49obo4cccir98ei1grfehrcd5qhnkcq0 + 801. -- #ol837rn3935jnul9r2ri4i7gqonu2jp9maqmbr072mmk35tl0kq19s4ltuche8seihf8d246a6upgpdlvs6ocdbsgdm7k88bonhgmn8 + List.head : [t] -> Optional t + + 802. -- #atruig2897q7u699k1u4ruou8epfb9qsok7ojkm5om67fhhaqgdi597jr7dvr09h9qndupc49obo4cccir98ei1grfehrcd5qhnkcq0 List.range : Nat -> Nat -> [Nat] - 801. -- #marlqbcbculvqjfro3iidf899g2ncob2f8ld3gosg7kas5t9hlh341d49uh57ff5litvrt0hlb2ms7tj0mkfqs9do67cm4msodt8dng + 803. -- #marlqbcbculvqjfro3iidf899g2ncob2f8ld3gosg7kas5t9hlh341d49uh57ff5litvrt0hlb2ms7tj0mkfqs9do67cm4msodt8dng List.reverse : [a] -> [a] - 802. -- #30hfqasco93u0oipi7irfoabh5uofuu2aeplo2c87p4dg0386si6gvv715dbr21s4ftfquev4baj5ost3h17mt8fajn64mbffp6c8c0 + 804. -- #30hfqasco93u0oipi7irfoabh5uofuu2aeplo2c87p4dg0386si6gvv715dbr21s4ftfquev4baj5ost3h17mt8fajn64mbffp6c8c0 List.unzip : [(a, b)] -> ([a], [b]) - 803. -- #s8l7maltpsr01naqadvs5ssttg7eim4ca2096lbo3f3he1i1b11kk95ahtgb5ukb8cjr6kg4r4c1qrvshk9e8dp5fkq87254gc1pk48 + 805. -- #s8l7maltpsr01naqadvs5ssttg7eim4ca2096lbo3f3he1i1b11kk95ahtgb5ukb8cjr6kg4r4c1qrvshk9e8dp5fkq87254gc1pk48 List.zip : [a] -> [b] -> [(a, b)] - 804. -- #g6g6lhj9upe46032doaeo0ndu8lh1krfkc56gvupeg4a16me5vghhi6bthphnsvgtve9ogl73qab6d69ju6uorpj029g97pjg3p2k2o + 806. -- #g6g6lhj9upe46032doaeo0ndu8lh1krfkc56gvupeg4a16me5vghhi6bthphnsvgtve9ogl73qab6d69ju6uorpj029g97pjg3p2k2o listen : Socket ->{IO, Exception} () - 805. -- #ilva5f9uoaia9l8suc3hl9kh2bg1lah1k7uvm8mlq3mt0b9krdh15kurbhb9pu7a8irmvk6m2lpulg75a5alf0a95u0rp0v0n9folmg + 807. -- #ilva5f9uoaia9l8suc3hl9kh2bg1lah1k7uvm8mlq3mt0b9krdh15kurbhb9pu7a8irmvk6m2lpulg75a5alf0a95u0rp0v0n9folmg loadCodeBytes : Bytes ->{Exception} Code - 806. -- #tjj9c7fbprd57jlnndl8huslhvfbhi1bt1mr45v1fvvr2b3bguhnjtll3lbsbnqqjb290tm9cnuafpbtlfev1csbtjjog0r2kfv0e50 + 808. -- #tjj9c7fbprd57jlnndl8huslhvfbhi1bt1mr45v1fvvr2b3bguhnjtll3lbsbnqqjb290tm9cnuafpbtlfev1csbtjjog0r2kfv0e50 loadSelfContained : Text ->{IO, Exception} a - 807. -- #1pkgu9vbcdl57d9pn9ses1htmfokjq6212ed5oo9jscjkf8t2s407j71287hd9nr1shgsjmn0eunm5e7h262id4hh3t4op6barrvc70 + 809. -- #1pkgu9vbcdl57d9pn9ses1htmfokjq6212ed5oo9jscjkf8t2s407j71287hd9nr1shgsjmn0eunm5e7h262id4hh3t4op6barrvc70 loadValueBytes : Bytes ->{IO, Exception} ([(Link.Term, Code)], Value) - 808. -- #nqodnhhovq1ilb5fstpc61l8omfto62r8s0qq8s4ij39ulorqpgtinef64mullq0ns4914gck6obeuu6so1hds09hh5o1ptpt4k909g + 810. -- #nqodnhhovq1ilb5fstpc61l8omfto62r8s0qq8s4ij39ulorqpgtinef64mullq0ns4914gck6obeuu6so1hds09hh5o1ptpt4k909g MVar.put : MVar i -> i ->{IO, Exception} () - 809. -- #4ck8hqiu4m7478q5p7osqd1g9piie53g2v6j89en9s90f3cnhb9jr2515f35605e18ohiod7nb93t03765cil0lecob3hcsht9870g0 + 811. -- #4ck8hqiu4m7478q5p7osqd1g9piie53g2v6j89en9s90f3cnhb9jr2515f35605e18ohiod7nb93t03765cil0lecob3hcsht9870g0 MVar.read : MVar o ->{IO, Exception} o - 810. -- #tchse01rs4t1e6bk9br5ofad23ahlb9eanlv9nqqlk5eh7rv7qtpd5jmdjrcksm1q3uji64kqblrqq0vgap9tmak3urkr3ok4kg2ci0 + 812. -- #tchse01rs4t1e6bk9br5ofad23ahlb9eanlv9nqqlk5eh7rv7qtpd5jmdjrcksm1q3uji64kqblrqq0vgap9tmak3urkr3ok4kg2ci0 MVar.swap : MVar o -> o ->{IO, Exception} o - 811. -- #23nq5mshk51uktsg3su3mnkr9s4fe3sktf4q388bpsluiik64l8h060qptgfv48r25fcskecmc9t4gdsm8im9fhjf70i1klp34epksg + 813. -- #23nq5mshk51uktsg3su3mnkr9s4fe3sktf4q388bpsluiik64l8h060qptgfv48r25fcskecmc9t4gdsm8im9fhjf70i1klp34epksg MVar.take : MVar o ->{IO, Exception} o - 812. -- #18pqussken2f5u9vuall7ds58cf4fajoc4trf7p93vk4640ia88vsh2lgq9kgu8fvpr86518443ecvn7eo5tessq2hmgs55aiftui8g + 814. -- #18pqussken2f5u9vuall7ds58cf4fajoc4trf7p93vk4640ia88vsh2lgq9kgu8fvpr86518443ecvn7eo5tessq2hmgs55aiftui8g newClient : ClientConfig -> Socket ->{IO, Exception} Tls - 813. -- #mmoj281h8bimgcfqfpfg6mfriu8cta5vva4ppo41ioc6phegdfii26ic2s5sh0lf5tc6o15o7v79ui8eeh2mbicup07tl6hkrq9q34o + 815. -- #mmoj281h8bimgcfqfpfg6mfriu8cta5vva4ppo41ioc6phegdfii26ic2s5sh0lf5tc6o15o7v79ui8eeh2mbicup07tl6hkrq9q34o newServer : ServerConfig -> Socket ->{IO, Exception} Tls - 814. -- #r6l6s6ni7ut1b9le2d84el9dkhqjcjhodhd0l1qsksahm4cbgdk0odjck9jnku08v0pn909kabe2v88p43jisavkariomtgmtrrtbu8 + 816. -- #r6l6s6ni7ut1b9le2d84el9dkhqjcjhodhd0l1qsksahm4cbgdk0odjck9jnku08v0pn909kabe2v88p43jisavkariomtgmtrrtbu8 openFile : Text -> FileMode ->{IO, Exception} Handle - 815. -- #c58qbcgd90d965dokk7bu82uehegkbe8jttm7lv4j0ohgi2qm3e3p4v1qfr8vc2dlsmsl9tv0v71kco8c18mneule0ntrhte4ks1090 + 817. -- #de42pjerlsm688s7llh6obrno8j5kq8rf5k931a5nq94o4475qi6ed0c5paqhem6aqi1e6th058qank01j7csc2sp7au9prhkjk31c8 + Optional.getOrBug : msg -> Optional a -> a + + 818. -- #c58qbcgd90d965dokk7bu82uehegkbe8jttm7lv4j0ohgi2qm3e3p4v1qfr8vc2dlsmsl9tv0v71kco8c18mneule0ntrhte4ks1090 printLine : Text ->{IO, Exception} () - 816. -- #dck7pb7qv05ol3b0o76l88a22bc7enl781ton5qbs2umvgsua3p16n22il02m29592oohsnbt3cr7hnlumpdhv2ibjp6iji9te4iot0 + 819. -- #dck7pb7qv05ol3b0o76l88a22bc7enl781ton5qbs2umvgsua3p16n22il02m29592oohsnbt3cr7hnlumpdhv2ibjp6iji9te4iot0 printText : Text ->{IO} Either Failure () - 817. -- #5si7baedo99eap6jgd9krvt7q4ak8s98t4ushnno8mgjp7u9li137ferm3dn11g4k3mds1m8n33sbuodrohstbm9hcqm1937tfj7iq8 + 820. -- #5si7baedo99eap6jgd9krvt7q4ak8s98t4ushnno8mgjp7u9li137ferm3dn11g4k3mds1m8n33sbuodrohstbm9hcqm1937tfj7iq8 putBytes : Handle -> Bytes ->{IO, Exception} () - 818. -- #gkd4pi7uossfe12b19s0mrr0a04v5vvhnfmq3qer3cu7jr24m5v4e1qu59mktrornbrrqgihsvkj1f29je971oqimpngiqgebkr9i58 + 821. -- #gkd4pi7uossfe12b19s0mrr0a04v5vvhnfmq3qer3cu7jr24m5v4e1qu59mktrornbrrqgihsvkj1f29je971oqimpngiqgebkr9i58 readFile : Text ->{IO, Exception} Bytes - 819. -- #ak95mrmd6jhaiikkr42qsvd5lu7au0mpveqm1e347mkr7s4f846apqhh203ei1p3pqi18dcuhuotf53l8p2ivsjs8octc1eenjdqb48 + 822. -- #ak95mrmd6jhaiikkr42qsvd5lu7au0mpveqm1e347mkr7s4f846apqhh203ei1p3pqi18dcuhuotf53l8p2ivsjs8octc1eenjdqb48 ready : Handle ->{IO, Exception} Boolean - 820. -- #gpogpcuoc1dsktoh5t50ofl6dc4vulm0fsqoeevuuoivbrin87ah166b8k8vq3s3977ha0p7np5mn198gglqkjj1gh7nbv31eb7dbqo + 823. -- #gpogpcuoc1dsktoh5t50ofl6dc4vulm0fsqoeevuuoivbrin87ah166b8k8vq3s3977ha0p7np5mn198gglqkjj1gh7nbv31eb7dbqo receive : Tls ->{IO, Exception} Bytes - 821. -- #7rctbhido3s7lm9tjb6dit94cg2jofasr6div31976q840e5va5j6tu6p0pugkt106mcjrtiqndimaknakrnssdo6ul0jef6a9nf1qo + 824. -- #7rctbhido3s7lm9tjb6dit94cg2jofasr6div31976q840e5va5j6tu6p0pugkt106mcjrtiqndimaknakrnssdo6ul0jef6a9nf1qo removeDirectory : Text ->{IO, Exception} () - 822. -- #710k006oln987ch4k1c986sb0jfqtpusp0a235te6cejhns51um6umr311ltgfiv80kt0s8sb8r0ic63gj2nvgbi66vq10s4ilkk5ng + 825. -- #710k006oln987ch4k1c986sb0jfqtpusp0a235te6cejhns51um6umr311ltgfiv80kt0s8sb8r0ic63gj2nvgbi66vq10s4ilkk5ng renameDirectory : Text -> Text ->{IO, Exception} () - 823. -- #vb50tjb967ic3mr4brs0pro9819ftcj4q48eoeal8gmk02f05isuqhn0accbi7rv07g3i4hjgntu2b2r8b9bn15mjc59v10u9c3gjdo + 826. -- #vb50tjb967ic3mr4brs0pro9819ftcj4q48eoeal8gmk02f05isuqhn0accbi7rv07g3i4hjgntu2b2r8b9bn15mjc59v10u9c3gjdo runTest : '{IO, TempDirs, Exception, Stream Result} a ->{IO} [Result] - 824. -- #ub9vp3rs8gh7kj9ksq0dbpoj22r61iq179co8tpgsj9m52n36qha52rm5hlht4hesgqfb8917cp1tk8jhgcft6sufgis6bgemmd57ag + 827. -- #ub9vp3rs8gh7kj9ksq0dbpoj22r61iq179co8tpgsj9m52n36qha52rm5hlht4hesgqfb8917cp1tk8jhgcft6sufgis6bgemmd57ag saveSelfContained : a -> Text ->{IO, Exception} () - 825. -- #6jriif58nb7gbb576kcabft4k4qaa74prd4dpsomokbqceust7p0gu0jlpar4o70qt987lkki2sj1pknkr0ggoif8fcvu2jg2uenqe8 + 828. -- #6jriif58nb7gbb576kcabft4k4qaa74prd4dpsomokbqceust7p0gu0jlpar4o70qt987lkki2sj1pknkr0ggoif8fcvu2jg2uenqe8 saveTestCase : Text -> Text -> (a -> Text) -> a ->{IO, Exception} () - 826. -- #uq87p0r1djq5clhkbimp3fc325e5kp3bv33dc8fpphotdqp95a0ps2c2ch8d2ftdpdualpq2oo9dmnka6kvnc9kvugs2538q62up4t0 + 829. -- #uq87p0r1djq5clhkbimp3fc325e5kp3bv33dc8fpphotdqp95a0ps2c2ch8d2ftdpdualpq2oo9dmnka6kvnc9kvugs2538q62up4t0 seekHandle : Handle -> SeekMode -> Int ->{IO, Exception} () - 827. -- #ftkuro0u0et9ahigdr1k38tl2sl7i0plm7cv5nciccdd71t6a64icla66ss0ufu7llfuj7cuvg3ms4ieel6penfi8gkahb9tm3sfhjo + 830. -- #ftkuro0u0et9ahigdr1k38tl2sl7i0plm7cv5nciccdd71t6a64icla66ss0ufu7llfuj7cuvg3ms4ieel6penfi8gkahb9tm3sfhjo send : Tls -> Bytes ->{IO, Exception} () - 828. -- #k6gmcn3qg50h49gealh8o7j7tp74rvhgn040kftsavd2cldqopcv9945olnooe04cqitgpvekpcbr5ccqjosg7r9gb1lagju5v9ln0o + 831. -- #k6gmcn3qg50h49gealh8o7j7tp74rvhgn040kftsavd2cldqopcv9945olnooe04cqitgpvekpcbr5ccqjosg7r9gb1lagju5v9ln0o serverSocket : Optional Text -> Text ->{IO, Exception} Socket - 829. -- #umje4ibrfv3c6vsjrdkbne1u7c8hg4ll9185m3frqr2rsr8738hp5fq12kepa28h63u9qi23stsegjp1hv0incr5djbl7ulp2s12d8g + 832. -- #umje4ibrfv3c6vsjrdkbne1u7c8hg4ll9185m3frqr2rsr8738hp5fq12kepa28h63u9qi23stsegjp1hv0incr5djbl7ulp2s12d8g setBuffering : Handle -> BufferMode ->{IO, Exception} () - 830. -- #je6s0pdkrg3mvphpg535pubchjd40mepki6ipum7498sma7pll9l89h6de65063bufihf2jb5ihepth2jahir8rs757ggfrnpp7fs7o + 833. -- #je6s0pdkrg3mvphpg535pubchjd40mepki6ipum7498sma7pll9l89h6de65063bufihf2jb5ihepth2jahir8rs757ggfrnpp7fs7o setEcho : Handle -> Boolean ->{IO, Exception} () - 831. -- #in06o7cfgnlmm6pvdtv0jv9hniahcli0fvh27o01ork1p77ro2v51rc05ts1h6p9mtffqld4ufs8klcc4bse1tsj93cu0na0bbiuqb0 + 834. -- #in06o7cfgnlmm6pvdtv0jv9hniahcli0fvh27o01ork1p77ro2v51rc05ts1h6p9mtffqld4ufs8klcc4bse1tsj93cu0na0bbiuqb0 snd : (a1, a) -> a - 832. -- #km3cpkvcnvcos0isfbnb7pb3s45ri5q42n74jmm9c4v1bcu8nlk63353u4ohfr7av4k00s4s180ddnqbam6a01thhlt2tie1hm5a9bo + 835. -- #km3cpkvcnvcos0isfbnb7pb3s45ri5q42n74jmm9c4v1bcu8nlk63353u4ohfr7av4k00s4s180ddnqbam6a01thhlt2tie1hm5a9bo socketAccept : Socket ->{IO, Exception} Socket - 833. -- #ubteu6e7h7om7o40e8mm1rcmp8uur7qn7p5d92gtp3q92rtr459nn3rff4i9q46o2o60tmh77i9vgu0pub768s9kvn9egtcds30nk88 + 836. -- #ubteu6e7h7om7o40e8mm1rcmp8uur7qn7p5d92gtp3q92rtr459nn3rff4i9q46o2o60tmh77i9vgu0pub768s9kvn9egtcds30nk88 socketPort : Socket ->{IO, Exception} Nat - 834. -- #3rp8h0dt7g60nrjdehuhqga9dmomti5rdqho7r1rm5rg5moet7kt3ieempo7c9urur752njachq6k48ggbic4ugbbv75jl2mfbk57a0 + 837. -- #3rp8h0dt7g60nrjdehuhqga9dmomti5rdqho7r1rm5rg5moet7kt3ieempo7c9urur752njachq6k48ggbic4ugbbv75jl2mfbk57a0 startsWith : Text -> Text -> Boolean - 835. -- #elsab3sc7p4c6bj73pgvklv0j7qu268rn5isv6micfp7ib8grjoustpqdq0pkd4a379mr5ijb8duu2q0n040osfurppp8pt8vaue2fo + 838. -- #elsab3sc7p4c6bj73pgvklv0j7qu268rn5isv6micfp7ib8grjoustpqdq0pkd4a379mr5ijb8duu2q0n040osfurppp8pt8vaue2fo stdout : Handle - 836. -- #rfi1v9429f9qluv533l2iba77aadttilrpmnhljfapfnfa6sru2nr8ibpqvib9nc4s4nb9s1as45upsfqfqe6ivqi2p82b2vd866it8 + 839. -- #rfi1v9429f9qluv533l2iba77aadttilrpmnhljfapfnfa6sru2nr8ibpqvib9nc4s4nb9s1as45upsfqfqe6ivqi2p82b2vd866it8 structural ability Stream a - 837. -- #s76vfp9t00khf3bvrg01h9u7gnqj5m62sere8ac97un79ojd82b71q2e0cllj002jn4r2g3qhjft40gkqotgor74v0iogkt3lfftlug + 840. -- #s76vfp9t00khf3bvrg01h9u7gnqj5m62sere8ac97un79ojd82b71q2e0cllj002jn4r2g3qhjft40gkqotgor74v0iogkt3lfftlug Stream.collect : '{e, Stream a} r ->{e} ([a], r) - 838. -- #abc5m7k74em3fk9et4lrj0ee2lsbvp8vp826josen26l1g3lh9ansb47b68efe1vhhi8f6l6kaircd5t4ihlbt0pq4nlipgde9rq8v8 + 841. -- #abc5m7k74em3fk9et4lrj0ee2lsbvp8vp826josen26l1g3lh9ansb47b68efe1vhhi8f6l6kaircd5t4ihlbt0pq4nlipgde9rq8v8 Stream.collect.handler : Request {Stream a} r -> ([a], r) - 839. -- #rfi1v9429f9qluv533l2iba77aadttilrpmnhljfapfnfa6sru2nr8ibpqvib9nc4s4nb9s1as45upsfqfqe6ivqi2p82b2vd866it8#0 + 842. -- #rfi1v9429f9qluv533l2iba77aadttilrpmnhljfapfnfa6sru2nr8ibpqvib9nc4s4nb9s1as45upsfqfqe6ivqi2p82b2vd866it8#0 Stream.emit : a ->{Stream a} () - 840. -- #mrhqdu5he7p8adejmvt4ss09apkbnu8jn66g4lpf0uas9dvm8goa6g65bo2u7s0175hrrofd6uqg7ogmduf928knfpkd12042k6o860 + 843. -- #mrhqdu5he7p8adejmvt4ss09apkbnu8jn66g4lpf0uas9dvm8goa6g65bo2u7s0175hrrofd6uqg7ogmduf928knfpkd12042k6o860 Stream.toList : '{Stream a} r -> [a] - 841. -- #t3klufmrq2bk8gg0o4lukenlmu0dkkcssq9l80m4p3dm6rqesrt51nrebfujfgco9h47f4e5nplmj7rvc3salvs65labd7nvj2fkne8 + 844. -- #t3klufmrq2bk8gg0o4lukenlmu0dkkcssq9l80m4p3dm6rqesrt51nrebfujfgco9h47f4e5nplmj7rvc3salvs65labd7nvj2fkne8 Stream.toList.handler : Request {Stream a} r -> [a] - 842. -- #pus3urtj4e1bhv5p5l16d7vnv4g2hso78pcfussnufkt3d53j7oaqde1ajvijr1g6f0cv2c4ice34g8g8n17hd7hql6hvl8sgcgu6s8 + 845. -- #pus3urtj4e1bhv5p5l16d7vnv4g2hso78pcfussnufkt3d53j7oaqde1ajvijr1g6f0cv2c4ice34g8g8n17hd7hql6hvl8sgcgu6s8 systemTime : '{IO, Exception} Nat - 843. -- #11mhfqj6rts8lm3im7saf44tn3km5bboqtu1td0udnaiit4qqg6ar1ecmccosl6gufsnp6sug3vcmgapsc58sgj7dh7rg8msq2qkj18 + 846. -- #11mhfqj6rts8lm3im7saf44tn3km5bboqtu1td0udnaiit4qqg6ar1ecmccosl6gufsnp6sug3vcmgapsc58sgj7dh7rg8msq2qkj18 structural ability TempDirs - 844. -- #11mhfqj6rts8lm3im7saf44tn3km5bboqtu1td0udnaiit4qqg6ar1ecmccosl6gufsnp6sug3vcmgapsc58sgj7dh7rg8msq2qkj18#0 + 847. -- #11mhfqj6rts8lm3im7saf44tn3km5bboqtu1td0udnaiit4qqg6ar1ecmccosl6gufsnp6sug3vcmgapsc58sgj7dh7rg8msq2qkj18#0 TempDirs.newTempDir : Text ->{TempDirs} Text - 845. -- #11mhfqj6rts8lm3im7saf44tn3km5bboqtu1td0udnaiit4qqg6ar1ecmccosl6gufsnp6sug3vcmgapsc58sgj7dh7rg8msq2qkj18#1 + 848. -- #11mhfqj6rts8lm3im7saf44tn3km5bboqtu1td0udnaiit4qqg6ar1ecmccosl6gufsnp6sug3vcmgapsc58sgj7dh7rg8msq2qkj18#1 TempDirs.removeDir : Text ->{TempDirs} () - 846. -- #ibj0sc16l6bd7r6ptft93jeocitrjod98g210beogdk30t3tb127fbe33vau29j0j4gt8mbs2asfs5rslgk0fl3o4did2t9oa8o5kf8 + 849. -- #ibj0sc16l6bd7r6ptft93jeocitrjod98g210beogdk30t3tb127fbe33vau29j0j4gt8mbs2asfs5rslgk0fl3o4did2t9oa8o5kf8 terminate : Tls ->{IO, Exception} () - 847. -- #iis8ph5ljlq8ijd9jsdlsga91fh1354fii7955l4v52mnvn71cd76maculs0eathrmtfjqh0knbc600kmvq6abj4k2ntnbh5ee10m2o + 850. -- #iis8ph5ljlq8ijd9jsdlsga91fh1354fii7955l4v52mnvn71cd76maculs0eathrmtfjqh0knbc600kmvq6abj4k2ntnbh5ee10m2o testAutoClean : '{IO} [Result] - 848. -- #k1prgid1t9d4fu6f60rct978khcuinkpq49ps95aqaimt2tfoa77fc0c8i3pmc8toeth1s98al3nosaa1mhbh2j2k2nvqivm0ks963o + 851. -- #k1prgid1t9d4fu6f60rct978khcuinkpq49ps95aqaimt2tfoa77fc0c8i3pmc8toeth1s98al3nosaa1mhbh2j2k2nvqivm0ks963o Text.fromUtf8 : Bytes ->{Exception} Text - 849. -- #32q9jqhmi8f08pec3hj0je4u7k52f9f1hdfsmn9ncg2kpki5da9dabigplvdcot3a00k7s5npc4n78psd6ojaumqjla259e9pqd4ov8 + 852. -- #32q9jqhmi8f08pec3hj0je4u7k52f9f1hdfsmn9ncg2kpki5da9dabigplvdcot3a00k7s5npc4n78psd6ojaumqjla259e9pqd4ov8 structural ability Throw e - 850. -- #32q9jqhmi8f08pec3hj0je4u7k52f9f1hdfsmn9ncg2kpki5da9dabigplvdcot3a00k7s5npc4n78psd6ojaumqjla259e9pqd4ov8#0 + 853. -- #32q9jqhmi8f08pec3hj0je4u7k52f9f1hdfsmn9ncg2kpki5da9dabigplvdcot3a00k7s5npc4n78psd6ojaumqjla259e9pqd4ov8#0 Throw.throw : e ->{Throw e} a - 851. -- #f6pkvs6ukf8ngh2j8lm935p1bqadso76o7e3t0j1ukupjh1rg0m1rhtp7u492sq17p3bkbintbnjehc1cqs33qlhnfkoihf5uee4ug0 + 854. -- #f6pkvs6ukf8ngh2j8lm935p1bqadso76o7e3t0j1ukupjh1rg0m1rhtp7u492sq17p3bkbintbnjehc1cqs33qlhnfkoihf5uee4ug0 uncurry : (i1 ->{g1} i ->{g} o) -> (i1, i) ->{g1, g} o - 852. -- #u1o44hd0cdlfa8racf458sahdmgea409k8baajgc5k7bqukf2ak5ggs2ped0u3h85v99pgefgb9r7ct2dv4nn9eihjghnqf30p4l57g + 855. -- #u1o44hd0cdlfa8racf458sahdmgea409k8baajgc5k7bqukf2ak5ggs2ped0u3h85v99pgefgb9r7ct2dv4nn9eihjghnqf30p4l57g Value.transitiveDeps : Value ->{IO} [(Link.Term, Code)] - 853. -- #o5bg5el7ckak28ib98j5b6rt26bqbprpddd1brrg3s18qahhbbe3uohufjjnt5eenvtjg0hrvnvpra95jmdppqrovvmcfm1ih2k7guo + 856. -- #o5bg5el7ckak28ib98j5b6rt26bqbprpddd1brrg3s18qahhbbe3uohufjjnt5eenvtjg0hrvnvpra95jmdppqrovvmcfm1ih2k7guo void : x -> () - 854. -- #b4pssu6mf30r4irqj43vvgbc6geq8pp7eg4o2erl948qp3nskp6io5damjj54o2eq9q76mrhsijr1q1d0bna4soed3oggddfvdajaj8 + 857. -- #b4pssu6mf30r4irqj43vvgbc6geq8pp7eg4o2erl948qp3nskp6io5damjj54o2eq9q76mrhsijr1q1d0bna4soed3oggddfvdajaj8 writeFile : Text -> Bytes ->{IO, Exception} () - 855. -- #lcmj2envm11lrflvvcl290lplhvbccv82utoej0lg0eomhmsf2vrv8af17k6if7ff98fp1b13rkseng3fng4stlr495c8dn3gn4k400 + 858. -- #lcmj2envm11lrflvvcl290lplhvbccv82utoej0lg0eomhmsf2vrv8af17k6if7ff98fp1b13rkseng3fng4stlr495c8dn3gn4k400 |> : a -> (a ->{g} t) ->{g} t ``` diff --git a/unison-src/transcripts-using-base/base.u b/unison-src/transcripts-using-base/base.u index b1023f558a..f525dae034 100644 --- a/unison-src/transcripts-using-base/base.u +++ b/unison-src/transcripts-using-base/base.u @@ -1,4 +1,3 @@ - a |> f = f a f <| a = f a @@ -97,6 +96,10 @@ List.forEach l f = [] -> () go l +List.head = cases + [] -> None + a +: _ -> Some a + List.zip : [a] -> [b] -> [(a,b)] List.zip = cases [], _ -> [] @@ -118,6 +121,10 @@ List.reverse = x +: xs -> loop (x +: acc) xs loop [] +Optional.getOrBug msg = cases + None -> bug msg + Some a -> a + first : (a -> b) -> (a,c) -> (b,c) first f = cases (x,y) -> (f x, y) @@ -215,6 +222,9 @@ autoCleaned.handler _ = autoCleaned: '{io2.IO, TempDirs} r -> r autoCleaned comp = handle !comp with !autoCleaned.handler +getArgs : '{IO, Exception} [Text] +getArgs _ = Exception.reraise getArgs.impl() + stdout = IO.stdHandle StdOut printText : Text -> {io2.IO} Either Failure () printText t = putBytes.impl stdout (toUtf8 t) diff --git a/unison-src/transcripts-using-base/fix-2805.md b/unison-src/transcripts-using-base/fix-2805.md new file mode 100644 index 0000000000..8cbe4d580c --- /dev/null +++ b/unison-src/transcripts-using-base/fix-2805.md @@ -0,0 +1,20 @@ +When running a main function in `ucm` a numeric argument is replaced by the potential last result of a find command: + +``` unison +main : '{IO, Exception} () +main _ = + printLine ("Hello " ++ Optional.getOrBug "definitely passed an arg" (List.head !getArgs) ++ "!") +``` + +First we run it with no numbered results in the history, so if number expansion is applied, it should end up calling `main` with zero args, whereas without number expansion, we get a single argument, “1”, passed to it. + +``` ucm :bug +scratch/main> run main 1 +``` + +Now we set it up so there _are_ numbered results in the history. If number expansion is applied here, we will get an error “`run` can’t accept a numbered argument […]”, and otherwise our expected "1". + +``` ucm :bug +scratch/main> find.all isLeft +scratch/main> run main 1 +``` diff --git a/unison-src/transcripts-using-base/fix-2805.output.md b/unison-src/transcripts-using-base/fix-2805.output.md new file mode 100644 index 0000000000..48b8e2c51d --- /dev/null +++ b/unison-src/transcripts-using-base/fix-2805.output.md @@ -0,0 +1,57 @@ +When running a main function in `ucm` a numeric argument is replaced by the potential last result of a find command: + +``` unison +main : '{IO, Exception} () +main _ = + printLine ("Hello " ++ Optional.getOrBug "definitely passed an arg" (List.head !getArgs) ++ "!") +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + main : '{IO, Exception} () +``` + +First we run it with no numbered results in the history, so if number expansion is applied, it should end up calling `main` with zero args, whereas without number expansion, we get a single argument, “1”, passed to it. + +``` ucm :bug +scratch/main> run main 1 + + 💔💥 + + I've encountered a call to builtin.bug with the following + value: + + "definitely passed an arg" + + Stack trace: + bug + main + #ra2ebfober +``` + +Now we set it up so there *are* numbered results in the history. If number expansion is applied here, we will get an error “`run` can’t accept a numbered argument \[…\]”, and otherwise our expected "1". + +``` ucm :bug +scratch/main> find.all isLeft + + 1. Either.isLeft : Either a b -> Boolean + +scratch/main> run main 1 + + ⚠️ + + Sorry, I wasn’t sure how to process your request: + + `run` can’t accept a numbered argument for a command-line + argument and it’s not yet possible to provide un-expanded + numbers as arguments. + + You can run `help run` for more information on using `run`. +``` From 6f8fb414ada091eb72e654efe93d1dbdf096b06e Mon Sep 17 00:00:00 2001 From: Greg Pfeil Date: Mon, 2 Dec 2024 18:09:55 -0700 Subject: [PATCH 2/5] Make UCM command arg checking stricter MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - distinguish between “parameters” and “arguments” – a command has a fixed number of parameters, each of which maps to some number of arguments (from 0 to many, depending on the parameter) - change the type of parameters to eliminate invalid parameter structures - require `InputPattern` parameters to cover all arguments (there are a number of commands whose parameters were under-specified). --- .../src/Unison/Codebase/Editor/HandleInput.hs | 37 +- .../src/Unison/Codebase/Editor/Output.hs | 4 + unison-cli/src/Unison/CommandLine.hs | 131 ++-- .../src/Unison/CommandLine/Completion.hs | 4 +- .../src/Unison/CommandLine/InputPattern.hs | 179 ++--- .../src/Unison/CommandLine/InputPatterns.hs | 646 +++++++++--------- .../src/Unison/CommandLine/OutputMessages.hs | 2 + 7 files changed, 543 insertions(+), 460 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 4967878424..ab26e91d5c 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -714,18 +714,31 @@ loop e = do DebugFuzzyOptionsI command args -> do Cli.Env {codebase} <- ask currentBranch <- Branch.withoutTransitiveLibs <$> Cli.getCurrentBranch0 - case Map.lookup command InputPatterns.patternMap of - Just (IP.InputPattern {args = argTypes}) -> do - zip argTypes args & Monoid.foldMapM \case - ((argName, _, IP.ArgumentType {fzfResolver = Just IP.FZFResolver {getOptions}}), "_") -> do - pp <- Cli.getCurrentProjectPath - results <- liftIO $ getOptions codebase pp currentBranch - Cli.respond (DebugDisplayFuzzyOptions argName (Text.unpack <$> results)) - ((_, _, IP.ArgumentType {fzfResolver = Nothing}), "_") -> do - Cli.respond DebugFuzzyOptionsNoResolver - _ -> pure () - Nothing -> do - Cli.respond DebugFuzzyOptionsNoResolver + maybe + (Cli.respond $ DebugFuzzyOptionsNoCommand command) + ( \IP.InputPattern {params} -> + either (Cli.respond . DebugFuzzyOptionsIncorrectArgs) snd $ + IP.foldArgs + ( \(paramName, IP.ParameterType {fzfResolver}) arg -> + ( *> + if arg == "_" + then + maybe + (Cli.respond DebugFuzzyOptionsNoResolver) + ( \IP.FZFResolver {getOptions} -> do + pp <- Cli.getCurrentProjectPath + results <- liftIO $ getOptions codebase pp currentBranch + Cli.respond (DebugDisplayFuzzyOptions paramName (Text.unpack <$> results)) + ) + fzfResolver + else pure () + ) + ) + (pure ()) + params + args + ) + $ Map.lookup command InputPatterns.patternMap DebugFormatI -> do env <- ask void $ runMaybeT do diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 7ebf9ad299..fd6291553f 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -354,6 +354,8 @@ data Output | DisplayDebugCompletions [Completion.Completion] | DisplayDebugLSPNameCompletions [(Text, Name, LabeledDependency)] | DebugDisplayFuzzyOptions Text [String {- arg description, options -}] + | DebugFuzzyOptionsIncorrectArgs (NonEmpty String) + | DebugFuzzyOptionsNoCommand String | DebugFuzzyOptionsNoResolver | DebugTerm (Bool {- verbose mode -}) (Either (Text {- A builtin hash -}) (Term Symbol Ann)) | DebugDecl (Either (Text {- A builtin hash -}) (DD.Decl Symbol Ann)) (Maybe ConstructorId {- If 'Just' we're debugging a constructor of the given decl -}) @@ -611,6 +613,8 @@ isFailure o = case o of DisplayDebugCompletions {} -> False DisplayDebugLSPNameCompletions {} -> False DebugDisplayFuzzyOptions {} -> False + DebugFuzzyOptionsIncorrectArgs {} -> True + DebugFuzzyOptionsNoCommand {} -> True DebugFuzzyOptionsNoResolver {} -> True DebugTerm {} -> False DebugDecl {} -> False diff --git a/unison-cli/src/Unison/CommandLine.hs b/unison-cli/src/Unison/CommandLine.hs index 99ac5799d9..1b1cc2df7a 100644 --- a/unison-cli/src/Unison/CommandLine.hs +++ b/unison-cli/src/Unison/CommandLine.hs @@ -15,13 +15,14 @@ import Control.Lens hiding (aside) import Control.Monad.Except import Control.Monad.Trans.Except import Data.List (isPrefixOf, isSuffixOf) +import Data.List.NonEmpty (NonEmpty) import Data.Map qualified as Map -import Data.Semialign qualified as Align import Data.Text qualified as Text import Data.Text.IO qualified as Text -import Data.These (These (..)) import Data.Vector qualified as Vector import System.FilePath (takeFileName) +import Text.Numeral (defaultInflection) +import Text.Numeral.Language.ENG qualified as Numeral import Text.Regex.TDFA ((=~)) import Unison.Codebase (Codebase) import Unison.Codebase.Branch (Branch0) @@ -83,35 +84,45 @@ parseInput codebase projPath currentProjectRoot numberedArgs patterns segments = case segments of [] -> throwE "" command : args -> case Map.lookup command patterns of - Just pat@(InputPattern {parse, help}) -> do + Just pat@(InputPattern {params, help, parse}) -> do let expandedNumbers :: InputPattern.Arguments expandedNumbers = foldMap (\arg -> maybe [Left arg] (fmap pure) $ expandNumber numberedArgs arg) args - lift (fzfResolve codebase projPath getCurrentBranch0 pat expandedNumbers) >>= \case - Left (NoFZFResolverForArgumentType _argDesc) -> throwError help - Left (NoFZFOptions argDesc) -> throwError (noCompletionsMessage argDesc) - Left FZFCancelled -> pure Nothing - Right resolvedArgs -> do - parsedInput <- - except - . first - ( \msg -> - P.warnCallout $ - P.wrap "Sorry, I wasn’t sure how to process your request:" - <> P.newline - <> P.newline - <> P.indentN 2 msg - <> P.newline - <> P.newline - <> P.wrap - ( "You can run" - <> IPs.makeExample IPs.help [fromString command] - <> "for more information on using" - <> IPs.makeExampleEOS pat [] - ) - ) - $ parse resolvedArgs - pure $ Just (Left command : resolvedArgs, parsedInput) + lift (fzfResolve codebase projPath getCurrentBranch0 params expandedNumbers) + >>= either + ( \case + NoFZFResolverForArgumentType _argDesc -> throwError help + NoFZFOptions argDesc -> throwError (noCompletionsMessage argDesc) + FZFCancelled -> pure Nothing + FZFOversaturated extraArgs -> do + let showNum n = fromMaybe (tShow n) $ Numeral.us_cardinal defaultInflection n + maxCount <- maybe (throwError . P.text $ "Internal error: fuzzy finder complained that there are " <> showNum (length extraArgs) <> " too many arguments provided, but the command apparently allows an unbounded number of arguments.") pure $ InputPattern.maxArgs params + let foundCount = showNum $ maxCount + length extraArgs + throwError . P.text $ + "I expected no more than " <> showNum maxCount <> " arguments, but received " <> foundCount <> "." + ) + ( \resolvedArgs -> do + parsedInput <- + except + . first + ( \msg -> + P.warnCallout $ + P.wrap "Sorry, I wasn’t sure how to process your request:" + <> P.newline + <> P.newline + <> P.indentN 2 msg + <> P.newline + <> P.newline + <> P.wrap + ( "You can run" + <> IPs.makeExample IPs.help [fromString command] + <> "for more information on using" + <> IPs.makeExampleEOS pat [] + ) + ) + $ parse resolvedArgs + pure $ Just (Left command : resolvedArgs, parsedInput) + ) Nothing -> throwE . warn @@ -151,37 +162,56 @@ expandNumber numberedArgs s = _ -> Nothing data FZFResolveFailure - = NoFZFResolverForArgumentType InputPattern.ArgumentDescription - | NoFZFOptions Text {- argument description -} + = NoFZFResolverForArgumentType InputPattern.ParameterDescription + | NoFZFOptions + -- | argument description + Text | FZFCancelled + | -- | More arguments were provided than the command supports. + FZFOversaturated + -- | The arguments that couldn’t be assigned to a parameter. + (NonEmpty InputPattern.Argument) -fzfResolve :: Codebase IO Symbol Ann -> PP.ProjectPath -> (IO (Branch0 IO)) -> InputPattern -> InputPattern.Arguments -> IO (Either FZFResolveFailure InputPattern.Arguments) -fzfResolve codebase ppCtx getCurrentBranch pat args = runExceptT do +fzfResolve :: + Codebase IO Symbol Ann -> + PP.ProjectPath -> + (IO (Branch0 IO)) -> + InputPattern.Parameters -> + InputPattern.Arguments -> + IO (Either FZFResolveFailure InputPattern.Arguments) +fzfResolve codebase ppCtx getCurrentBranch params args = runExceptT do -- We resolve args in two steps, first we check that all arguments that will require a fzf -- resolver have one, and only if so do we prompt the user to actually do a fuzzy search. -- Otherwise, we might ask the user to perform a search only to realize we don't have a resolver -- for a later arg. - argumentResolvers :: [ExceptT FZFResolveFailure IO InputPattern.Arguments] <- - (Align.align (InputPattern.args pat) args) - & traverse \case - This (argName, opt, InputPattern.ArgumentType {fzfResolver}) - | opt == InputPattern.Required || opt == InputPattern.OnePlus -> - case fzfResolver of - Nothing -> throwError $ NoFZFResolverForArgumentType argName - Just fzfResolver -> pure $ fuzzyFillArg opt argName fzfResolver - | otherwise -> pure $ pure [] - That arg -> pure $ pure [arg] - These _ arg -> pure $ pure [arg] + let argumentResolvers :: [ExceptT FZFResolveFailure IO InputPattern.Arguments] = + either + (pure . throwError . FZFOversaturated) + ( \(InputPattern.Parameters {requiredParams, trailingParams}, args) -> + args + <> map (meh False) requiredParams + <> case trailingParams of + InputPattern.Optional _ _ -> mempty + InputPattern.OnePlus p -> pure $ meh True p + ) + $ InputPattern.foldArgs (\(_, _) arg acc -> pure [arg] : acc) mempty params args argumentResolvers & foldMapM id where - fuzzyFillArg :: InputPattern.IsOptional -> Text -> InputPattern.FZFResolver -> ExceptT FZFResolveFailure IO InputPattern.Arguments - fuzzyFillArg opt argDesc InputPattern.FZFResolver {getOptions} = do + meh :: Bool -> InputPattern.Parameter -> ExceptT FZFResolveFailure IO InputPattern.Arguments + meh allowMulti (argName, InputPattern.ParameterType {fzfResolver}) = + maybe + (throwError $ NoFZFResolverForArgumentType argName) + (fuzzyFillArg allowMulti argName) + fzfResolver + + fuzzyFillArg :: Bool -> Text -> InputPattern.FZFResolver -> ExceptT FZFResolveFailure IO InputPattern.Arguments + fuzzyFillArg allowMulti argDesc InputPattern.FZFResolver {getOptions} = do currentBranch <- Branch.withoutTransitiveLibs <$> liftIO getCurrentBranch options <- liftIO $ getOptions codebase ppCtx currentBranch - when (null options) $ throwError $ NoFZFOptions argDesc + when (null options) . throwError $ NoFZFOptions argDesc liftIO $ Text.putStrLn (FZFResolvers.fuzzySelectHeader argDesc) results <- - liftIO (Fuzzy.fuzzySelect Fuzzy.defaultOptions {Fuzzy.allowMultiSelect = multiSelectForOptional opt} id options) + liftIO (Fuzzy.fuzzySelect Fuzzy.defaultOptions {Fuzzy.allowMultiSelect = allowMulti} id options) `whenNothingM` throwError FZFCancelled -- If the user triggered the fuzzy finder, but selected nothing, abort the command rather than continuing execution -- with no arguments. @@ -189,12 +219,5 @@ fzfResolve codebase ppCtx getCurrentBranch pat args = runExceptT do then throwError FZFCancelled else pure (Left . Text.unpack <$> results) - multiSelectForOptional :: InputPattern.IsOptional -> Bool - multiSelectForOptional = \case - InputPattern.Required -> False - InputPattern.Optional -> False - InputPattern.OnePlus -> True - InputPattern.ZeroPlus -> True - prompt :: String prompt = "> " diff --git a/unison-cli/src/Unison/CommandLine/Completion.hs b/unison-cli/src/Unison/CommandLine/Completion.hs index 10a838373e..c3920b6ed4 100644 --- a/unison-cli/src/Unison/CommandLine/Completion.hs +++ b/unison-cli/src/Unison/CommandLine/Completion.hs @@ -83,8 +83,8 @@ haskelineTabComplete patterns codebase authedHTTPClient ppCtx = Line.completeWor case words $ reverse prev of h : t -> fromMaybe (pure []) $ do p <- Map.lookup h patterns - argType <- IP.argType p (length t) - pure $ IP.suggestions argType word codebase authedHTTPClient ppCtx + paramType <- IP.paramType (IP.params p) (length t) + pure $ IP.suggestions paramType word codebase authedHTTPClient ppCtx _ -> pure [] -- | Things which we may want to complete for. diff --git a/unison-cli/src/Unison/CommandLine/InputPattern.hs b/unison-cli/src/Unison/CommandLine/InputPattern.hs index cc628559e6..772a729b9f 100644 --- a/unison-cli/src/Unison/CommandLine/InputPattern.hs +++ b/unison-cli/src/Unison/CommandLine/InputPattern.hs @@ -4,13 +4,17 @@ module Unison.CommandLine.InputPattern ( InputPattern (..), + ParameterDescription, + ParameterType (..), + Parameter, + TrailingParameters (..), + Parameters (..), Argument, - ArgumentType (..), - ArgumentDescription, Arguments, - argType, + foldArgs, + noParams, + paramType, FZFResolver (..), - IsOptional (..), Visibility (..), -- * Currently Unused @@ -23,6 +27,7 @@ where import Control.Lens import Data.List.Extra qualified as List +import Data.List.NonEmpty (NonEmpty (..)) import System.Console.Haskeline qualified as Line import Unison.Auth.HTTPClient (AuthenticatedHttpClient) import Unison.Codebase (Codebase) @@ -35,15 +40,6 @@ import Unison.Util.ColorText qualified as CT import Unison.Util.Monoid (foldMapM) import Unison.Util.Pretty qualified as P --- InputPatterns accept some fixed number of Required arguments of various --- types, followed by a variable number of a single type of argument. -data IsOptional - = Required -- 1, at the start - | Optional -- 0 or 1, at the end - | ZeroPlus -- 0 or more, at the end - | OnePlus -- 1 or more, at the end - deriving (Show, Eq) - data Visibility = Hidden | Visible deriving (Show, Eq, Ord) @@ -55,32 +51,34 @@ type Argument = Either String StructuredArgument type Arguments = [Argument] --- | Argument description --- It should fit grammatically into sentences like "I was expecting an argument for the " --- e.g. "namespace to merge", "definition to delete", "remote target to push to" etc. -type ArgumentDescription = Text +-- | This should fit grammatically into sentences like “I was expecting an argument for the ”. +-- E.g. “namespace to merge”, “definition to delete”, “remote target to push to” etc. +type ParameterDescription = Text data InputPattern = InputPattern { patternName :: String, aliases :: [String], - visibility :: Visibility, -- Allow hiding certain commands when debugging or work-in-progress - args :: [(ArgumentDescription, IsOptional, ArgumentType)], + -- | Allow hiding certain commands when debugging or work-in-progress + visibility :: Visibility, + params :: Parameters, help :: P.Pretty CT.ColorText, -- | Parse the arguments and return either an error message or a command `Input`. -- + -- The input list is always a valid length for the pattern. It may be necessary to have a catch-all case for + -- coverage, but the implementation can assume that, say, a `OnePlus` parameter will always be provided at least + -- one argument. + -- -- __NB__: This function should return `Left` only on failure. For commands (like `help`) that simply produce -- formatted output, use `pure . Input.CreateMessage`. The failure output should be fully formatted (using - -- `wrap`, etc.), but shouldn’t include any general error components like a warninng flag or the full help + -- `wrap`, etc.), but shouldn’t include any general error components like a warning flag or the full help -- message, and shouldn’t plan for the context it is being output to (e.g., don’t `P.indentN` the entire -- message). - parse :: - Arguments -> - Either (P.Pretty CT.ColorText) Input + parse :: Arguments -> Either (P.Pretty CT.ColorText) Input } -data ArgumentType = ArgumentType +data ParameterType = ParameterType { typeName :: String, - -- | Generate completion suggestions for this argument type + -- | Generate completion suggestions for this parameter type suggestions :: forall m v a. (MonadIO m) => @@ -89,75 +87,82 @@ data ArgumentType = ArgumentType AuthenticatedHttpClient -> PP.ProjectPath -> m [Line.Completion], - -- | If an argument is marked as required, but not provided, the fuzzy finder will be triggered if + -- | If a parameter is marked as required, but no argument is provided, the fuzzy finder will be triggered if -- available. fzfResolver :: Maybe FZFResolver } -instance Show ArgumentType where - show at = "ArgumentType " <> typeName at - --- `argType` gets called when the user tries to autocomplete an `i`th argument (zero-indexed). --- todo: would be nice if we could alert the user if they try to autocomplete --- past the end. It would also be nice if -argInfo :: InputPattern -> Int -> Maybe (ArgumentDescription, ArgumentType) -argInfo InputPattern {args, patternName} i = go (i, args) +type Parameter = (ParameterDescription, ParameterType) + +data TrailingParameters + = -- | Optional args followed by a possibly-empty catch-all + Optional [Parameter] (Maybe Parameter) + | -- | A catch-all that requires at least one value + OnePlus Parameter + +-- | The `Parameters` for an `InputPattern` are roughly +-- +-- > [required …] ([optional …] [catchAll] | NonEmpty catchAll) +data Parameters = Parameters {requiredParams :: [Parameter], trailingParams :: TrailingParameters} + +-- | This is the parameter structure for a pattern that doesn’t accept any arguments. +noParams :: Parameters +noParams = Parameters [] $ Optional [] Nothing + +-- | Aligns the pattern parameters with a set of concrete arguments. +-- +-- If too many arguments are provided, it returns the overflow arguments. In addition to the fold result, it returns +-- `Parameters` representing what can still be provided (e.g., via fuzzy completion). Note that if the result +-- `Parameters` has `OnePlus` or non-`null` `requiredArgs`, the application must fail unless more arguments are +-- provided somehow. +foldArgs :: (Parameter -> arg -> a -> a) -> a -> Parameters -> [arg] -> Either (NonEmpty arg) (Parameters, a) +foldArgs fn z Parameters {requiredParams, trailingParams} = foldRequiredArgs requiredParams where - -- Strategy: all of these input patterns take some number of arguments. - -- If it takes no arguments, then don't autocomplete. - go :: (Int, [(Text, IsOptional, ArgumentType)]) -> Maybe (ArgumentDescription, ArgumentType) - go (_, []) = Nothing - -- If requesting the 0th of >=1 arguments, return it. - go (0, (argName, _, t) : _) = Just (argName, t) - -- Vararg parameters should appear at the end of the arg list, and work for - -- any later argument number. - go (_, [(argName, ZeroPlus, t)]) = Just (argName, t) - go (_, [(argName, OnePlus, t)]) = Just (argName, t) - -- If requesting a later parameter, decrement and drop one. - go (n, (_argName, o, _) : argTypes) - | o == Optional || o == Required = go (n - 1, argTypes) - -- The argument list spec is invalid if something follows a vararg - go args = - error $ - "Input pattern " - <> show patternName - <> " has an invalid argument list: " - <> show args - --- `argType` gets called when the user tries to autocomplete an `i`th argument (zero-indexed). + foldRequiredArgs = curry \case + ([], as) -> foldTrailingArgs as + (ps, []) -> pure (Parameters ps trailingParams, z) + (p : ps, a : as) -> fmap (fn p a) <$> foldRequiredArgs ps as + foldTrailingArgs = case trailingParams of + Optional optParams zeroPlus -> foldOptionalArgs zeroPlus optParams + OnePlus param -> foldOnePlusArgs param + foldOptionalArgs zp = curry \case + (ps, []) -> pure (Parameters [] $ Optional ps zp, z) + ([], a : as) -> foldZeroPlusArgs zp $ a :| as + (p : ps, a : as) -> fmap (fn p a) <$> foldOptionalArgs zp ps as + foldZeroPlusArgs = maybe Left (\p -> pure . (Parameters [] . Optional [] $ pure p,) . foldr (fn p) z) + foldOnePlusArgs p = \case + [] -> pure (Parameters [] $ OnePlus p, z) + args -> pure (Parameters [] . Optional [] $ pure p, foldr (fn p) z args) + +paramInfo :: Parameters -> Int -> Maybe (ParameterDescription, ParameterType) +paramInfo Parameters {requiredParams, trailingParams} i = + if i < length requiredParams + then pure $ requiredParams !! i + else case trailingParams of + Optional optParams zeroPlus -> + let rem = i - length requiredParams + in if rem < length optParams + then pure $ optParams !! rem + else zeroPlus + OnePlus arg -> pure arg + +-- | `argType` gets called when the user tries to autocomplete an `i`th argument (zero-indexed). -- todo: would be nice if we could alert the user if they try to autocomplete -- past the end. It would also be nice if -argType :: InputPattern -> Int -> Maybe ArgumentType -argType ip i = snd <$> (argInfo ip i) - -minArgs :: InputPattern -> Int -minArgs (InputPattern {args, patternName}) = - go (args ^.. folded . _2) - where - go [] = 0 - go (Required : argTypes) = 1 + go argTypes - go [_] = 0 - go _ = - error $ - "Invalid args for InputPattern (" - <> show patternName - <> "): " - <> show args - -maxArgs :: InputPattern -> Maybe Int -maxArgs (InputPattern {args, patternName}) = go argTypes - where - argTypes = args ^.. folded . _2 - go [] = Just 0 - go (Required : argTypes) = (1 +) <$> go argTypes - go [Optional] = Just 0 - go [_] = Nothing - go _ = - error $ - "Invalid args for InputPattern (" - <> show patternName - <> "): " - <> show argTypes +paramType :: Parameters -> Int -> Maybe ParameterType +paramType p = fmap snd . paramInfo p + +minArgs :: Parameters -> Int +minArgs Parameters {requiredParams, trailingParams} = + length requiredParams + case trailingParams of + Optional _ _ -> 0 + OnePlus _ -> 1 + +maxArgs :: Parameters -> Maybe Int +maxArgs Parameters {requiredParams, trailingParams} = + case trailingParams of + Optional optParams Nothing -> pure $ length requiredParams + length optParams + _ -> Nothing -- | Union suggestions from all possible completions unionSuggestions :: diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 87597a8653..b5904cf4a3 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -202,7 +202,14 @@ import Unison.CommandLine.BranchRelativePath qualified as BranchRelativePath import Unison.CommandLine.Completion import Unison.CommandLine.FZFResolvers qualified as Resolvers import Unison.CommandLine.Helpers (aside, backtick, tip) -import Unison.CommandLine.InputPattern (ArgumentType (..), InputPattern (InputPattern), IsOptional (..), unionSuggestions) +import Unison.CommandLine.InputPattern + ( InputPattern (InputPattern), + ParameterType (..), + Parameters (..), + TrailingParameters (..), + noParams, + unionSuggestions, + ) import Unison.CommandLine.InputPattern qualified as I import Unison.Core.Project (ProjectBranchName (..)) import Unison.HashQualified qualified as HQ @@ -744,7 +751,7 @@ mergeBuiltins = "builtins.merge" [] I.Hidden - [("namespace", Optional, namespaceArg)] + (Parameters [] $ Optional [("namespace", namespaceArg)] Nothing) "Adds the builtins (excluding `io` and misc) to the specified namespace. Defaults to `builtin.`" \case [] -> pure . Input.MergeBuiltinsI $ Nothing @@ -757,7 +764,7 @@ mergeIOBuiltins = "builtins.mergeio" [] I.Hidden - [("namespace", Optional, namespaceArg)] + (Parameters [] $ Optional [("namespace", namespaceArg)] Nothing) "Adds all the builtins, including `io` and misc., to the specified namespace. Defaults to `builtin.`" \case [] -> pure . Input.MergeIOBuiltinsI $ Nothing @@ -770,11 +777,12 @@ updateBuiltins = "builtins.update" [] I.Hidden - [] + noParams ( "Adds all the builtins that are missing from this namespace, " <> "and deprecate the ones that don't exist in this version of Unison." ) - (const . pure $ Input.UpdateBuiltinsI) + . const + $ pure Input.UpdateBuiltinsI todo :: InputPattern todo = @@ -782,15 +790,14 @@ todo = "todo" [] I.Visible - [] + noParams ( P.wrap $ makeExample' todo <> "lists the current namespace's outstanding issues, including conflicted names, dependencies with missing" <> "names, and merge precondition violations." ) - \case - [] -> Right Input.TodoI - args -> wrongArgsLength "no arguments" args + . const + $ pure Input.TodoI load :: InputPattern load = @@ -798,7 +805,7 @@ load = "load" [] I.Visible - [("scratch file", Optional, filePathArg)] + (Parameters [] $ Optional [("scratch file", filePathArg)] Nothing) ( P.wrapColumn2 [ ( makeExample' load, "parses, typechecks, and evaluates the most recent scratch file." @@ -819,16 +826,15 @@ clear = "clear" [] I.Visible - [] + noParams ( P.wrapColumn2 [ ( makeExample' clear, "Clears the screen." ) ] ) - \case - [] -> pure Input.ClearI - args -> wrongArgsLength "no arguments" args + . const + $ pure Input.ClearI add :: InputPattern add = @@ -836,7 +842,7 @@ add = "add" [] I.Visible - [("definition", ZeroPlus, noCompletionsArg)] + (Parameters [] . Optional [] $ Just ("definition", noCompletionsArg)) ( "`add` adds to the codebase all the definitions from the most recently " <> "typechecked file." ) @@ -848,7 +854,7 @@ previewAdd = "add.preview" [] I.Visible - [("definition", ZeroPlus, noCompletionsArg)] + (Parameters [] . Optional [] $ Just ("definition", noCompletionsArg)) ( "`add.preview` previews additions to the codebase from the most recently " <> "typechecked file. This command only displays cached typechecking " <> "results. Use `load` to reparse & typecheck the file if the context " @@ -862,16 +868,14 @@ update = { patternName = "update", aliases = [], visibility = I.Visible, - args = [], + params = noParams, help = P.wrap $ "Adds everything in the most recently typechecked file to the namespace," <> "replacing existing definitions having the same name, and attempts to update all the existing dependents accordingly. If the process" <> "can't be completed automatically, the dependents will be added back to the scratch file" <> "for your review.", - parse = \case - [] -> pure Input.Update2I - args -> wrongArgsLength "no arguments" args + parse = const $ pure Input.Update2I } updateOldNoPatch :: InputPattern @@ -880,7 +884,7 @@ updateOldNoPatch = "update.old.nopatch" [] I.Visible - [("definition", ZeroPlus, noCompletionsArg)] + (Parameters [] . Optional [] $ Just ("definition", noCompletionsArg)) ( P.wrap ( makeExample' updateOldNoPatch <> "works like" @@ -908,7 +912,7 @@ updateOld = "update.old" [] I.Visible - [("patch", Optional, patchArg), ("definition", ZeroPlus, noCompletionsArg)] + (Parameters [] . Optional [("patch", patchArg)] $ Just ("definition", noCompletionsArg)) ( P.wrap ( makeExample' updateOld <> "works like" @@ -945,7 +949,7 @@ previewUpdate = "update.old.preview" [] I.Visible - [("definition", ZeroPlus, noCompletionsArg)] + (Parameters [] . Optional [] $ Just ("definition", noCompletionsArg)) ( "`update.old.preview` previews updates to the codebase from the most " <> "recently typechecked file. This command only displays cached " <> "typechecking results. Use `load` to reparse & typecheck the file if " @@ -959,7 +963,7 @@ view = "view" [] I.Visible - [("definition to view", OnePlus, definitionQueryArg)] + (Parameters [] $ OnePlus ("definition to view", definitionQueryArg)) ( P.lines [ P.wrap $ makeExample view ["foo"] <> "shows definitions named `foo` within your current namespace.", P.wrap $ makeExample view [] <> "without arguments invokes a search to select definitions to view, which requires that `fzf` can be found within your PATH.", @@ -985,7 +989,7 @@ viewGlobal = "view.global" [] I.Visible - [("definition to view", ZeroPlus, definitionQueryArg)] + (Parameters [] . Optional [] $ Just ("definition to view", definitionQueryArg)) ( P.lines [ "`view.global foo` prints definitions of `foo` within your codebase.", "`view.global` without arguments invokes a search to select definitions to view, which requires that `fzf` can be found within your PATH." @@ -1005,7 +1009,7 @@ display = "display" [] I.Visible - [("definition to display", OnePlus, definitionQueryArg)] + (Parameters [] $ OnePlus ("definition to display", definitionQueryArg)) ( P.lines [ "`display foo` prints a rendered version of the term `foo`.", "`display` without arguments invokes a search to select a definition to display, which requires that `fzf` can be found within your PATH." @@ -1022,7 +1026,7 @@ displayTo = "display.to" [] I.Visible - [("destination file name", Required, filePathArg), ("definition to display", OnePlus, definitionQueryArg)] + (Parameters [("destination file name", filePathArg)] $ OnePlus ("definition to display", definitionQueryArg)) ( P.wrap $ makeExample displayTo ["", "foo"] <> "prints a rendered version of the term `foo` to the given file." @@ -1045,7 +1049,7 @@ docs = "docs" [] I.Visible - [("definition", OnePlus, definitionQueryArg)] + (Parameters [] $ OnePlus ("definition", definitionQueryArg)) ( P.lines [ "`docs foo` shows documentation for the definition `foo`.", "`docs` without arguments invokes a search to select which definition to view documentation for, which requires that `fzf` can be found within your PATH." @@ -1059,9 +1063,10 @@ api = "api" [] I.Visible - [] + noParams "`api` provides details about the API." - (const $ pure Input.ApiI) + . const + $ pure Input.ApiI ui :: InputPattern ui = @@ -1069,7 +1074,7 @@ ui = { patternName = "ui", aliases = [], visibility = I.Visible, - args = [("definition to load", Optional, namespaceOrDefinitionArg)], + params = Parameters [] $ Optional [("definition to load", namespaceOrDefinitionArg)] Nothing, help = P.wrap "`ui` opens the Local UI in the default browser.", parse = \case [] -> pure $ Input.UiI Path.relativeEmpty' @@ -1083,13 +1088,14 @@ undo = "undo" [] I.Visible - [] + noParams "`undo` reverts the most recent change to the codebase." - (const $ pure Input.UndoI) + . const + $ pure Input.UndoI textfind :: Bool -> InputPattern textfind allowLib = - InputPattern cmdName aliases I.Visible [("token", OnePlus, noCompletionsArg)] msg parse + InputPattern cmdName aliases I.Visible (Parameters [] $ OnePlus ("token", noCompletionsArg)) msg parse where (cmdName, aliases, alternate) = if allowLib @@ -1129,7 +1135,13 @@ untokenize words = go (unwords words) sfind :: InputPattern sfind = - InputPattern "rewrite.find" ["sfind"] I.Visible [("rewrite-rule definition", Required, definitionQueryArg)] msg parse + InputPattern + "rewrite.find" + ["sfind"] + I.Visible + (Parameters [("rewrite-rule definition", definitionQueryArg)] $ Optional [] Nothing) + msg + parse where parse = \case [q] -> Input.StructuredFindI (Input.FindLocal Path.relativeEmpty') <$> handleHashQualifiedNameArg q @@ -1161,7 +1173,13 @@ sfind = sfindReplace :: InputPattern sfindReplace = - InputPattern "rewrite" ["sfind.replace"] I.Visible [("rewrite-rule definition", Required, definitionQueryArg)] msg parse + InputPattern + "rewrite" + ["sfind.replace"] + I.Visible + (Parameters [("rewrite-rule definition", definitionQueryArg)] $ Optional [] Nothing) + msg + parse where parse [q] = Input.StructuredFindReplaceI <$> handleHashQualifiedNameArg q parse args = wrongArgsLength "exactly one argument" args @@ -1208,7 +1226,7 @@ findIn' cmd mkfscope = cmd [] I.Visible - [("namespace", Required, namespaceArg), ("query", ZeroPlus, exactDefinitionArg)] + (Parameters [("namespace", namespaceArg)] . Optional [] $ Just ("query", exactDefinitionArg)) findHelp \case p : args -> Input.FindI False . mkfscope <$> handlePath'Arg p <*> pure (unifyArgument <$> args) @@ -1256,7 +1274,7 @@ find' cmd fscope = cmd [] I.Visible - [("query", ZeroPlus, exactDefinitionArg)] + (Parameters [] . Optional [] $ Just ("query", exactDefinitionArg)) findHelp (pure . Input.FindI False fscope . fmap unifyArgument) @@ -1266,7 +1284,7 @@ findShallow = "list" ["ls", "dir"] I.Visible - [("namespace", Optional, namespaceArg)] + (Parameters [] $ Optional [("namespace", namespaceArg)] Nothing) ( P.wrapColumn2 [ ("`list`", "lists definitions and namespaces at the current level of the current namespace."), ("`list foo`", "lists the 'foo' namespace."), @@ -1285,7 +1303,7 @@ findVerbose = "find.verbose" [] I.Visible - [("query", ZeroPlus, exactDefinitionArg)] + (Parameters [] . Optional [] $ Just ("query", exactDefinitionArg)) ( "`find.verbose` searches for definitions like `find`, but includes hashes " <> "and aliases in the results." ) @@ -1297,7 +1315,7 @@ findVerboseAll = "find.all.verbose" [] I.Visible - [("query", ZeroPlus, exactDefinitionArg)] + (Parameters [] . Optional [] $ Just ("query", exactDefinitionArg)) ( "`find.all.verbose` searches for definitions like `find.all`, but includes hashes " <> "and aliases in the results." ) @@ -1309,9 +1327,9 @@ renameTerm = "move.term" ["rename.term"] I.Visible - [ ("definition to move", Required, exactDefinitionTermQueryArg), - ("new location", Required, newNameArg) - ] + ( Parameters [("definition to move", exactDefinitionTermQueryArg), ("new location", newNameArg)] $ + Optional [] Nothing + ) "`move.term foo bar` renames `foo` to `bar`." \case [oldName, newName] -> Input.MoveTermI <$> handleHashQualifiedSplit'Arg oldName <*> handleNewName newName @@ -1323,9 +1341,7 @@ moveAll = "move" ["rename"] I.Visible - [ ("definition to move", Required, namespaceOrDefinitionArg), - ("new location", Required, newNameArg) - ] + (Parameters [("definition to move", namespaceOrDefinitionArg), ("new location", newNameArg)] $ Optional [] Nothing) "`move foo bar` renames the term, type, and namespace foo to bar." \case [oldName, newName] -> Input.MoveAllI <$> handlePath'Arg oldName <*> handleNewPath newName @@ -1337,16 +1353,14 @@ renameType = "move.type" ["rename.type"] I.Visible - [ ("type to move", Required, exactDefinitionTypeQueryArg), - ("new location", Required, newNameArg) - ] + (Parameters [("type to move", exactDefinitionTypeQueryArg), ("new location", newNameArg)] $ Optional [] Nothing) "`move.type foo bar` renames `foo` to `bar`." \case [oldName, newName] -> Input.MoveTypeI <$> handleHashQualifiedSplit'Arg oldName <*> handleNewName newName _ -> Left $ P.wrap "`rename.type` takes two arguments, like `rename.type oldname newname`." -deleteGen :: Maybe String -> ArgumentType -> String -> ([Path.HQSplit'] -> DeleteTarget) -> InputPattern +deleteGen :: Maybe String -> ParameterType -> String -> ([Path.HQSplit'] -> DeleteTarget) -> InputPattern deleteGen suffix queryCompletionArg target mkTarget = let cmd = maybe "delete" ("delete." <>) suffix info = @@ -1381,7 +1395,7 @@ deleteGen suffix queryCompletionArg target mkTarget = cmd [] I.Visible - [("definition to delete", OnePlus, queryCompletionArg)] + (Parameters [] $ OnePlus ("definition to delete", queryCompletionArg)) info \case [] -> Left $ P.wrap warning @@ -1411,7 +1425,7 @@ deleteProject = { patternName = "delete.project", aliases = ["project.delete"], visibility = I.Visible, - args = [("project to delete", Required, projectNameArg)], + params = Parameters [("project to delete", projectNameArg)] $ Optional [] Nothing, help = P.wrapColumn2 [ ("`delete.project foo`", "deletes the local project `foo`") @@ -1427,7 +1441,7 @@ deleteBranch = { patternName = "delete.branch", aliases = ["branch.delete"], visibility = I.Visible, - args = [("branch to delete", Required, projectBranchNameArg suggestionsConfig)], + params = Parameters [("branch to delete", projectBranchNameArg suggestionsConfig)] $ Optional [] Nothing, help = P.wrapColumn2 [ ("`delete.branch foo/bar`", "deletes the branch `bar` in the project `foo`"), @@ -1451,7 +1465,8 @@ aliasTerm = { patternName = "alias.term", aliases = [], visibility = I.Visible, - args = [("term to alias", Required, exactDefinitionTermQueryArg), ("alias name", Required, newNameArg)], + params = + Parameters [("term to alias", exactDefinitionTermQueryArg), ("alias name", newNameArg)] $ Optional [] Nothing, help = "`alias.term foo bar` introduces `bar` with the same definition as `foo`.", parse = \case [oldName, newName] -> Input.AliasTermI False <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName @@ -1464,7 +1479,8 @@ debugAliasTermForce = { patternName = "debug.alias.term.force", aliases = [], visibility = I.Hidden, - args = [("term to alias", Required, exactDefinitionTermQueryArg), ("alias name", Required, newNameArg)], + params = + Parameters [("term to alias", exactDefinitionTermQueryArg), ("alias name", newNameArg)] $ Optional [] Nothing, help = "`debug.alias.term.force foo bar` introduces `bar` with the same definition as `foo`.", parse = \case [oldName, newName] -> Input.AliasTermI True <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName @@ -1479,7 +1495,7 @@ aliasType = "alias.type" [] I.Visible - [("type to alias", Required, exactDefinitionTypeQueryArg), ("alias name", Required, newNameArg)] + (Parameters [("type to alias", exactDefinitionTypeQueryArg), ("alias name", newNameArg)] $ Optional [] Nothing) "`alias.type Foo Bar` introduces `Bar` with the same definition as `Foo`." \case [oldName, newName] -> Input.AliasTypeI False <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName @@ -1491,7 +1507,8 @@ debugAliasTypeForce = { patternName = "debug.alias.type.force", aliases = [], visibility = I.Hidden, - args = [("type to alias", Required, exactDefinitionTypeQueryArg), ("alias name", Required, newNameArg)], + params = + Parameters [("type to alias", exactDefinitionTypeQueryArg), ("alias name", newNameArg)] $ Optional [] Nothing, help = "`debug.alias.type.force Foo Bar` introduces `Bar` with the same definition as `Foo`.", parse = \case [oldName, newName] -> Input.AliasTypeI True <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName @@ -1506,7 +1523,7 @@ aliasMany = "alias.many" ["copy"] I.Visible - [("definition to alias", Required, definitionQueryArg), ("alias names", OnePlus, exactDefinitionArg)] + (Parameters [("definition to alias", definitionQueryArg)] $ OnePlus ("alias names", exactDefinitionArg)) ( P.group . P.lines $ [ P.wrap $ P.group (makeExample aliasMany ["", "[relative2...]", ""]) @@ -1527,11 +1544,10 @@ up = "deprecated.up" [] I.Hidden - [] + noParams (P.wrapColumn2 [(makeExample up [], "move current path up one level (deprecated)")]) - \case - [] -> Right Input.UpI - args -> wrongArgsLength "no arguments" args + . const + $ pure Input.UpI cd :: InputPattern cd = @@ -1539,7 +1555,7 @@ cd = "deprecated.cd" ["deprecated.namespace"] I.Visible - [("namespace", Required, namespaceArg)] + (Parameters [("namespace", namespaceArg)] $ Optional [] Nothing) ( P.lines [ "Moves your perspective to a different namespace. Deprecated for now because too many important things depend on your perspective selection.", "", @@ -1570,16 +1586,15 @@ back = "back" ["popd"] I.Visible - [] + noParams ( P.wrapColumn2 [ ( makeExample back [], "undoes the last" <> makeExample' projectSwitch <> "command." ) ] ) - \case - [] -> pure Input.PopBranchI - args -> wrongArgsLength "no arguments" args + . const + $ pure Input.PopBranchI deleteNamespace :: InputPattern deleteNamespace = @@ -1587,7 +1602,7 @@ deleteNamespace = "delete.namespace" [] I.Visible - [("namespace to delete", Required, namespaceArg)] + (Parameters [("namespace to delete", namespaceArg)] $ Optional [] Nothing) "`delete.namespace ` deletes the namespace `foo`" (deleteNamespaceParser Input.Try) @@ -1597,7 +1612,7 @@ deleteNamespaceForce = "delete.namespace.force" [] I.Visible - [("namespace to delete", Required, namespaceArg)] + (Parameters [("namespace to delete", namespaceArg)] $ Optional [] Nothing) ( "`delete.namespace.force ` deletes the namespace `foo`," <> "deletion will proceed even if other code depends on definitions in foo." ) @@ -1615,7 +1630,7 @@ renameBranch = "move.namespace" ["rename.namespace"] I.Visible - [("namespace to move", Required, namespaceArg), ("new location", Required, newNameArg)] + (Parameters [("namespace to move", namespaceArg), ("new location", newNameArg)] $ Optional [] Nothing) "`move.namespace foo bar` renames the path `foo` to `bar`." \case [src, dest] -> Input.MoveBranchI <$> handlePath'Arg src <*> handlePath'Arg dest @@ -1627,7 +1642,7 @@ history = "history" [] I.Visible - [("namespace", Optional, namespaceArg)] + (Parameters [] $ Optional [("namespace", namespaceArg)] Nothing) ( P.wrapColumn2 [ (makeExample history [], "Shows the history of the current path."), (makeExample history [".foo"], "Shows history of the path .foo."), @@ -1648,9 +1663,9 @@ forkLocal = "fork" ["copy.namespace"] I.Visible - [ ("source location", Required, branchRelativePathArg), - ("dest location", Required, branchRelativePathArg) - ] + ( Parameters [("source location", branchRelativePathArg), ("dest location", branchRelativePathArg)] $ + Optional [] Nothing + ) ( P.wrapColumn2 [ ( makeExample forkLocal ["src", "dest"], "creates the namespace `dest` as a copy of `src`." @@ -1673,7 +1688,7 @@ libInstallInputPattern = { patternName = "lib.install", aliases = ["install.lib"], visibility = I.Visible, - args = [], + params = Parameters [("library name", noCompletionsArg)] $ Optional [] Nothing, help = P.lines [ P.wrap $ @@ -1704,9 +1719,9 @@ reset = "reset" [] I.Visible - [ ("namespace, hash, or branch to reset to", Required, namespaceOrProjectBranchArg config), - ("namespace to be reset", Optional, namespaceOrProjectBranchArg config) - ] + ( Parameters [("namespace, hash, or branch to reset to", namespaceOrProjectBranchArg config)] $ + Optional [("namespace to be reset", namespaceOrProjectBranchArg config)] Nothing + ) ( P.lines [ P.wrapColumn2 [ ("`reset #pvfd222s8n`", "reset the current namespace to the hash `#pvfd222s8n`"), @@ -1750,18 +1765,20 @@ pullImpl name aliases pullMode addendum = do { patternName = name, aliases = aliases, visibility = I.Visible, - args = - [ ("remote namespace to pull", Optional, remoteNamespaceArg), - ( "destination branch", - Optional, - projectBranchNameArg - ProjectBranchSuggestionsConfig - { showProjectCompletions = False, - projectInclusion = AllProjects, - branchInclusion = AllBranches - } - ) - ], + params = + Parameters [] $ + Optional + [ ("remote namespace to pull", remoteNamespaceArg), + ( "destination branch", + projectBranchNameArg + ProjectBranchSuggestionsConfig + { showProjectCompletions = False, + projectInclusion = AllProjects, + branchInclusion = AllBranches + } + ) + ] + Nothing, help = P.lines [ P.wrap $ @@ -1852,7 +1869,7 @@ debugTabCompletion = "debug.tab-complete" [] I.Hidden - [("command arguments", ZeroPlus, noCompletionsArg)] + (Parameters [] . Optional [] $ Just ("command arguments", noCompletionsArg)) ( P.lines [ P.wrap $ "This command can be used to test and debug ucm's tab-completion within transcripts.", P.wrap $ "Completions which are finished are prefixed with a * represent finished completions." @@ -1866,7 +1883,7 @@ debugLspNameCompletion = "debug.lsp-name-completion" [] I.Hidden - [("Completion prefix", OnePlus, noCompletionsArg)] + (Parameters [] $ OnePlus ("Completion prefix", noCompletionsArg)) ( P.lines [ P.wrap $ "This command can be used to test and debug ucm's LSP name-completion within transcripts." ] @@ -1881,7 +1898,7 @@ debugFuzzyOptions = "debug.fuzzy-options" [] I.Hidden - [("command arguments", OnePlus, noCompletionsArg)] + (Parameters [] $ OnePlus ("command arguments", noCompletionsArg)) ( P.lines [ P.wrap $ "This command can be used to test and debug ucm's fuzzy-options within transcripts.", P.wrap $ "Write a command invocation with _ for any args you'd like to see completion options for.", @@ -1903,7 +1920,7 @@ debugFormat = "debug.format" [] I.Hidden - [("source-file", Optional, filePathArg)] + (Parameters [] $ Optional [("source-file", filePathArg)] Nothing) ( P.lines [ P.wrap $ "This command can be used to test ucm's file formatter on the latest typechecked file.", makeExample' debugFormat @@ -1920,7 +1937,11 @@ push = "push" [] I.Visible - [("remote destination", Optional, remoteNamespaceArg), ("local target", Optional, namespaceOrProjectBranchArg suggestionsConfig)] + ( Parameters [] $ + Optional + [("remote destination", remoteNamespaceArg), ("local target", namespaceOrProjectBranchArg suggestionsConfig)] + Nothing + ) ( P.lines [ P.wrap "The `push` command merges a local project or namespace into a remote project or namespace.", @@ -1973,10 +1994,13 @@ pushCreate = "push.create" [] I.Visible - [("remote destination", Optional, remoteNamespaceArg), ("local target", Optional, namespaceOrProjectBranchArg suggestionsConfig)] + ( Parameters [] $ + Optional + [("remote destination", remoteNamespaceArg), ("local target", namespaceOrProjectBranchArg suggestionsConfig)] + Nothing + ) ( P.lines - [ P.wrap - "The `push.create` command pushes a local namespace to an empty remote namespace.", + [ P.wrap "The `push.create` command pushes a local namespace to an empty remote namespace.", "", P.wrapColumn2 [ ( "`push.create remote local`", @@ -2024,7 +2048,11 @@ pushForce = "unsafe.force-push" ["push.unsafe-force"] I.Visible - [("remote destination", Optional, remoteNamespaceArg), ("local source", Optional, namespaceOrProjectBranchArg suggestionsConfig)] + ( Parameters [] $ + Optional + [("remote destination", remoteNamespaceArg), ("local source", namespaceOrProjectBranchArg suggestionsConfig)] + Nothing + ) (P.wrap "Like `push`, but forcibly overwrites the remote namespace.") $ fmap ( \sourceTarget -> @@ -2054,7 +2082,11 @@ pushExhaustive = "debug.push-exhaustive" [] I.Hidden - [("remote destination", Optional, remoteNamespaceArg), ("local target", Optional, namespaceOrProjectBranchArg suggestionsConfig)] + ( Parameters [] $ + Optional + [("remote destination", remoteNamespaceArg), ("local target", namespaceOrProjectBranchArg suggestionsConfig)] + Nothing + ) ( P.lines [ P.wrap $ "The " @@ -2094,10 +2126,12 @@ mergeOldSquashInputPattern = { patternName = "merge.old.squash", aliases = ["squash.old"], visibility = I.Hidden, - args = - [ ("namespace or branch to be squashed", Required, namespaceOrProjectBranchArg suggestionsConfig), - ("merge destination", Required, namespaceOrProjectBranchArg suggestionsConfig) - ], + params = + Parameters + [ ("namespace or branch to be squashed", namespaceOrProjectBranchArg suggestionsConfig), + ("merge destination", namespaceOrProjectBranchArg suggestionsConfig) + ] + $ Optional [] Nothing, help = P.wrap $ makeExample mergeOldSquashInputPattern ["src", "dest"] @@ -2132,9 +2166,9 @@ mergeOldInputPattern = "merge.old" [] I.Hidden - [ ("branch or namespace to merge", Required, namespaceOrProjectBranchArg config), - ("merge destination", Optional, namespaceOrProjectBranchArg config) - ] + ( Parameters [("branch or namespace to merge", namespaceOrProjectBranchArg config)] $ + Optional [("merge destination", namespaceOrProjectBranchArg config)] Nothing + ) ( P.column2 [ ( makeExample mergeOldInputPattern ["foo/bar", "baz/qux"], "merges the `foo/bar` branch into the `baz/qux` branch" @@ -2177,17 +2211,18 @@ mergeInputPattern = { patternName = "merge", aliases = [], visibility = I.Visible, - args = - [ ( "branch to merge", - Required, - projectBranchNameArg - ProjectBranchSuggestionsConfig - { showProjectCompletions = True, - projectInclusion = AllProjects, - branchInclusion = ExcludeCurrentBranch - } - ) - ], + params = + Parameters + [ ( "branch to merge", + projectBranchNameArg + ProjectBranchSuggestionsConfig + { showProjectCompletions = True, + projectInclusion = AllProjects, + branchInclusion = ExcludeCurrentBranch + } + ) + ] + $ Optional [] Nothing, help = P.wrap $ makeExample mergeInputPattern ["/branch"] <> "merges `branch` into the current branch", parse = \case @@ -2201,7 +2236,7 @@ mergeCommitInputPattern = { patternName = "merge.commit", aliases = ["commit.merge"], visibility = I.Visible, - args = [], + params = noParams, help = let mainBranch = UnsafeProjectBranchName "main" tempBranch = UnsafeProjectBranchName "merge-topic-into-main" @@ -2232,9 +2267,7 @@ mergeCommitInputPattern = makeExampleNoBackticks deleteBranch [prettySlashProjectBranchName tempBranch] ] ), - parse = \case - [] -> Right Input.MergeCommitI - args -> wrongArgsLength "no arguments" args + parse = const $ pure Input.MergeCommitI } diffNamespace :: InputPattern @@ -2243,7 +2276,9 @@ diffNamespace = "diff.namespace" [] I.Visible - [("before namespace", Required, namespaceOrProjectBranchArg suggestionsConfig), ("after namespace", Optional, namespaceOrProjectBranchArg suggestionsConfig)] + ( Parameters [("before namespace", namespaceOrProjectBranchArg suggestionsConfig)] $ + Optional [("after namespace", namespaceOrProjectBranchArg suggestionsConfig)] Nothing + ) ( P.column2 [ ( "`diff.namespace before after`", P.wrap "shows how the namespace `after` differs from the namespace `before`" @@ -2272,7 +2307,9 @@ mergeOldPreviewInputPattern = "merge.old.preview" [] I.Hidden - [("branch or namespace to merge", Required, namespaceOrProjectBranchArg suggestionsConfig), ("merge destination", Optional, namespaceOrProjectBranchArg suggestionsConfig)] + ( Parameters [("branch or namespace to merge", namespaceOrProjectBranchArg suggestionsConfig)] $ + Optional [("merge destination", namespaceOrProjectBranchArg suggestionsConfig)] Nothing + ) ( P.column2 [ ( makeExample mergeOldPreviewInputPattern ["src"], "shows how the current namespace will change after a " <> makeExample mergeOldInputPattern ["src"] @@ -2302,17 +2339,13 @@ deprecatedViewRootReflog = "deprecated.root-reflog" [] I.Visible - [] + noParams ( "`deprecated.root-reflog` lists the changes that have affected the root namespace. This has been deprecated in favor of " <> makeExample branchReflog [] <> " which shows the reflog for the current project." ) - ( \case - [] -> pure Input.ShowRootReflogI - _ -> - Left . P.string $ - I.patternName deprecatedViewRootReflog ++ " doesn't take any arguments." - ) + . const + $ pure Input.ShowRootReflogI branchReflog :: InputPattern branchReflog = @@ -2320,7 +2353,7 @@ branchReflog = "reflog" ["reflog.branch", "branch.reflog"] I.Visible - [] + (Parameters [] $ Optional [("branch name", noCompletionsArg)] Nothing) ( P.lines [ "`reflog` lists all the changes that have affected the current branch.", "`reflog /mybranch` lists all the changes that have affected /mybranch." @@ -2338,7 +2371,7 @@ projectReflog = "project.reflog" ["reflog.project"] I.Visible - [] + (Parameters [] $ Optional [("project name", noCompletionsArg)] Nothing) ( P.lines [ "`project.reflog` lists all the changes that have affected any branches in the current project.", "`project.reflog myproject` lists all the changes that have affected any branches in myproject." @@ -2356,15 +2389,13 @@ globalReflog = "reflog.global" [] I.Visible - [] + noParams ( P.lines [ "`reflog.global` lists all recent changes across all projects and branches." ] ) - ( \case - [] -> pure $ Input.ShowGlobalReflogI - _ -> Left (I.help globalReflog) - ) + . const + $ pure Input.ShowGlobalReflogI edit :: InputPattern edit = @@ -2372,7 +2403,7 @@ edit = { patternName = "edit", aliases = [], visibility = I.Visible, - args = [("definition to edit", OnePlus, definitionQueryArg)], + params = Parameters [] $ OnePlus ("definition to edit", definitionQueryArg), help = P.lines [ "`edit foo` prepends the definition of `foo` to the top of the most " @@ -2394,7 +2425,7 @@ editNew = { patternName = "edit.new", aliases = [], visibility = I.Visible, - args = [("definition to edit", OnePlus, definitionQueryArg)], + params = Parameters [] $ OnePlus ("definition to edit", definitionQueryArg), help = "Like `edit`, but adds a new fold line below the definitions.", parse = maybe @@ -2411,7 +2442,7 @@ editDependents = { patternName = "edit.dependents", aliases = [], visibility = I.Visible, - args = [("definition to edit", Required, definitionQueryArg)], + params = Parameters [("definition to edit", definitionQueryArg)] $ Optional [] Nothing, help = "Like `edit`, but also includes all transitive dependents in the current project.", parse = \case [name] -> Input.EditDependentsI <$> handleHashQualifiedNameArg name @@ -2424,7 +2455,7 @@ editNamespace = { patternName = "edit.namespace", aliases = [], visibility = I.Visible, - args = [("namespace to load definitions from", ZeroPlus, namespaceArg)], + params = Parameters [] . Optional [] $ Just ("namespace to load definitions from", namespaceArg), help = P.lines [ "`edit.namespace` will load all terms and types contained within the current namespace into your scratch file. This includes definitions in namespaces, but excludes libraries.", @@ -2433,10 +2464,18 @@ editNamespace = parse = fmap Input.EditNamespaceI . traverse handlePathArg } -topicNameArg :: ArgumentType +newBranchNameArg :: ParameterType +newBranchNameArg = + ParameterType + { typeName = "new-branch", + suggestions = \_ _ _ _ -> pure [], + fzfResolver = Nothing + } + +topicNameArg :: ParameterType topicNameArg = let topics = Map.keys helpTopicsMap - in ArgumentType + in ParameterType { typeName = "topic", suggestions = \q _ _ _ -> pure (exactComplete q topics), fzfResolver = Just $ Resolvers.fuzzySelectFromList (Text.pack <$> topics) @@ -2448,7 +2487,7 @@ helpTopics = "help-topics" ["help-topic"] I.Visible - [("topic", Optional, topicNameArg)] + (Parameters [] $ Optional [("topic", topicNameArg)] Nothing) ("`help-topics` lists all topics and `help-topics ` shows an explanation of that topic.") ( \case [] -> Right $ Input.CreateMessage topics @@ -2632,7 +2671,7 @@ help = "help" ["?"] I.Visible - [("command", Optional, commandNameArg)] + (Parameters [] $ Optional [("command", commandNameArg)] Nothing) "`help` shows general help and `help ` shows help for one command." $ \case [] -> @@ -2675,11 +2714,10 @@ quit = "quit" ["exit", ":q"] I.Visible - [] + noParams "Exits the Unison command line interface." - \case - [] -> pure Input.QuitI - _ -> Left "Use `quit`, `exit`, or to quit." + . const + $ pure Input.QuitI names :: Input.IsGlobal -> InputPattern names isGlobal = @@ -2687,7 +2725,7 @@ names isGlobal = cmdName [] I.Visible - [("name or hash", Required, definitionQueryArg)] + (Parameters [("name or hash", definitionQueryArg)] $ Optional [] Nothing) (P.wrap $ makeExample (names isGlobal) ["foo"] <> description) $ \case [thing] -> Input.NamesI isGlobal <$> handleHashQualifiedNameArg thing @@ -2704,7 +2742,7 @@ dependents = "dependents" [] I.Visible - [("definition", Required, definitionQueryArg)] + (Parameters [("definition", definitionQueryArg)] $ Optional [] Nothing) "List the named dependents of the specified definition." $ \case [thing] -> Input.ListDependentsI <$> handleHashQualifiedNameArg thing @@ -2714,7 +2752,7 @@ dependencies = "dependencies" [] I.Visible - [("definition", Required, definitionQueryArg)] + (Parameters [("definition", definitionQueryArg)] $ Optional [] Nothing) "List the dependencies of the specified definition." $ \case [thing] -> Input.ListDependenciesI <$> handleHashQualifiedNameArg thing @@ -2726,7 +2764,7 @@ namespaceDependencies = "namespace.dependencies" [] I.Visible - [("namespace", Optional, namespaceArg)] + (Parameters [] $ Optional [("namespace", namespaceArg)] Nothing) "List the external dependencies of the specified namespace." $ \case [p] -> Input.NamespaceDependenciesI . pure <$> handlePath'Arg p @@ -2739,9 +2777,10 @@ debugNumberedArgs = "debug.numberedArgs" [] I.Visible - [] + noParams "Dump the contents of the numbered args state." - (const $ Right Input.DebugNumberedArgsI) + . const + $ pure Input.DebugNumberedArgsI debugFileHashes :: InputPattern debugFileHashes = @@ -2749,9 +2788,10 @@ debugFileHashes = "debug.file" [] I.Visible - [] + noParams "View details about the most recent successfully typechecked file." - (const $ Right Input.DebugTypecheckedUnisonFileI) + . const + $ pure Input.DebugTypecheckedUnisonFileI debugDumpNamespace :: InputPattern debugDumpNamespace = @@ -2759,9 +2799,10 @@ debugDumpNamespace = "debug.dump-namespace" [] I.Visible - [] + noParams "Dump the namespace to a text file" - (const $ Right Input.DebugDumpNamespacesI) + . const + $ pure Input.DebugDumpNamespacesI debugDumpNamespaceSimple :: InputPattern debugDumpNamespaceSimple = @@ -2769,9 +2810,10 @@ debugDumpNamespaceSimple = "debug.dump-namespace-simple" [] I.Visible - [] + noParams "Dump the namespace to a text file" - (const $ Right Input.DebugDumpNamespaceSimpleI) + . const + $ pure Input.DebugDumpNamespaceSimpleI debugTerm :: InputPattern debugTerm = @@ -2779,7 +2821,7 @@ debugTerm = "debug.term.abt" [] I.Hidden - [("term", Required, exactDefinitionTermQueryArg)] + (Parameters [("term", exactDefinitionTermQueryArg)] $ Optional [] Nothing) "View debugging information for a given term." ( \case [thing] -> Input.DebugTermI False <$> handleHashQualifiedNameArg thing @@ -2792,7 +2834,7 @@ debugTermVerbose = "debug.term.abt.verbose" [] I.Hidden - [("term", Required, exactDefinitionTermQueryArg)] + (Parameters [("term", exactDefinitionTermQueryArg)] $ Optional [] Nothing) "View verbose debugging information for a given term." ( \case [thing] -> Input.DebugTermI True <$> handleHashQualifiedNameArg thing @@ -2805,7 +2847,7 @@ debugType = "debug.type.abt" [] I.Hidden - [("type", Required, exactDefinitionTypeQueryArg)] + (Parameters [("type", exactDefinitionTypeQueryArg)] $ Optional [] Nothing) "View debugging information for a given type." ( \case [thing] -> Input.DebugTypeI <$> handleHashQualifiedNameArg thing @@ -2818,9 +2860,10 @@ debugLSPFoldRanges = "debug.lsp.fold-ranges" [] I.Hidden - [] + noParams "Output the source from the most recently parsed file, but annotated with the computed fold ranges." - (const $ Right Input.DebugLSPFoldRangesI) + . const + $ pure Input.DebugLSPFoldRangesI debugClearWatchCache :: InputPattern debugClearWatchCache = @@ -2828,9 +2871,10 @@ debugClearWatchCache = "debug.clear-cache" [] I.Visible - [] + noParams "Clear the watch expression cache" - (const $ Right Input.DebugClearWatchI) + . const + $ pure Input.DebugClearWatchI debugDoctor :: InputPattern debugDoctor = @@ -2838,13 +2882,10 @@ debugDoctor = "debug.doctor" [] I.Visible - [] - ( P.wrap "Analyze your codebase for errors and inconsistencies." - ) - ( \case - [] -> Right $ Input.DebugDoctorI - args -> wrongArgsLength "no arguments" args - ) + noParams + (P.wrap "Analyze your codebase for errors and inconsistencies.") + . const + $ pure Input.DebugDoctorI debugNameDiff :: InputPattern debugNameDiff = @@ -2852,7 +2893,7 @@ debugNameDiff = { patternName = "debug.name-diff", aliases = [], visibility = I.Hidden, - args = [("before namespace", Required, namespaceArg), ("after namespace", Required, namespaceArg)], + params = Parameters [("before namespace", namespaceArg), ("after namespace", namespaceArg)] $ Optional [] Nothing, help = P.wrap "List all name changes between two causal hashes. Does not detect patch changes.", parse = \case [from, to] -> Input.DebugNameDiffI <$> handleShortCausalHashArg from <*> handleShortCausalHashArg to @@ -2865,7 +2906,7 @@ test = { patternName = "test", aliases = [], visibility = I.Visible, - args = [("namespace", Optional, namespaceArg)], + params = Parameters [] $ Optional [("namespace", namespaceArg)] Nothing, help = P.wrapColumn2 [ ("`test`", "runs unit tests for the current branch"), @@ -2895,7 +2936,7 @@ testNative = { patternName = "test.native", aliases = [], visibility = I.Hidden, - args = [("namespace", Optional, namespaceArg)], + params = Parameters [] $ Optional [("namespace", namespaceArg)] Nothing, help = P.wrapColumn2 [ ( "`test.native`", @@ -2927,19 +2968,18 @@ testAll = "test.all" [] I.Visible - [] + noParams "`test.all` runs unit tests for the current branch (including the `lib` namespace)." - ( const $ - pure $ - Input.TestI - False - Input.TestInput - { includeLibNamespace = True, - path = Path.empty, - showFailures = True, - showSuccesses = True - } - ) + . const + . pure + $ Input.TestI + False + Input.TestInput + { includeLibNamespace = True, + path = Path.empty, + showFailures = True, + showSuccesses = True + } testAllNative :: InputPattern testAllNative = @@ -2947,19 +2987,18 @@ testAllNative = "test.native.all" ["test.all.native"] I.Hidden - [] + noParams "`test.native.all` runs unit tests for the current branch (including the `lib` namespace) on the native runtime." - ( const $ - pure $ - Input.TestI - True - Input.TestInput - { includeLibNamespace = True, - path = Path.empty, - showFailures = True, - showSuccesses = True - } - ) + . const + . pure + $ Input.TestI + True + Input.TestInput + { includeLibNamespace = True, + path = Path.empty, + showFailures = True, + showSuccesses = True + } docsToHtml :: InputPattern docsToHtml = @@ -2967,7 +3006,7 @@ docsToHtml = "docs.to-html" [] I.Visible - [("namespace", Required, branchRelativePathArg), ("", Required, filePathArg)] + (Parameters [("namespace", branchRelativePathArg), ("output directory", filePathArg)] $ Optional [] Nothing) ( P.wrapColumn2 [ ( makeExample docsToHtml [".path.to.ns", "doc-dir"], "Render all docs contained within the namespace `.path.to.ns`, no matter how deep, to html files in `doc-dir` in the directory UCM was run from." @@ -2990,7 +3029,7 @@ docToMarkdown = "debug.doc-to-markdown" [] I.Visible - [("doc to render", Required, exactDefinitionTermQueryArg)] + (Parameters [("doc to render", exactDefinitionTermQueryArg)] $ Optional [] Nothing) ( P.wrapColumn2 [ ( "`debug.doc-to-markdown term.doc`", "Render a doc to markdown." @@ -3007,7 +3046,7 @@ execute = "run" [] I.Visible - [("definition to execute", Required, exactDefinitionTermQueryArg), ("argument", ZeroPlus, noCompletionsArg)] + (Parameters [("definition to execute", exactDefinitionTermQueryArg)] . Optional [] $ Just ("argument", noCompletionsArg)) ( P.wrapColumn2 [ ( "`run mymain args...`", "Runs `!mymain`, where `mymain` is searched for in the most recent" @@ -3030,7 +3069,7 @@ saveExecuteResult = "add.run" [] I.Visible - [("new name", Required, newNameArg)] + (Parameters [("new name", newNameArg)] $ Optional [] Nothing) ( "`add.run name` adds to the codebase the result of the most recent `run` command" <> " as `name`." ) @@ -3044,7 +3083,7 @@ ioTest = { patternName = "io.test", aliases = ["test.io"], visibility = I.Visible, - args = [("test to run", Required, exactDefinitionTermQueryArg)], + params = Parameters [("test to run", exactDefinitionTermQueryArg)] $ Optional [] Nothing, help = P.wrapColumn2 [ ( "`io.test mytest`", @@ -3062,7 +3101,7 @@ ioTestNative = { patternName = "io.test.native", aliases = ["test.io.native", "test.native.io"], visibility = I.Hidden, - args = [("test to run", Required, exactDefinitionTermQueryArg)], + params = Parameters [("test to run", exactDefinitionTermQueryArg)] $ Optional [] Nothing, help = P.wrapColumn2 [ ( "`io.test.native mytest`", @@ -3082,16 +3121,14 @@ ioTestAll = { patternName = "io.test.all", aliases = ["test.io.all"], visibility = I.Visible, - args = [], + params = noParams, help = P.wrapColumn2 [ ( "`io.test.all`", "runs unit tests for the current branch that use IO" ) ], - parse = \case - [] -> Right (Input.IOTestAllI False) - args -> wrongArgsLength "no arguments" args + parse = const . pure $ Input.IOTestAllI False } ioTestAllNative :: InputPattern @@ -3100,16 +3137,14 @@ ioTestAllNative = { patternName = "io.test.native.all", aliases = ["test.io.native.all", "test.native.io.all"], visibility = I.Hidden, - args = [], + params = noParams, help = P.wrapColumn2 [ ( "`io.test.native.all`", "runs unit tests for the current branch that use IO" ) ], - parse = \case - [] -> Right (Input.IOTestAllI True) - args -> wrongArgsLength "no arguments" args + parse = const . pure $ Input.IOTestAllI True } makeStandalone :: InputPattern @@ -3118,7 +3153,9 @@ makeStandalone = "compile" ["compile.output"] I.Visible - [("definition to compile", Required, exactDefinitionTermQueryArg), ("output file", Required, filePathArg)] + ( Parameters [("definition to compile", exactDefinitionTermQueryArg), ("output file", filePathArg)] $ + Optional [] Nothing + ) ( P.wrapColumn2 [ ( "`compile main file`", "Outputs a stand alone file that can be directly loaded and" @@ -3140,7 +3177,9 @@ runScheme = "run.native" [] I.Visible - [("definition to run", Required, exactDefinitionTermQueryArg), ("arguments", ZeroPlus, noCompletionsArg)] + ( Parameters [("definition to run", exactDefinitionTermQueryArg)] . Optional [] $ + Just ("arguments", noCompletionsArg) + ) ( P.wrapColumn2 [ ( makeExample runScheme ["main", "args"], "Executes !main using native compilation via scheme." @@ -3160,10 +3199,9 @@ compileScheme = "compile.native" [] I.Hidden - [ ("definition to compile", Required, exactDefinitionTermQueryArg), - ("output file", Required, filePathArg), - ("profile", Optional, profileArg) - ] + ( Parameters [("definition to compile", exactDefinitionTermQueryArg), ("output file", filePathArg)] $ + Optional [("profile", profileArg)] Nothing + ) ( P.wrapColumn2 [ ( makeExample compileScheme ["main", "file", "profile"], "Creates stand alone executable via compilation to" @@ -3198,7 +3236,7 @@ createAuthor = "create.author" [] I.Visible - [("definition name", Required, noCompletionsArg), ("author name", Required, noCompletionsArg)] + (Parameters [("definition name", noCompletionsArg)] $ OnePlus ("author name", noCompletionsArg)) ( makeExample createAuthor ["alicecoder", "\"Alice McGee\""] <> " " <> P.wrap @@ -3232,17 +3270,14 @@ authLogin = "auth.login" [] I.Visible - [] + noParams ( P.lines [ P.wrap "Obtain an authentication session with Unison Share.", - makeExample authLogin [] - <> "authenticates ucm with Unison Share." + makeExample authLogin [] <> "authenticates ucm with Unison Share." ] ) - ( \case - [] -> Right $ Input.AuthLoginI - args -> wrongArgsLength "no arguments" args - ) + . const + $ pure Input.AuthLoginI printVersion :: InputPattern printVersion = @@ -3250,13 +3285,10 @@ printVersion = "version" [] I.Visible - [] - ( P.wrap "Print the version of unison you're running" - ) - ( \case - [] -> Right $ Input.VersionI - args -> wrongArgsLength "no arguments" args - ) + noParams + (P.wrap "Print the version of unison you're running") + . const + $ pure Input.VersionI projectCreate :: InputPattern projectCreate = @@ -3264,7 +3296,7 @@ projectCreate = { patternName = "project.create", aliases = ["create.project"], visibility = I.Visible, - args = [], + params = Parameters [] $ Optional [("project name", noCompletionsArg)] Nothing, help = P.wrapColumn2 [ ("`project.create`", "creates a project with a random name"), @@ -3282,7 +3314,7 @@ projectCreateEmptyInputPattern = { patternName = "project.create-empty", aliases = ["create.empty-project"], visibility = I.Hidden, - args = [], + params = Parameters [] $ Optional [("project name", noCompletionsArg)] Nothing, help = P.wrapColumn2 [ ("`project.create-empty`", "creates an empty project with a random name"), @@ -3300,7 +3332,7 @@ projectRenameInputPattern = { patternName = "project.rename", aliases = ["rename.project"], visibility = I.Visible, - args = [("new name", Required, projectNameArg)], + params = Parameters [("new name", projectNameArg)] $ Optional [] Nothing, help = P.wrapColumn2 [ ("`project.rename foo`", "renames the current project to `foo`") @@ -3316,7 +3348,9 @@ projectSwitch = { patternName = "switch", aliases = [], visibility = I.Visible, - args = [("project or branch to switch to", Required, projectAndBranchNamesArg suggestionsConfig)], + params = + Parameters [("project or branch to switch to", projectAndBranchNamesArg suggestionsConfig)] $ + Optional [] Nothing, help = P.wrapColumn2 [ ("`switch`", "opens an interactive selector to pick a project and branch"), @@ -3342,9 +3376,9 @@ projectsInputPattern = { patternName = "projects", aliases = ["list.project", "ls.project", "project.list"], visibility = I.Visible, - args = [], + params = noParams, help = P.wrap "List projects.", - parse = \_ -> Right Input.ProjectsI + parse = const $ pure Input.ProjectsI } branchesInputPattern :: InputPattern @@ -3353,7 +3387,7 @@ branchesInputPattern = { patternName = "branches", aliases = ["list.branch", "ls.branch", "branch.list"], visibility = I.Visible, - args = [("project", Optional, projectNameArg)], + params = Parameters [] $ Optional [("project", projectNameArg)] Nothing, help = P.wrapColumn2 [ ("`branches`", "lists all branches in the current project"), @@ -3371,10 +3405,9 @@ branchInputPattern = { patternName = "branch", aliases = ["branch.create", "create.branch"], visibility = I.Visible, - args = - [ ("branch", Required, projectBranchNameArg suggestionsConfig), - ("branch", Optional, newBranchNameArg) - ], + params = + Parameters [("branch", projectBranchNameArg suggestionsConfig)] $ + Optional [("branch", newBranchNameArg)] Nothing, help = P.wrapColumn2 [ ("`branch foo`", "forks the current project branch to a new branch `foo`"), @@ -3389,12 +3422,6 @@ branchInputPattern = args -> wrongArgsLength "one or two arguments" args } where - newBranchNameArg = - ArgumentType - { typeName = "new-branch", - suggestions = \_ _ _ _ -> pure [], - fzfResolver = Nothing - } suggestionsConfig = ProjectBranchSuggestionsConfig { showProjectCompletions = False, @@ -3408,7 +3435,7 @@ branchEmptyInputPattern = { patternName = "branch.empty", aliases = ["branch.create-empty", "create.empty-branch"], visibility = I.Visible, - args = [], + params = Parameters [("branch", newBranchNameArg)] $ Optional [] Nothing, help = P.wrap "Create a new empty branch.", parse = \case [name] -> @@ -3423,7 +3450,7 @@ branchRenameInputPattern = { patternName = "branch.rename", aliases = ["rename.branch"], visibility = I.Visible, - args = [], + params = Parameters [("branch", newBranchNameArg)] $ Optional [] Nothing, help = P.wrapColumn2 [("`branch.rename foo`", "renames the current branch to `foo`")], @@ -3438,7 +3465,9 @@ clone = { patternName = "clone", aliases = [], visibility = I.Visible, - args = [], + params = + Parameters [("source branch", projectAndBranchNamesArg suggestionsConfig)] $ + Optional [("target branch", newBranchNameArg)] Nothing, help = P.wrapColumn2 [ ( "`clone @unison/json/topic json/my-topic`", @@ -3469,6 +3498,13 @@ clone = <*> fmap pure (handleProjectAndBranchNamesArg localNames) args -> wrongArgsLength "one or two arguments" args } + where + suggestionsConfig = + ProjectBranchSuggestionsConfig + { showProjectCompletions = True, + projectInclusion = AllProjects, + branchInclusion = ExcludeCurrentBranch + } releaseDraft :: InputPattern releaseDraft = @@ -3476,7 +3512,7 @@ releaseDraft = { patternName = "release.draft", aliases = ["draft.release"], visibility = I.Visible, - args = [], + params = Parameters [("version", noCompletionsArg)] $ Optional [] Nothing, help = P.wrap "Draft a release.", parse = \case [semverString] -> @@ -3493,7 +3529,9 @@ upgrade = { patternName = "upgrade", aliases = [], visibility = I.Visible, - args = [("dependency to upgrade", Required, dependencyArg), ("dependency to upgrade to", Required, dependencyArg)], + params = + Parameters [("dependency to upgrade", dependencyArg), ("dependency to upgrade to", dependencyArg)] $ + Optional [] Nothing, help = P.wrap $ "`upgrade old new` upgrades library dependency `lib.old` to `lib.new`, and, if successful, deletes `lib.old`.", @@ -3509,7 +3547,7 @@ upgradeCommitInputPattern = { patternName = "upgrade.commit", aliases = ["commit.upgrade"], visibility = I.Visible, - args = [], + params = noParams, help = let mainBranch = UnsafeProjectBranchName "main" tempBranch = UnsafeProjectBranchName "upgrade-foo-to-bar" @@ -3540,9 +3578,7 @@ upgradeCommitInputPattern = makeExampleNoBackticks deleteBranch [prettySlashProjectBranchName tempBranch] ] ), - parse = \case - [] -> Right Input.UpgradeCommitI - args -> wrongArgsLength "no arguments" args + parse = const $ pure Input.UpgradeCommitI } debugSynhashTermInputPattern :: InputPattern @@ -3551,7 +3587,7 @@ debugSynhashTermInputPattern = { patternName = "debug.synhash.term", aliases = [], visibility = I.Hidden, - args = [("term", Required, exactDefinitionTermQueryArg)], + params = Parameters [("term", exactDefinitionTermQueryArg)] $ Optional [] Nothing, help = mempty, parse = \case [arg] -> Input.DebugSynhashTermI <$> handleNameArg arg @@ -3710,70 +3746,70 @@ visibleInputs = filter ((== I.Visible) . I.visibility) validInputs commandNames :: [String] commandNames = visibleInputs >>= \i -> I.patternName i : I.aliases i -commandNameArg :: ArgumentType +commandNameArg :: ParameterType commandNameArg = let options = commandNames <> Map.keys helpTopicsMap - in ArgumentType + in ParameterType { typeName = "command", suggestions = \q _ _ _ -> pure (exactComplete q options), fzfResolver = Just $ Resolvers.fuzzySelectFromList (Text.pack <$> options) } -exactDefinitionArg :: ArgumentType +exactDefinitionArg :: ParameterType exactDefinitionArg = - ArgumentType + ParameterType { typeName = "definition", suggestions = \q cb _http p -> Codebase.runTransaction cb (prefixCompleteTermOrType q p), fzfResolver = Just Resolvers.definitionResolver } -definitionQueryArg :: ArgumentType +definitionQueryArg :: ParameterType definitionQueryArg = exactDefinitionArg {typeName = "definition query"} -exactDefinitionTypeQueryArg :: ArgumentType +exactDefinitionTypeQueryArg :: ParameterType exactDefinitionTypeQueryArg = - ArgumentType + ParameterType { typeName = "type definition query", suggestions = \q cb _http p -> Codebase.runTransaction cb (prefixCompleteType q p), fzfResolver = Just Resolvers.typeDefinitionResolver } -exactDefinitionTypeOrTermQueryArg :: ArgumentType +exactDefinitionTypeOrTermQueryArg :: ParameterType exactDefinitionTypeOrTermQueryArg = - ArgumentType + ParameterType { typeName = "type or term definition query", suggestions = \q cb _http p -> Codebase.runTransaction cb (prefixCompleteTermOrType q p), fzfResolver = Just Resolvers.definitionResolver } -exactDefinitionTermQueryArg :: ArgumentType +exactDefinitionTermQueryArg :: ParameterType exactDefinitionTermQueryArg = - ArgumentType + ParameterType { typeName = "term definition query", suggestions = \q cb _http p -> Codebase.runTransaction cb (prefixCompleteTerm q p), fzfResolver = Just Resolvers.termDefinitionResolver } -patchArg :: ArgumentType +patchArg :: ParameterType patchArg = - ArgumentType + ParameterType { typeName = "patch", suggestions = \q cb _http p -> Codebase.runTransaction cb (prefixCompletePatch q p), fzfResolver = Nothing } -namespaceArg :: ArgumentType +namespaceArg :: ParameterType namespaceArg = - ArgumentType + ParameterType { typeName = "namespace", suggestions = \q cb _http p -> Codebase.runTransaction cb (prefixCompleteNamespace q p), fzfResolver = Just Resolvers.namespaceResolver } -- | Usually you'll want one or the other, but some commands support both right now. -namespaceOrProjectBranchArg :: ProjectBranchSuggestionsConfig -> ArgumentType +namespaceOrProjectBranchArg :: ProjectBranchSuggestionsConfig -> ParameterType namespaceOrProjectBranchArg config = - ArgumentType + ParameterType { typeName = "namespace or branch", suggestions = let namespaceSuggestions = \q cb _http pp -> Codebase.runTransaction cb (prefixCompleteNamespace q pp) @@ -3784,9 +3820,9 @@ namespaceOrProjectBranchArg config = fzfResolver = Just Resolvers.projectOrBranchResolver } -namespaceOrDefinitionArg :: ArgumentType +namespaceOrDefinitionArg :: ParameterType namespaceOrDefinitionArg = - ArgumentType + ParameterType { typeName = "term, type, or namespace", suggestions = \q cb _http p -> Codebase.runTransaction cb do namespaces <- prefixCompleteNamespace q p @@ -3798,51 +3834,51 @@ namespaceOrDefinitionArg = -- | A dependency name. E.g. if your project has `lib.base`, `base` would be a dependency -- name. -dependencyArg :: ArgumentType +dependencyArg :: ParameterType dependencyArg = - ArgumentType + ParameterType { typeName = "project dependency", suggestions = \q cb _http pp -> Codebase.runTransaction cb do prefixCompleteNamespace q (pp & PP.path_ .~ Path.singleton NameSegment.libSegment), fzfResolver = Just Resolvers.projectDependencyResolver } -newNameArg :: ArgumentType +newNameArg :: ParameterType newNameArg = - ArgumentType + ParameterType { typeName = "new-name", suggestions = \q cb _http p -> Codebase.runTransaction cb (prefixCompleteNamespace q p), fzfResolver = Nothing } -noCompletionsArg :: ArgumentType +noCompletionsArg :: ParameterType noCompletionsArg = - ArgumentType + ParameterType { typeName = "word", suggestions = noCompletions, fzfResolver = Nothing } -filePathArg :: ArgumentType +filePathArg :: ParameterType filePathArg = - ArgumentType + ParameterType { typeName = "file-path", suggestions = noCompletions, fzfResolver = Nothing } -- | Refers to a namespace on some remote code host. -remoteNamespaceArg :: ArgumentType +remoteNamespaceArg :: ParameterType remoteNamespaceArg = - ArgumentType + ParameterType { typeName = "remote-namespace", suggestions = \input _cb http _p -> sharePathCompletion http input, fzfResolver = Nothing } -profileArg :: ArgumentType +profileArg :: ParameterType profileArg = - ArgumentType + ParameterType { typeName = "profile", suggestions = \_input _cb _http _p -> pure [Line.simpleCompletion "profile"], @@ -4160,26 +4196,26 @@ branchRelativePathSuggestions config inputStr codebase _httpClient pp = do branchPathSep = ":" -- | A project name, branch name, or both. -projectAndBranchNamesArg :: ProjectBranchSuggestionsConfig -> ArgumentType +projectAndBranchNamesArg :: ProjectBranchSuggestionsConfig -> ParameterType projectAndBranchNamesArg config = - ArgumentType + ParameterType { typeName = "project-and-branch-names", suggestions = projectAndOrBranchSuggestions config, fzfResolver = Just Resolvers.projectAndOrBranchArg } -- | A project branch name. -projectBranchNameArg :: ProjectBranchSuggestionsConfig -> ArgumentType +projectBranchNameArg :: ProjectBranchSuggestionsConfig -> ParameterType projectBranchNameArg config = - ArgumentType + ParameterType { typeName = "project-branch-name", suggestions = projectAndOrBranchSuggestions config, fzfResolver = Just Resolvers.projectBranchResolver } -branchRelativePathArg :: ArgumentType +branchRelativePathArg :: ParameterType branchRelativePathArg = - ArgumentType + ParameterType { typeName = "branch-relative-path", suggestions = branchRelativePathSuggestions config, fzfResolver = Nothing @@ -4193,9 +4229,9 @@ branchRelativePathArg = } -- | A project name. -projectNameArg :: ArgumentType +projectNameArg :: ParameterType projectNameArg = - ArgumentType + ParameterType { typeName = "project-name", suggestions = \input codebase _httpClient _path -> projectNameSuggestions NoSlash input codebase, fzfResolver = Just $ Resolvers.multiResolver [Resolvers.projectNameOptions] diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index f2d1ab61c0..f347c33f8c 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1584,6 +1584,8 @@ notifyUser dir = \case pure $ P.lines [P.text (FZFResolvers.fuzzySelectHeader argDesc), P.indentN 2 $ P.bulleted (P.string <$> fuzzyOptions)] + DebugFuzzyOptionsIncorrectArgs _ -> pure $ P.string "Too many arguments were provided." + DebugFuzzyOptionsNoCommand command -> pure $ "The command “" <> P.string command <> "” doesn’t exist." DebugFuzzyOptionsNoResolver -> pure "No resolver found for fuzzy options in this slot." ClearScreen -> do ANSI.clearScreen From 2684f9a4ec3396ba81d358f7ceb578fa151797fc Mon Sep 17 00:00:00 2001 From: Greg Pfeil Date: Mon, 2 Dec 2024 10:25:50 -0700 Subject: [PATCH 3/5] Add structured arg checking to `ParameterType` This allows us to incrementally expand numbered arguments, only doing so when we want a Unison value and not unstructured text. Fixes #2805. --- .../src/Unison/Codebase/Editor/HandleInput.hs | 43 ++-- .../src/Unison/Codebase/Transcript/Runner.hs | 9 +- unison-cli/src/Unison/CommandLine.hs | 238 ++++++++++-------- .../src/Unison/CommandLine/InputPattern.hs | 68 +++-- .../src/Unison/CommandLine/InputPatterns.hs | 101 ++++---- unison-cli/src/Unison/CommandLine/Main.hs | 14 +- unison-src/transcripts-using-base/fix-2805.md | 4 +- .../transcripts-using-base/fix-2805.output.md | 26 +- 8 files changed, 273 insertions(+), 230 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index ab26e91d5c..558f610150 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -714,31 +714,24 @@ loop e = do DebugFuzzyOptionsI command args -> do Cli.Env {codebase} <- ask currentBranch <- Branch.withoutTransitiveLibs <$> Cli.getCurrentBranch0 - maybe - (Cli.respond $ DebugFuzzyOptionsNoCommand command) - ( \IP.InputPattern {params} -> - either (Cli.respond . DebugFuzzyOptionsIncorrectArgs) snd $ - IP.foldArgs - ( \(paramName, IP.ParameterType {fzfResolver}) arg -> - ( *> - if arg == "_" - then - maybe - (Cli.respond DebugFuzzyOptionsNoResolver) - ( \IP.FZFResolver {getOptions} -> do - pp <- Cli.getCurrentProjectPath - results <- liftIO $ getOptions codebase pp currentBranch - Cli.respond (DebugDisplayFuzzyOptions paramName (Text.unpack <$> results)) - ) - fzfResolver - else pure () - ) - ) - (pure ()) - params - args - ) - $ Map.lookup command InputPatterns.patternMap + case Map.lookup command InputPatterns.patternMap of + Just IP.InputPattern {params} -> + either (Cli.respond . DebugFuzzyOptionsIncorrectArgs) (pure . fst) + =<< IP.foldParamsWithM + ( \_ (paramName, IP.ParameterType {fzfResolver}) arg -> + if arg == "_" + then case fzfResolver of + Just IP.FZFResolver {getOptions} -> do + pp <- Cli.getCurrentProjectPath + results <- liftIO $ getOptions codebase pp currentBranch + (,[]) <$> Cli.respond (DebugDisplayFuzzyOptions paramName (Text.unpack <$> results)) + Nothing -> (,[]) <$> Cli.respond DebugFuzzyOptionsNoResolver + else pure ((), []) + ) + () + params + args + Nothing -> Cli.respond $ DebugFuzzyOptionsNoCommand command DebugFormatI -> do env <- ask void $ runMaybeT do diff --git a/unison-cli/src/Unison/Codebase/Transcript/Runner.hs b/unison-cli/src/Unison/Codebase/Transcript/Runner.hs index bde34ed739..9b03a86d4c 100644 --- a/unison-cli/src/Unison/Codebase/Transcript/Runner.hs +++ b/unison-cli/src/Unison/Codebase/Transcript/Runner.hs @@ -48,8 +48,8 @@ import Unison.Codebase.Transcript.Parser qualified as Transcript import Unison.Codebase.Verbosity (Verbosity, isSilent) import Unison.Codebase.Verbosity qualified as Verbosity import Unison.CommandLine -import Unison.CommandLine.InputPattern (InputPattern (aliases, patternName)) -import Unison.CommandLine.InputPatterns (validInputs) +import Unison.CommandLine.InputPattern (aliases, patternName) +import Unison.CommandLine.InputPatterns qualified as IP import Unison.CommandLine.OutputMessages (notifyNumbered, notifyUser) import Unison.CommandLine.Welcome (asciiartUnison) import Unison.Parser.Ann (Ann) @@ -174,7 +174,7 @@ run isTest verbosity dir codebase runtime sbRuntime nRuntime ucmVersion baseURL expectFailure <- newIORef False hasErrors <- newIORef False mBlock <- newIORef Nothing - let patternMap = Map.fromList $ (\p -> (patternName p, p) : ((,p) <$> aliases p)) =<< validInputs + let patternMap = Map.fromList $ (\p -> (patternName p, p) : ((,p) <$> aliases p)) =<< IP.validInputs let output' :: Bool -> Stanza -> IO () output' inputEcho msg = do hide <- hideOutput inputEcho @@ -326,7 +326,8 @@ run isTest verbosity dir codebase runtime sbRuntime nRuntime ucmVersion baseURL liftIO (parseInput codebase curPath getProjectRoot numberedArgs patternMap args) >>= either -- invalid command is treated as a failure - ( \msg -> do + ( \failure -> do + let msg = reportParseFailure failure liftIO $ outputUcmResult msg liftIO $ maybeDieWithMsg msg Cli.returnEarlyWithoutOutput diff --git a/unison-cli/src/Unison/CommandLine.hs b/unison-cli/src/Unison/CommandLine.hs index 1b1cc2df7a..28a699592a 100644 --- a/unison-cli/src/Unison/CommandLine.hs +++ b/unison-cli/src/Unison/CommandLine.hs @@ -3,9 +3,13 @@ {-# LANGUAGE ViewPatterns #-} module Unison.CommandLine - ( allow, + ( ParseFailure (..), + ExpansionFailure (..), + FZFResolveFailure (..), + allow, parseInput, prompt, + reportParseFailure, watchFileSystem, ) where @@ -15,7 +19,7 @@ import Control.Lens hiding (aside) import Control.Monad.Except import Control.Monad.Trans.Except import Data.List (isPrefixOf, isSuffixOf) -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) import Data.Map qualified as Map import Data.Text qualified as Text import Data.Text.IO qualified as Text @@ -29,6 +33,7 @@ import Unison.Codebase.Branch (Branch0) import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Editor.Input (Event (..), Input (..)) import Unison.Codebase.Editor.Output (NumberedArgs) +import Unison.Codebase.Editor.StructuredArgument (StructuredArgument) import Unison.Codebase.ProjectPath qualified as PP import Unison.Codebase.Watch qualified as Watch import Unison.CommandLine.FZFResolvers qualified as FZFResolvers @@ -36,12 +41,10 @@ import Unison.CommandLine.FuzzySelect qualified as Fuzzy import Unison.CommandLine.Helpers (warn) import Unison.CommandLine.InputPattern (InputPattern (..)) import Unison.CommandLine.InputPattern qualified as InputPattern -import Unison.CommandLine.InputPatterns qualified as IPs +import Unison.CommandLine.InputPatterns qualified as IP import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.Symbol (Symbol) -import Unison.Util.ColorText qualified as CT -import Unison.Util.Monoid (foldMapM) import Unison.Util.Pretty qualified as P import Unison.Util.TQueue qualified as Q import UnliftIO.STM @@ -61,6 +64,99 @@ watchFileSystem q dir = do atomically . Q.enqueue q $ UnisonFileChanged (Text.pack filePath) text pure (cancel >> killThread t) +data ExpansionFailure + = TooManyArguments (NonEmpty InputPattern.Argument) + | UnexpectedStructuredArgument StructuredArgument + +-- | Expanding numbers is a bit complicated. Each `Parameter` expects either structured or “unstructured” arguments. So +-- we iterate over the parameters, if it doesn’t want structured, we just preserve the string. If it does want +-- structured, we have to expand the argument, which may result in /multiple/ structured arguments. We take the first +-- one for the param and pass the rest along. Now, if the next param wants unstructured, but we’ve already structured +-- it, then we’ve got an error. +expandArguments :: + NumberedArgs -> + InputPattern.Parameters -> + [String] -> + Either ExpansionFailure (InputPattern.Arguments, InputPattern.Parameters) +expandArguments numberedArgs params = + bimap TooManyArguments (first $ reverse) + <=< InputPattern.foldParamsWithM + ( \acc (_, param) arg -> + if InputPattern.isStructured param + then + pure $ + either + ( maybe (arg : acc, []) (maybe (acc, []) (\(h :| t) -> (h : acc, t)) . nonEmpty . fmap pure) + . expandNumber numberedArgs + ) + ((,[]) . (: acc) . pure) + arg + else (,[]) . (: acc) <$> either (pure . Left) (Left . UnexpectedStructuredArgument) arg + ) + [] + params + . fmap Left + +data ParseFailure + = NoCommand + | UnknownCommand String + | ExpansionFailure String InputPattern ExpansionFailure + | FZFResolveFailure InputPattern FZFResolveFailure + | SubParseFailure String InputPattern (P.Pretty P.ColorText) + +-- | +-- +-- __TODO__: Move this closer to `main`, but right now it’s shared by @ucm@ and @transcripts@, so this is the closest +-- we can get without duplicating it. +reportParseFailure :: ParseFailure -> P.Pretty P.ColorText +reportParseFailure = \case + NoCommand -> "" + UnknownCommand command -> + warn . P.wrap $ + "I don't know how to" + <> P.group (fromString command <> ".") + <> "Type" + <> IP.makeExample' IP.help + <> "or `?` to get help." + ExpansionFailure command pat@InputPattern {params} ef -> case ef of + TooManyArguments extraArgs -> + let showNum n = fromMaybe (tShow n) $ Numeral.us_cardinal defaultInflection n + in wrapFailure command pat + . P.text + . maybe + ( "Internal error: fuzzy finder complained that there are " + <> showNum (length extraArgs) + <> " too many arguments provided, but the command apparently allows an unbounded number of arguments." + ) + ( \maxCount -> + let foundCount = showNum $ maxCount + length extraArgs + in case maxCount of + 0 -> "I expected no arguments, but received " <> foundCount <> "." + _ -> "I expected no more than " <> showNum maxCount <> " arguments, but received " <> foundCount <> "." + ) + $ InputPattern.maxArgs params + UnexpectedStructuredArgument _arg -> "Internal error: Expected a String, but got a structured argument instead." + FZFResolveFailure pat frf -> case frf of + NoFZFResolverForArgumentType _argDesc -> InputPattern.help pat + NoFZFOptions argDesc -> + P.callout "⚠️" $ + "Sorry, I was expecting an argument for the " <> P.text argDesc <> ", and I couldn't find any to suggest to you. 😅" + SubParseFailure command pat msg -> wrapFailure command pat msg + where + wrapFailure command pat msg = + P.warnCallout $ + P.lines + [ P.wrap "Sorry, I wasn’t sure how to process your request:", + "", + P.indentN 2 msg, + "", + P.wrap $ + "You can run" + <> IP.makeExample IP.help [fromString command] + <> "for more information on using" + <> IP.makeExampleEOS pat [] + ] + parseInput :: Codebase IO Symbol Ann -> -- | Current location @@ -74,7 +170,7 @@ parseInput :: [String] -> -- Returns either an error message or the fully expanded arguments list and parsed input. -- If the output is `Nothing`, the user cancelled the input (e.g. ctrl-c) - IO (Either (P.Pretty CT.ColorText) (Maybe (InputPattern.Arguments, Input))) + IO (Either ParseFailure (Maybe (InputPattern.Arguments, Input))) parseInput codebase projPath currentProjectRoot numberedArgs patterns segments = runExceptT do let getCurrentBranch0 :: IO (Branch0 IO) getCurrentBranch0 = do @@ -82,70 +178,24 @@ parseInput codebase projPath currentProjectRoot numberedArgs patterns segments = pure . Branch.head $ Branch.getAt' (projPath ^. PP.path_) projRoot case segments of - [] -> throwE "" + [] -> throwE NoCommand command : args -> case Map.lookup command patterns of - Just pat@(InputPattern {params, help, parse}) -> do - let expandedNumbers :: InputPattern.Arguments - expandedNumbers = - foldMap (\arg -> maybe [Left arg] (fmap pure) $ expandNumber numberedArgs arg) args - lift (fzfResolve codebase projPath getCurrentBranch0 params expandedNumbers) + Just pat@(InputPattern {params, parse}) -> do + (expandedArgs, remainingParams) <- + except . first (ExpansionFailure command pat) $ expandArguments numberedArgs params args + lift (fzfResolve codebase projPath getCurrentBranch0 remainingParams) >>= either - ( \case - NoFZFResolverForArgumentType _argDesc -> throwError help - NoFZFOptions argDesc -> throwError (noCompletionsMessage argDesc) - FZFCancelled -> pure Nothing - FZFOversaturated extraArgs -> do - let showNum n = fromMaybe (tShow n) $ Numeral.us_cardinal defaultInflection n - maxCount <- maybe (throwError . P.text $ "Internal error: fuzzy finder complained that there are " <> showNum (length extraArgs) <> " too many arguments provided, but the command apparently allows an unbounded number of arguments.") pure $ InputPattern.maxArgs params - let foundCount = showNum $ maxCount + length extraArgs - throwError . P.text $ - "I expected no more than " <> showNum maxCount <> " arguments, but received " <> foundCount <> "." - ) - ( \resolvedArgs -> do - parsedInput <- - except - . first - ( \msg -> - P.warnCallout $ - P.wrap "Sorry, I wasn’t sure how to process your request:" - <> P.newline - <> P.newline - <> P.indentN 2 msg - <> P.newline - <> P.newline - <> P.wrap - ( "You can run" - <> IPs.makeExample IPs.help [fromString command] - <> "for more information on using" - <> IPs.makeExampleEOS pat [] - ) - ) - $ parse resolvedArgs - pure $ Just (Left command : resolvedArgs, parsedInput) - ) - Nothing -> - throwE - . warn - . P.wrap - $ "I don't know how to" - <> P.group (fromString command <> ".") - <> "Type" - <> IPs.makeExample' IPs.help - <> "or `?` to get help." - where - noCompletionsMessage argDesc = - P.callout "⚠️" $ - P.lines - [ ( "Sorry, I was expecting an argument for the " - <> P.text argDesc - <> ", and I couldn't find any to suggest to you. 😅" + (throwE . FZFResolveFailure pat) + ( traverse \resolvedArgs -> + let allArgs = expandedArgs <> resolvedArgs + in except . bimap (SubParseFailure command pat) (Left command : allArgs,) $ parse allArgs ) - ] + Nothing -> throwE $ UnknownCommand command -- Expand a numeric argument like `1` or a range like `3-9` expandNumber :: NumberedArgs -> String -> Maybe NumberedArgs expandNumber numberedArgs s = - (\nums -> [arg | i <- nums, Just arg <- [vargs Vector.!? (i - 1)]]) <$> expandedNumber + catMaybes . fmap ((vargs Vector.!?) . pred) <$> expandedNumber where vargs = Vector.fromList numberedArgs rangeRegex = "([0-9]+)-([0-9]+)" :: String @@ -157,67 +207,47 @@ expandNumber numberedArgs s = Nothing -> -- check for a range case (junk, moreJunk, ns) of - ("", "", [from, to]) -> - (\x y -> [x .. y]) <$> readMay from <*> readMay to - _ -> Nothing + ("", "", [from, to]) -> enumFromTo <$> readMay from <*> readMay to + (_, _, _) -> Nothing data FZFResolveFailure = NoFZFResolverForArgumentType InputPattern.ParameterDescription | NoFZFOptions -- | argument description Text - | FZFCancelled - | -- | More arguments were provided than the command supports. - FZFOversaturated - -- | The arguments that couldn’t be assigned to a parameter. - (NonEmpty InputPattern.Argument) fzfResolve :: Codebase IO Symbol Ann -> PP.ProjectPath -> (IO (Branch0 IO)) -> InputPattern.Parameters -> - InputPattern.Arguments -> - IO (Either FZFResolveFailure InputPattern.Arguments) -fzfResolve codebase ppCtx getCurrentBranch params args = runExceptT do - -- We resolve args in two steps, first we check that all arguments that will require a fzf - -- resolver have one, and only if so do we prompt the user to actually do a fuzzy search. - -- Otherwise, we might ask the user to perform a search only to realize we don't have a resolver - -- for a later arg. - let argumentResolvers :: [ExceptT FZFResolveFailure IO InputPattern.Arguments] = - either - (pure . throwError . FZFOversaturated) - ( \(InputPattern.Parameters {requiredParams, trailingParams}, args) -> - args - <> map (meh False) requiredParams - <> case trailingParams of - InputPattern.Optional _ _ -> mempty - InputPattern.OnePlus p -> pure $ meh True p - ) - $ InputPattern.foldArgs (\(_, _) arg acc -> pure [arg] : acc) mempty params args - argumentResolvers & foldMapM id + IO (Either FZFResolveFailure (Maybe InputPattern.Arguments)) +fzfResolve codebase ppCtx getCurrentBranch InputPattern.Parameters {requiredParams, trailingParams} = runExceptT do + -- We build up a list of `ExceptT` inside an outer `ExceptT` to allow us to fail immediately if /any/ required + -- argument is missing a resolver, before we start prompting the user to actually do a fuzzy search. Otherwise, we + -- might ask the user to perform a search only to realize we don't have a resolver for a later arg. + argumentResolvers :: [MaybeT (ExceptT FZFResolveFailure IO) (NonEmpty InputPattern.Argument)] <- + liftA2 (<>) (traverse (maybeFillArg False) requiredParams) case trailingParams of + InputPattern.Optional _ _ -> pure mempty + InputPattern.OnePlus p -> pure <$> maybeFillArg True p + runMaybeT $ foldM (\bs -> ((bs <>) . toList <$>)) [] argumentResolvers where - meh :: Bool -> InputPattern.Parameter -> ExceptT FZFResolveFailure IO InputPattern.Arguments - meh allowMulti (argName, InputPattern.ParameterType {fzfResolver}) = + maybeFillArg allowMulti (argName, InputPattern.ParameterType {fzfResolver}) = maybe (throwError $ NoFZFResolverForArgumentType argName) - (fuzzyFillArg allowMulti argName) + (pure . fuzzyFillArg allowMulti argName) fzfResolver - - fuzzyFillArg :: Bool -> Text -> InputPattern.FZFResolver -> ExceptT FZFResolveFailure IO InputPattern.Arguments - fuzzyFillArg allowMulti argDesc InputPattern.FZFResolver {getOptions} = do + fuzzyFillArg :: + Bool -> Text -> InputPattern.FZFResolver -> MaybeT (ExceptT FZFResolveFailure IO) (NonEmpty InputPattern.Argument) + fuzzyFillArg allowMulti argDesc InputPattern.FZFResolver {getOptions} = MaybeT do currentBranch <- Branch.withoutTransitiveLibs <$> liftIO getCurrentBranch options <- liftIO $ getOptions codebase ppCtx currentBranch when (null options) . throwError $ NoFZFOptions argDesc liftIO $ Text.putStrLn (FZFResolvers.fuzzySelectHeader argDesc) - results <- - liftIO (Fuzzy.fuzzySelect Fuzzy.defaultOptions {Fuzzy.allowMultiSelect = allowMulti} id options) - `whenNothingM` throwError FZFCancelled - -- If the user triggered the fuzzy finder, but selected nothing, abort the command rather than continuing execution - -- with no arguments. - if null results - then throwError FZFCancelled - else pure (Left . Text.unpack <$> results) + results <- liftIO (Fuzzy.fuzzySelect Fuzzy.defaultOptions {Fuzzy.allowMultiSelect = allowMulti} id options) + -- If the user triggered the fuzzy finder, but selected nothing, abort the command rather than continuing + -- execution with no arguments. + pure $ fmap (Left . Text.unpack <$>) . nonEmpty =<< results prompt :: String prompt = "> " diff --git a/unison-cli/src/Unison/CommandLine/InputPattern.hs b/unison-cli/src/Unison/CommandLine/InputPattern.hs index 772a729b9f..c8e8a35341 100644 --- a/unison-cli/src/Unison/CommandLine/InputPattern.hs +++ b/unison-cli/src/Unison/CommandLine/InputPattern.hs @@ -11,8 +11,8 @@ module Unison.CommandLine.InputPattern Parameters (..), Argument, Arguments, - foldArgs, noParams, + foldParamsWithM, paramType, FZFResolver (..), Visibility (..), @@ -89,7 +89,8 @@ data ParameterType = ParameterType m [Line.Completion], -- | If a parameter is marked as required, but no argument is provided, the fuzzy finder will be triggered if -- available. - fzfResolver :: Maybe FZFResolver + fzfResolver :: Maybe FZFResolver, + isStructured :: Bool } type Parameter = (ParameterDescription, ParameterType) @@ -109,30 +110,47 @@ data Parameters = Parameters {requiredParams :: [Parameter], trailingParams :: T noParams :: Parameters noParams = Parameters [] $ Optional [] Nothing --- | Aligns the pattern parameters with a set of concrete arguments. --- --- If too many arguments are provided, it returns the overflow arguments. In addition to the fold result, it returns --- `Parameters` representing what can still be provided (e.g., via fuzzy completion). Note that if the result --- `Parameters` has `OnePlus` or non-`null` `requiredArgs`, the application must fail unless more arguments are --- provided somehow. -foldArgs :: (Parameter -> arg -> a -> a) -> a -> Parameters -> [arg] -> Either (NonEmpty arg) (Parameters, a) -foldArgs fn z Parameters {requiredParams, trailingParams} = foldRequiredArgs requiredParams +-- | Applies concrete arguments to a set of `Parameters`. +foldParamsWithM :: + (Monad m) => + -- | Each step needs to return a new incremental result, but can also return additional arguments to apply in later + -- steps. This allows for the expansion of an argument to multiple arguments, as with numbered arg ranges. + (state -> Parameter -> arg -> m (state, [arg])) -> + -- | The initial state. + state -> + Parameters -> + [arg] -> + -- | If too many arguments are provided, it returns `Left`, with the arguments that couldn’t be assigned to a + -- parameter. Otherwise, it returns a tuple of the `Parameters` that could still be applied to additional arguments + -- (e.g., via fuzzy completion) and the final result. If the returned `Parameters` has remaining required arguments, + -- they must either be provided somehow (e.g., another call to this function or fuzzy completion) or result in a + -- “not enough arguments” error. + m (Either (NonEmpty arg) (state, Parameters)) +foldParamsWithM fn z Parameters {requiredParams, trailingParams} = foldRequiredArgs z requiredParams where - foldRequiredArgs = curry \case - ([], as) -> foldTrailingArgs as - (ps, []) -> pure (Parameters ps trailingParams, z) - (p : ps, a : as) -> fmap (fn p a) <$> foldRequiredArgs ps as - foldTrailingArgs = case trailingParams of - Optional optParams zeroPlus -> foldOptionalArgs zeroPlus optParams - OnePlus param -> foldOnePlusArgs param - foldOptionalArgs zp = curry \case - (ps, []) -> pure (Parameters [] $ Optional ps zp, z) - ([], a : as) -> foldZeroPlusArgs zp $ a :| as - (p : ps, a : as) -> fmap (fn p a) <$> foldOptionalArgs zp ps as - foldZeroPlusArgs = maybe Left (\p -> pure . (Parameters [] . Optional [] $ pure p,) . foldr (fn p) z) - foldOnePlusArgs p = \case - [] -> pure (Parameters [] $ OnePlus p, z) - args -> pure (Parameters [] . Optional [] $ pure p, foldr (fn p) z args) + foldRequiredArgs res = curry \case + ([], as) -> case trailingParams of + Optional optParams zeroPlus -> foldOptionalArgs res zeroPlus optParams as + OnePlus param -> case as of + [] -> pure $ pure (res, Parameters [] $ OnePlus param) + a : args -> foldCatchallArg res param $ a :| args + (ps, []) -> pure $ pure (res, Parameters ps trailingParams) + (p : ps, a : as) -> do + (res', extraArgs) <- fn res p a + foldRequiredArgs res' ps $ extraArgs <> as + foldOptionalArgs res zp = curry \case + (ps, []) -> pure $ pure (res, Parameters [] $ Optional ps zp) + ([], a : as) -> maybe (pure . Left) (foldCatchallArg res) zp $ a :| as + (p : ps, a : as) -> do + (res', extraArgs) <- fn res p a + foldOptionalArgs res' zp ps $ extraArgs <> as + foldCatchallArg res p = + let collectRemainingArgs prevRes = \case + [] -> pure $ pure (prevRes, Parameters [] . Optional [] $ pure p) + a : args -> do + (res', extraArgs) <- fn prevRes p a + collectRemainingArgs res' $ extraArgs <> args + in collectRemainingArgs res . toList paramInfo :: Parameters -> Int -> Maybe (ParameterDescription, ParameterType) paramInfo Parameters {requiredParams, trailingParams} i = diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index b5904cf4a3..8f86503dc0 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -842,7 +842,7 @@ add = "add" [] I.Visible - (Parameters [] . Optional [] $ Just ("definition", noCompletionsArg)) + (Parameters [] . Optional [] $ Just ("definition", exactDefinitionArg)) ( "`add` adds to the codebase all the definitions from the most recently " <> "typechecked file." ) @@ -854,7 +854,7 @@ previewAdd = "add.preview" [] I.Visible - (Parameters [] . Optional [] $ Just ("definition", noCompletionsArg)) + (Parameters [] . Optional [] $ Just ("definition", exactDefinitionArg)) ( "`add.preview` previews additions to the codebase from the most recently " <> "typechecked file. This command only displays cached typechecking " <> "results. Use `load` to reparse & typecheck the file if the context " @@ -884,7 +884,7 @@ updateOldNoPatch = "update.old.nopatch" [] I.Visible - (Parameters [] . Optional [] $ Just ("definition", noCompletionsArg)) + (Parameters [] . Optional [] $ Just ("definition", exactDefinitionArg)) ( P.wrap ( makeExample' updateOldNoPatch <> "works like" @@ -912,7 +912,7 @@ updateOld = "update.old" [] I.Visible - (Parameters [] . Optional [("patch", patchArg)] $ Just ("definition", noCompletionsArg)) + (Parameters [] . Optional [("patch", patchArg)] $ Just ("definition", exactDefinitionArg)) ( P.wrap ( makeExample' updateOld <> "works like" @@ -949,7 +949,7 @@ previewUpdate = "update.old.preview" [] I.Visible - (Parameters [] . Optional [] $ Just ("definition", noCompletionsArg)) + (Parameters [] . Optional [] $ Just ("definition", exactDefinitionArg)) ( "`update.old.preview` previews updates to the codebase from the most " <> "recently typechecked file. This command only displays cached " <> "typechecking results. Use `load` to reparse & typecheck the file if " @@ -1032,16 +1032,11 @@ displayTo = <> "prints a rendered version of the term `foo` to the given file." ) $ \case - file : defs -> - maybe - (wrongArgsLength "at least two arguments" [file]) - ( \defs -> do - file <- unsupportedStructuredArgument displayTo "a file name" file - names <- traverse handleHashQualifiedNameArg defs - pure (Input.DisplayI (Input.FileLocation file Input.AboveFold) names) - ) - $ NE.nonEmpty defs - [] -> wrongArgsLength "at least two arguments" [] + file : def : defs -> do + file <- unsupportedStructuredArgument displayTo "a file name" file + names <- traverse handleHashQualifiedNameArg $ def NE.:| defs + pure (Input.DisplayI (Input.FileLocation file Input.AboveFold) names) + args -> wrongArgsLength "at least two arguments" args docs :: InputPattern docs = @@ -1898,7 +1893,7 @@ debugFuzzyOptions = "debug.fuzzy-options" [] I.Hidden - (Parameters [] $ OnePlus ("command arguments", noCompletionsArg)) + (Parameters [("command", commandNameArg)] . Optional [] $ Just ("arguments", noCompletionsArg)) ( P.lines [ P.wrap $ "This command can be used to test and debug ucm's fuzzy-options within transcripts.", P.wrap $ "Write a command invocation with _ for any args you'd like to see completion options for.", @@ -1908,7 +1903,7 @@ debugFuzzyOptions = ] ) \case - (cmd : args) -> + cmd : args -> Input.DebugFuzzyOptionsI <$> unsupportedStructuredArgument debugFuzzyOptions "a command" cmd <*> traverse (unsupportedStructuredArgument debugFuzzyOptions "text") args @@ -2469,7 +2464,8 @@ newBranchNameArg = ParameterType { typeName = "new-branch", suggestions = \_ _ _ _ -> pure [], - fzfResolver = Nothing + fzfResolver = Nothing, + isStructured = False } topicNameArg :: ParameterType @@ -2478,7 +2474,8 @@ topicNameArg = in ParameterType { typeName = "topic", suggestions = \q _ _ _ -> pure (exactComplete q topics), - fzfResolver = Just $ Resolvers.fuzzySelectFromList (Text.pack <$> topics) + fzfResolver = Just $ Resolvers.fuzzySelectFromList (Text.pack <$> topics), + isStructured = False } helpTopics :: InputPattern @@ -2489,7 +2486,7 @@ helpTopics = I.Visible (Parameters [] $ Optional [("topic", topicNameArg)] Nothing) ("`help-topics` lists all topics and `help-topics ` shows an explanation of that topic.") - ( \case + \case [] -> Right $ Input.CreateMessage topics [topic] -> do topic <- unsupportedStructuredArgument helpTopics "a help topic" topic @@ -2497,7 +2494,6 @@ helpTopics = Nothing -> Left $ "I don't know of that topic. Try `help-topics`." Just t -> Right $ Input.CreateMessage t _ -> Left $ "Use `help-topics ` or `help-topics`." - ) where topics = P.callout "🌻" $ @@ -3056,7 +3052,7 @@ execute = ) ] ) - $ \case + \case main : args -> Input.ExecuteI <$> handleHashQualifiedNameArg main @@ -3164,7 +3160,7 @@ makeStandalone = ) ] ) - $ \case + \case [main, file] -> Input.MakeStandaloneI <$> unsupportedStructuredArgument makeStandalone "a file name" file @@ -3186,7 +3182,7 @@ runScheme = ) ] ) - $ \case + \case main : args -> Input.ExecuteSchemeI <$> handleHashQualifiedNameArg main @@ -3752,7 +3748,8 @@ commandNameArg = in ParameterType { typeName = "command", suggestions = \q _ _ _ -> pure (exactComplete q options), - fzfResolver = Just $ Resolvers.fuzzySelectFromList (Text.pack <$> options) + fzfResolver = Just $ Resolvers.fuzzySelectFromList (Text.pack <$> options), + isStructured = False } exactDefinitionArg :: ParameterType @@ -3760,7 +3757,8 @@ exactDefinitionArg = ParameterType { typeName = "definition", suggestions = \q cb _http p -> Codebase.runTransaction cb (prefixCompleteTermOrType q p), - fzfResolver = Just Resolvers.definitionResolver + fzfResolver = Just Resolvers.definitionResolver, + isStructured = True } definitionQueryArg :: ParameterType @@ -3771,7 +3769,8 @@ exactDefinitionTypeQueryArg = ParameterType { typeName = "type definition query", suggestions = \q cb _http p -> Codebase.runTransaction cb (prefixCompleteType q p), - fzfResolver = Just Resolvers.typeDefinitionResolver + fzfResolver = Just Resolvers.typeDefinitionResolver, + isStructured = True } exactDefinitionTypeOrTermQueryArg :: ParameterType @@ -3779,7 +3778,8 @@ exactDefinitionTypeOrTermQueryArg = ParameterType { typeName = "type or term definition query", suggestions = \q cb _http p -> Codebase.runTransaction cb (prefixCompleteTermOrType q p), - fzfResolver = Just Resolvers.definitionResolver + fzfResolver = Just Resolvers.definitionResolver, + isStructured = True } exactDefinitionTermQueryArg :: ParameterType @@ -3787,7 +3787,8 @@ exactDefinitionTermQueryArg = ParameterType { typeName = "term definition query", suggestions = \q cb _http p -> Codebase.runTransaction cb (prefixCompleteTerm q p), - fzfResolver = Just Resolvers.termDefinitionResolver + fzfResolver = Just Resolvers.termDefinitionResolver, + isStructured = True } patchArg :: ParameterType @@ -3795,7 +3796,8 @@ patchArg = ParameterType { typeName = "patch", suggestions = \q cb _http p -> Codebase.runTransaction cb (prefixCompletePatch q p), - fzfResolver = Nothing + fzfResolver = Nothing, + isStructured = True } namespaceArg :: ParameterType @@ -3803,7 +3805,8 @@ namespaceArg = ParameterType { typeName = "namespace", suggestions = \q cb _http p -> Codebase.runTransaction cb (prefixCompleteNamespace q p), - fzfResolver = Just Resolvers.namespaceResolver + fzfResolver = Just Resolvers.namespaceResolver, + isStructured = True } -- | Usually you'll want one or the other, but some commands support both right now. @@ -3817,7 +3820,8 @@ namespaceOrProjectBranchArg config = [ projectAndOrBranchSuggestions config, namespaceSuggestions ], - fzfResolver = Just Resolvers.projectOrBranchResolver + fzfResolver = Just Resolvers.projectOrBranchResolver, + isStructured = True } namespaceOrDefinitionArg :: ParameterType @@ -3829,7 +3833,8 @@ namespaceOrDefinitionArg = termsTypes <- prefixCompleteTermOrType q p pure (List.nubOrd $ namespaces <> termsTypes), fzfResolver = - Just Resolvers.namespaceOrDefinitionResolver + Just Resolvers.namespaceOrDefinitionResolver, + isStructured = True } -- | A dependency name. E.g. if your project has `lib.base`, `base` would be a dependency @@ -3840,7 +3845,8 @@ dependencyArg = { typeName = "project dependency", suggestions = \q cb _http pp -> Codebase.runTransaction cb do prefixCompleteNamespace q (pp & PP.path_ .~ Path.singleton NameSegment.libSegment), - fzfResolver = Just Resolvers.projectDependencyResolver + fzfResolver = Just Resolvers.projectDependencyResolver, + isStructured = True } newNameArg :: ParameterType @@ -3848,7 +3854,8 @@ newNameArg = ParameterType { typeName = "new-name", suggestions = \q cb _http p -> Codebase.runTransaction cb (prefixCompleteNamespace q p), - fzfResolver = Nothing + fzfResolver = Nothing, + isStructured = True } noCompletionsArg :: ParameterType @@ -3856,7 +3863,8 @@ noCompletionsArg = ParameterType { typeName = "word", suggestions = noCompletions, - fzfResolver = Nothing + fzfResolver = Nothing, + isStructured = False } filePathArg :: ParameterType @@ -3864,7 +3872,8 @@ filePathArg = ParameterType { typeName = "file-path", suggestions = noCompletions, - fzfResolver = Nothing + fzfResolver = Nothing, + isStructured = False } -- | Refers to a namespace on some remote code host. @@ -3873,7 +3882,8 @@ remoteNamespaceArg = ParameterType { typeName = "remote-namespace", suggestions = \input _cb http _p -> sharePathCompletion http input, - fzfResolver = Nothing + fzfResolver = Nothing, + isStructured = True } profileArg :: ParameterType @@ -3882,7 +3892,8 @@ profileArg = { typeName = "profile", suggestions = \_input _cb _http _p -> pure [Line.simpleCompletion "profile"], - fzfResolver = Nothing + fzfResolver = Nothing, + isStructured = False } data ProjectInclusion = OnlyWithinCurrentProject | OnlyOutsideCurrentProject | AllProjects @@ -4201,7 +4212,8 @@ projectAndBranchNamesArg config = ParameterType { typeName = "project-and-branch-names", suggestions = projectAndOrBranchSuggestions config, - fzfResolver = Just Resolvers.projectAndOrBranchArg + fzfResolver = Just Resolvers.projectAndOrBranchArg, + isStructured = True } -- | A project branch name. @@ -4210,7 +4222,8 @@ projectBranchNameArg config = ParameterType { typeName = "project-branch-name", suggestions = projectAndOrBranchSuggestions config, - fzfResolver = Just Resolvers.projectBranchResolver + fzfResolver = Just Resolvers.projectBranchResolver, + isStructured = True } branchRelativePathArg :: ParameterType @@ -4218,7 +4231,8 @@ branchRelativePathArg = ParameterType { typeName = "branch-relative-path", suggestions = branchRelativePathSuggestions config, - fzfResolver = Nothing + fzfResolver = Nothing, + isStructured = True } where config = @@ -4234,7 +4248,8 @@ projectNameArg = ParameterType { typeName = "project-name", suggestions = \input codebase _httpClient _path -> projectNameSuggestions NoSlash input codebase, - fzfResolver = Just $ Resolvers.multiResolver [Resolvers.projectNameOptions] + fzfResolver = Just $ Resolvers.multiResolver [Resolvers.projectNameOptions], + isStructured = True } data OptionalSlash diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index 97af0ba88e..61fe87e3a1 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -81,7 +81,11 @@ getUserInput codebase authHTTPClient pp currentProjectRoot numberedArgs = codeserverPrompt :: String codeserverPrompt = if isCustomCodeserver Codeserver.defaultCodeserver - then "🌐" <> Codeserver.codeserverRegName Codeserver.defaultCodeserver <> maybe "" (":" <>) (show <$> Codeserver.codeserverPort Codeserver.defaultCodeserver) <> "\n" + then + "🌐" + <> Codeserver.codeserverRegName Codeserver.defaultCodeserver + <> maybe "" (":" <>) (show <$> Codeserver.codeserverPort Codeserver.defaultCodeserver) + <> "\n" else "" go :: Line.InputT IO Input @@ -95,11 +99,11 @@ getUserInput codebase authHTTPClient pp currentProjectRoot numberedArgs = [] -> go ws -> do liftIO (parseInput codebase pp currentProjectRoot numberedArgs IP.patternMap ws) >>= \case - Left msg -> do + Left failure -> do -- We still add history that failed to parse so the user can easily reload -- the input and fix it. - Line.modifyHistory $ Line.addHistoryUnlessConsecutiveDupe $ l - liftIO $ putPrettyLn msg + Line.modifyHistory $ Line.addHistoryUnlessConsecutiveDupe l + liftIO . putPrettyLn $ reportParseFailure failure go Right Nothing -> do -- Ctrl-c or some input cancel, re-run the prompt @@ -109,7 +113,7 @@ getUserInput codebase authHTTPClient pp currentProjectRoot numberedArgs = expandedArgsStr = unwords expandedArgs' when (expandedArgs' /= ws) $ do liftIO . putStrLn $ fullPrompt <> expandedArgsStr - Line.modifyHistory $ Line.addHistoryUnlessConsecutiveDupe $ expandedArgsStr + Line.modifyHistory $ Line.addHistoryUnlessConsecutiveDupe expandedArgsStr pure i settings :: Line.Settings IO settings = diff --git a/unison-src/transcripts-using-base/fix-2805.md b/unison-src/transcripts-using-base/fix-2805.md index 8cbe4d580c..80e8198b3c 100644 --- a/unison-src/transcripts-using-base/fix-2805.md +++ b/unison-src/transcripts-using-base/fix-2805.md @@ -8,13 +8,13 @@ main _ = First we run it with no numbered results in the history, so if number expansion is applied, it should end up calling `main` with zero args, whereas without number expansion, we get a single argument, “1”, passed to it. -``` ucm :bug +``` ucm scratch/main> run main 1 ``` Now we set it up so there _are_ numbered results in the history. If number expansion is applied here, we will get an error “`run` can’t accept a numbered argument […]”, and otherwise our expected "1". -``` ucm :bug +``` ucm scratch/main> find.all isLeft scratch/main> run main 1 ``` diff --git a/unison-src/transcripts-using-base/fix-2805.output.md b/unison-src/transcripts-using-base/fix-2805.output.md index 48b8e2c51d..fddc6702d9 100644 --- a/unison-src/transcripts-using-base/fix-2805.output.md +++ b/unison-src/transcripts-using-base/fix-2805.output.md @@ -20,38 +20,20 @@ main _ = First we run it with no numbered results in the history, so if number expansion is applied, it should end up calling `main` with zero args, whereas without number expansion, we get a single argument, “1”, passed to it. -``` ucm :bug +``` ucm scratch/main> run main 1 - 💔💥 - - I've encountered a call to builtin.bug with the following - value: - - "definitely passed an arg" - - Stack trace: - bug - main - #ra2ebfober + () ``` Now we set it up so there *are* numbered results in the history. If number expansion is applied here, we will get an error “`run` can’t accept a numbered argument \[…\]”, and otherwise our expected "1". -``` ucm :bug +``` ucm scratch/main> find.all isLeft 1. Either.isLeft : Either a b -> Boolean scratch/main> run main 1 - ⚠️ - - Sorry, I wasn’t sure how to process your request: - - `run` can’t accept a numbered argument for a command-line - argument and it’s not yet possible to provide un-expanded - numbers as arguments. - - You can run `help run` for more information on using `run`. + () ``` From 9d76d9a4a84109319cdc72ff629a69dd6bf3e896 Mon Sep 17 00:00:00 2001 From: Greg Pfeil Date: Tue, 14 Jan 2025 15:22:44 -0700 Subject: [PATCH 4/5] Simplify `InputPattern` parsers MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Now that the arguments to `parse` are universally checked, the individual parsers don’t need to handle the cases as precisely. --- .../src/Unison/CommandLine/InputPatterns.hs | 181 +++++++----------- 1 file changed, 68 insertions(+), 113 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 8f86503dc0..982b756490 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -755,8 +755,7 @@ mergeBuiltins = "Adds the builtins (excluding `io` and misc) to the specified namespace. Defaults to `builtin.`" \case [] -> pure . Input.MergeBuiltinsI $ Nothing - [p] -> Input.MergeBuiltinsI . Just <$> handlePathArg p - args -> wrongArgsLength "no more than one argument" args + p : _ -> Input.MergeBuiltinsI . Just <$> handlePathArg p mergeIOBuiltins :: InputPattern mergeIOBuiltins = @@ -768,8 +767,7 @@ mergeIOBuiltins = "Adds all the builtins, including `io` and misc., to the specified namespace. Defaults to `builtin.`" \case [] -> pure . Input.MergeIOBuiltinsI $ Nothing - [p] -> Input.MergeIOBuiltinsI . Just <$> handlePathArg p - args -> wrongArgsLength "no more than one argument" args + p : _ -> Input.MergeIOBuiltinsI . Just <$> handlePathArg p updateBuiltins :: InputPattern updateBuiltins = @@ -817,8 +815,7 @@ load = ) \case [] -> pure $ Input.LoadI Nothing - [file] -> Input.LoadI . Just <$> unsupportedStructuredArgument load "a file name" file - args -> wrongArgsLength "no more than one argument" args + file : _ -> Input.LoadI . Just <$> unsupportedStructuredArgument load "a file name" file clear :: InputPattern clear = @@ -1073,8 +1070,7 @@ ui = help = P.wrap "`ui` opens the Local UI in the default browser.", parse = \case [] -> pure $ Input.UiI Path.relativeEmpty' - [path] -> Input.UiI <$> handlePath'Arg path - args -> wrongArgsLength "no more than one argument" args + path : _ -> Input.UiI <$> handlePath'Arg path } undo :: InputPattern @@ -1097,7 +1093,6 @@ textfind allowLib = then ("text.find.all", ["grep.all"], "Use `text.find` to exclude `lib` from search.") else ("text.find", ["grep"], "Use `text.find.all` to include search of `lib`.") parse = \case - [] -> Left (P.text "Please supply at least one token.") words -> pure $ Input.TextFindI allowLib (untokenize $ [e | Left e <- words]) msg = P.lines @@ -1139,7 +1134,7 @@ sfind = parse where parse = \case - [q] -> Input.StructuredFindI (Input.FindLocal Path.relativeEmpty') <$> handleHashQualifiedNameArg q + q : _ -> Input.StructuredFindI (Input.FindLocal Path.relativeEmpty') <$> handleHashQualifiedNameArg q args -> wrongArgsLength "exactly one argument" args msg = P.lines @@ -1176,7 +1171,7 @@ sfindReplace = msg parse where - parse [q] = Input.StructuredFindReplaceI <$> handleHashQualifiedNameArg q + parse (q : _) = Input.StructuredFindReplaceI <$> handleHashQualifiedNameArg q parse args = wrongArgsLength "exactly one argument" args msg :: P.Pretty CT.ColorText msg = @@ -1288,8 +1283,7 @@ findShallow = ) ( fmap Input.FindShallowI . \case [] -> pure Path.relativeEmpty' - [path] -> handlePath'Arg path - args -> wrongArgsLength "no more than one argument" args + path : _ -> handlePath'Arg path ) findVerbose :: InputPattern @@ -1327,7 +1321,7 @@ renameTerm = ) "`move.term foo bar` renames `foo` to `bar`." \case - [oldName, newName] -> Input.MoveTermI <$> handleHashQualifiedSplit'Arg oldName <*> handleNewName newName + oldName : newName : _ -> Input.MoveTermI <$> handleHashQualifiedSplit'Arg oldName <*> handleNewName newName _ -> Left $ P.wrap "`rename.term` takes two arguments, like `rename.term oldname newname`." moveAll :: InputPattern @@ -1339,7 +1333,7 @@ moveAll = (Parameters [("definition to move", namespaceOrDefinitionArg), ("new location", newNameArg)] $ Optional [] Nothing) "`move foo bar` renames the term, type, and namespace foo to bar." \case - [oldName, newName] -> Input.MoveAllI <$> handlePath'Arg oldName <*> handleNewPath newName + oldName : newName : _ -> Input.MoveAllI <$> handlePath'Arg oldName <*> handleNewPath newName _ -> Left $ P.wrap "`move` takes two arguments, like `move oldname newname`." renameType :: InputPattern @@ -1351,7 +1345,7 @@ renameType = (Parameters [("type to move", exactDefinitionTypeQueryArg), ("new location", newNameArg)] $ Optional [] Nothing) "`move.type foo bar` renames `foo` to `bar`." \case - [oldName, newName] -> Input.MoveTypeI <$> handleHashQualifiedSplit'Arg oldName <*> handleNewName newName + oldName : newName : _ -> Input.MoveTypeI <$> handleHashQualifiedSplit'Arg oldName <*> handleNewName newName _ -> Left $ P.wrap "`rename.type` takes two arguments, like `rename.type oldname newname`." @@ -1379,22 +1373,13 @@ deleteGen suffix queryCompletionArg target mkTarget = "" ) ] - warning = - P.sep - " " - [ backtick (P.string cmd), - "takes an argument, like", - backtick (P.sep " " [P.string cmd, "name"]) <> "." - ] in InputPattern cmd [] I.Visible (Parameters [] $ OnePlus ("definition to delete", queryCompletionArg)) info - \case - [] -> Left $ P.wrap warning - queries -> Input.DeleteI . mkTarget <$> traverse handleHashQualifiedSplit'Arg queries + $ fmap (Input.DeleteI . mkTarget) . traverse handleHashQualifiedSplit'Arg delete :: InputPattern delete = deleteGen Nothing exactDefinitionTypeOrTermQueryArg "term or type" (DeleteTarget'TermOrType DeleteOutput'NoDiff) @@ -1426,7 +1411,7 @@ deleteProject = [ ("`delete.project foo`", "deletes the local project `foo`") ], parse = \case - [name] -> Input.DeleteI . DeleteTarget'Project <$> handleProjectArg name + name : _ -> Input.DeleteI . DeleteTarget'Project <$> handleProjectArg name args -> wrongArgsLength "exactly one argument" args } @@ -1443,7 +1428,7 @@ deleteBranch = ("`delete.branch /bar`", "deletes the branch `bar` in the current project") ], parse = \case - [name] -> Input.DeleteI . DeleteTarget'ProjectBranch <$> handleMaybeProjectBranchArg name + name : _ -> Input.DeleteI . DeleteTarget'ProjectBranch <$> handleMaybeProjectBranchArg name args -> wrongArgsLength "exactly one argument" args } where @@ -1464,7 +1449,7 @@ aliasTerm = Parameters [("term to alias", exactDefinitionTermQueryArg), ("alias name", newNameArg)] $ Optional [] Nothing, help = "`alias.term foo bar` introduces `bar` with the same definition as `foo`.", parse = \case - [oldName, newName] -> Input.AliasTermI False <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName + oldName : newName : _ -> Input.AliasTermI False <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName _ -> Left $ P.wrap "`alias.term` takes two arguments, like `alias.term oldname newname`." } @@ -1478,7 +1463,7 @@ debugAliasTermForce = Parameters [("term to alias", exactDefinitionTermQueryArg), ("alias name", newNameArg)] $ Optional [] Nothing, help = "`debug.alias.term.force foo bar` introduces `bar` with the same definition as `foo`.", parse = \case - [oldName, newName] -> Input.AliasTermI True <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName + oldName : newName : _ -> Input.AliasTermI True <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName _ -> Left $ P.wrap "`debug.alias.term.force` takes two arguments, like `debug.alias.term.force oldname newname`." @@ -1493,7 +1478,7 @@ aliasType = (Parameters [("type to alias", exactDefinitionTypeQueryArg), ("alias name", newNameArg)] $ Optional [] Nothing) "`alias.type Foo Bar` introduces `Bar` with the same definition as `Foo`." \case - [oldName, newName] -> Input.AliasTypeI False <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName + oldName : newName : _ -> Input.AliasTypeI False <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName _ -> Left $ P.wrap "`alias.type` takes two arguments, like `alias.type oldname newname`." debugAliasTypeForce :: InputPattern @@ -1648,9 +1633,8 @@ history = ] ) \case - [src] -> Input.HistoryI (Just 10) (Just 10) <$> handleBranchIdArg src [] -> pure $ Input.HistoryI (Just 10) (Just 10) (BranchAtPath Path.currentPath) - args -> wrongArgsLength "no more than one argument" args + src : _ -> Input.HistoryI (Just 10) (Just 10) <$> handleBranchIdArg src forkLocal :: InputPattern forkLocal = @@ -1802,7 +1786,7 @@ pullImpl name aliases pullMode addendum = do [sourceArg] -> do source <- handlePullSourceArg sourceArg pure (Input.PullI (Input.PullSourceTarget1 source) pullMode) - [sourceArg, targetArg] -> + sourceArg : targetArg : _ -> -- You used to be able to pull into a path, so this arg parser is a little complicated, because -- we want to provide helpful suggestions if you are doing a deprecated or invalid thing. case ( handlePullSourceArg sourceArg, @@ -1855,7 +1839,6 @@ pullImpl name aliases pullMode addendum = do <> " namespace, but the " <> makeExample' pull <> " command only supports merging into the top level of a local project branch." - args -> wrongArgsLength "no more than two arguments" args } debugTabCompletion :: InputPattern @@ -1921,10 +1904,8 @@ debugFormat = makeExample' debugFormat ] ) - ( \case - [] -> Right Input.DebugFormatI - args -> wrongArgsLength "no arguments" args - ) + . const + $ pure Input.DebugFormatI push :: InputPattern push = @@ -1972,9 +1953,8 @@ push = . \case [] -> pure Input.PushSourceTarget0 [targetStr] -> Input.PushSourceTarget1 <$> handlePushTargetArg targetStr - [targetStr, sourceStr] -> + targetStr : sourceStr : _ -> Input.PushSourceTarget2 <$> handlePushSourceArg sourceStr <*> handlePushTargetArg targetStr - args -> wrongArgsLength "no more than two arguments" args where suggestionsConfig = ProjectBranchSuggestionsConfig @@ -2026,9 +2006,8 @@ pushCreate = . \case [] -> pure Input.PushSourceTarget0 [targetStr] -> Input.PushSourceTarget1 <$> handlePushTargetArg targetStr - [targetStr, sourceStr] -> + targetStr : sourceStr : _ -> Input.PushSourceTarget2 <$> handlePushSourceArg sourceStr <*> handlePushTargetArg targetStr - args -> wrongArgsLength "no more than two arguments" args where suggestionsConfig = ProjectBranchSuggestionsConfig @@ -2060,9 +2039,8 @@ pushForce = . \case [] -> pure Input.PushSourceTarget0 [targetStr] -> Input.PushSourceTarget1 <$> handlePushTargetArg targetStr - [targetStr, sourceStr] -> + targetStr : sourceStr : _ -> Input.PushSourceTarget2 <$> handlePushSourceArg sourceStr <*> handlePushTargetArg targetStr - args -> wrongArgsLength "no more than two arguments" args where suggestionsConfig = ProjectBranchSuggestionsConfig @@ -2104,9 +2082,8 @@ pushExhaustive = . \case [] -> pure Input.PushSourceTarget0 [targetStr] -> Input.PushSourceTarget1 <$> handlePushTargetArg targetStr - [targetStr, sourceStr] -> + targetStr : sourceStr : _ -> Input.PushSourceTarget2 <$> handlePushSourceArg sourceStr <*> handlePushTargetArg targetStr - args -> wrongArgsLength "no more than two arguments" args where suggestionsConfig = ProjectBranchSuggestionsConfig @@ -2283,11 +2260,10 @@ diffNamespace = ) ] ) - ( \case - [before, after] -> Input.DiffNamespaceI <$> handleBranchId2Arg before <*> handleBranchId2Arg after - [before] -> Input.DiffNamespaceI <$> handleBranchId2Arg before <*> pure (Right . UnqualifiedPath $ Path.currentPath) - args -> wrongArgsLength "one or two arguments" args - ) + \case + [before, after] -> Input.DiffNamespaceI <$> handleBranchId2Arg before <*> handleBranchId2Arg after + [before] -> Input.DiffNamespaceI <$> handleBranchId2Arg before <*> pure (Right . UnqualifiedPath $ Path.currentPath) + args -> wrongArgsLength "one or two arguments" args where suggestionsConfig = ProjectBranchSuggestionsConfig @@ -2314,12 +2290,11 @@ mergeOldPreviewInputPattern = ) ] ) - ( \case - [src] -> Input.PreviewMergeLocalBranchI <$> handleBranchRelativePathArg src <*> pure Nothing - [src, dest] -> - Input.PreviewMergeLocalBranchI <$> handleBranchRelativePathArg src <*> (Just <$> handleBranchRelativePathArg dest) - args -> wrongArgsLength "one or two arguments" args - ) + \case + [src] -> Input.PreviewMergeLocalBranchI <$> handleBranchRelativePathArg src <*> pure Nothing + [src, dest] -> + Input.PreviewMergeLocalBranchI <$> handleBranchRelativePathArg src <*> (Just <$> handleBranchRelativePathArg dest) + args -> wrongArgsLength "one or two arguments" args where suggestionsConfig = ProjectBranchSuggestionsConfig @@ -2354,11 +2329,9 @@ branchReflog = "`reflog /mybranch` lists all the changes that have affected /mybranch." ] ) - ( \case - [] -> pure $ Input.ShowProjectBranchReflogI Nothing - [branchRef] -> Input.ShowProjectBranchReflogI <$> (Just <$> handleMaybeProjectBranchArg branchRef) - _ -> Left (I.help branchReflog) - ) + \case + [] -> pure $ Input.ShowProjectBranchReflogI Nothing + branchRef : _ -> Input.ShowProjectBranchReflogI <$> (Just <$> handleMaybeProjectBranchArg branchRef) projectReflog :: InputPattern projectReflog = @@ -2372,11 +2345,9 @@ projectReflog = "`project.reflog myproject` lists all the changes that have affected any branches in myproject." ] ) - ( \case - [] -> pure $ Input.ShowProjectReflogI Nothing - [projectRef] -> Input.ShowProjectReflogI <$> (Just <$> handleProjectArg projectRef) - _ -> Left (I.help projectReflog) - ) + \case + [] -> pure $ Input.ShowProjectReflogI Nothing + projectRef : _ -> Input.ShowProjectReflogI <$> (Just <$> handleProjectArg projectRef) globalReflog :: InputPattern globalReflog = @@ -2487,13 +2458,12 @@ helpTopics = (Parameters [] $ Optional [("topic", topicNameArg)] Nothing) ("`help-topics` lists all topics and `help-topics ` shows an explanation of that topic.") \case - [] -> Right $ Input.CreateMessage topics - [topic] -> do - topic <- unsupportedStructuredArgument helpTopics "a help topic" topic - case Map.lookup topic helpTopicsMap of - Nothing -> Left $ "I don't know of that topic. Try `help-topics`." - Just t -> Right $ Input.CreateMessage t - _ -> Left $ "Use `help-topics ` or `help-topics`." + [] -> Right $ Input.CreateMessage topics + topic : _ -> do + topic <- unsupportedStructuredArgument helpTopics "a help topic" topic + case Map.lookup topic helpTopicsMap of + Nothing -> Left $ "I don't know of that topic. Try `help-topics`." + Just t -> Right $ Input.CreateMessage t where topics = P.callout "🌻" $ @@ -2670,13 +2640,8 @@ help = (Parameters [] $ Optional [("command", commandNameArg)] Nothing) "`help` shows general help and `help ` shows help for one command." $ \case - [] -> - Right . Input.CreateMessage $ - intercalateMap - "\n\n" - showPatternHelp - visibleInputs - [cmd] -> do + [] -> Right . Input.CreateMessage $ intercalateMap "\n\n" showPatternHelp visibleInputs + cmd : _ -> do cmd <- unsupportedStructuredArgument help "a command" cmd case (Map.lookup cmd commandsByName, isHelp cmd) of (Nothing, Just msg) -> Right $ Input.CreateMessage msg @@ -2695,7 +2660,6 @@ help = <> "use" <> makeExample helpTopics [P.string cmd] ) - _ -> Left "Use `help ` or `help`." where commandsByName = Map.fromList $ do @@ -2723,7 +2687,7 @@ names isGlobal = I.Visible (Parameters [("name or hash", definitionQueryArg)] $ Optional [] Nothing) (P.wrap $ makeExample (names isGlobal) ["foo"] <> description) - $ \case + \case [thing] -> Input.NamesI isGlobal <$> handleHashQualifiedNameArg thing args -> wrongArgsLength "exactly one argument" args where @@ -2740,7 +2704,7 @@ dependents = I.Visible (Parameters [("definition", definitionQueryArg)] $ Optional [] Nothing) "List the named dependents of the specified definition." - $ \case + \case [thing] -> Input.ListDependentsI <$> handleHashQualifiedNameArg thing args -> wrongArgsLength "exactly one argument" args dependencies = @@ -2750,7 +2714,7 @@ dependencies = I.Visible (Parameters [("definition", definitionQueryArg)] $ Optional [] Nothing) "List the dependencies of the specified definition." - $ \case + \case [thing] -> Input.ListDependenciesI <$> handleHashQualifiedNameArg thing args -> wrongArgsLength "exactly one argument" args @@ -2762,10 +2726,9 @@ namespaceDependencies = I.Visible (Parameters [] $ Optional [("namespace", namespaceArg)] Nothing) "List the external dependencies of the specified namespace." - $ \case - [p] -> Input.NamespaceDependenciesI . pure <$> handlePath'Arg p + \case [] -> pure (Input.NamespaceDependenciesI Nothing) - args -> wrongArgsLength "no more than one argument" args + p : _ -> Input.NamespaceDependenciesI . pure <$> handlePath'Arg p debugNumberedArgs :: InputPattern debugNumberedArgs = @@ -2819,10 +2782,9 @@ debugTerm = I.Hidden (Parameters [("term", exactDefinitionTermQueryArg)] $ Optional [] Nothing) "View debugging information for a given term." - ( \case - [thing] -> Input.DebugTermI False <$> handleHashQualifiedNameArg thing - args -> wrongArgsLength "exactly one argument" args - ) + \case + [thing] -> Input.DebugTermI False <$> handleHashQualifiedNameArg thing + args -> wrongArgsLength "exactly one argument" args debugTermVerbose :: InputPattern debugTermVerbose = @@ -2832,10 +2794,9 @@ debugTermVerbose = I.Hidden (Parameters [("term", exactDefinitionTermQueryArg)] $ Optional [] Nothing) "View verbose debugging information for a given term." - ( \case - [thing] -> Input.DebugTermI True <$> handleHashQualifiedNameArg thing - args -> wrongArgsLength "exactly one argument" args - ) + \case + [thing] -> Input.DebugTermI True <$> handleHashQualifiedNameArg thing + args -> wrongArgsLength "exactly one argument" args debugType :: InputPattern debugType = @@ -2845,10 +2806,9 @@ debugType = I.Hidden (Parameters [("type", exactDefinitionTypeQueryArg)] $ Optional [] Nothing) "View debugging information for a given type." - ( \case - [thing] -> Input.DebugTypeI <$> handleHashQualifiedNameArg thing - args -> wrongArgsLength "exactly one argument" args - ) + \case + [thing] -> Input.DebugTypeI <$> handleHashQualifiedNameArg thing + args -> wrongArgsLength "exactly one argument" args debugLSPFoldRanges :: InputPattern debugLSPFoldRanges = @@ -2922,8 +2882,7 @@ test = ) . \case [] -> pure Path.empty - [pathString] -> handlePathArg pathString - args -> wrongArgsLength "no more than one argument" args + pathString : _ -> handlePathArg pathString } testNative :: InputPattern @@ -2954,8 +2913,7 @@ testNative = ) . \case [] -> pure Path.empty - [pathString] -> handlePathArg pathString - args -> wrongArgsLength "no more than one argument" args + pathString : _ -> handlePathArg pathString } testAll :: InputPattern @@ -3069,7 +3027,7 @@ saveExecuteResult = ( "`add.run name` adds to the codebase the result of the most recent `run` command" <> " as `name`." ) - $ \case + \case [w] -> Input.SaveExecuteResultI <$> handleNameArg w args -> wrongArgsLength "exactly one argument" args @@ -3207,7 +3165,7 @@ compileScheme = ) ] ) - $ \case + \case [main, file] -> mkCompileScheme False file main [main, file, prof] -> do unsupportedStructuredArgument compileScheme "profile" prof @@ -3300,8 +3258,7 @@ projectCreate = ], parse = \case [] -> pure $ Input.ProjectCreateI True Nothing - [name] -> Input.ProjectCreateI True . pure <$> handleProjectArg name - args -> wrongArgsLength "no more than one argument" args + name : _ -> Input.ProjectCreateI True . pure <$> handleProjectArg name } projectCreateEmptyInputPattern :: InputPattern @@ -3318,8 +3275,7 @@ projectCreateEmptyInputPattern = ], parse = \case [] -> pure $ Input.ProjectCreateI False Nothing - [name] -> Input.ProjectCreateI False . pure <$> handleProjectArg name - args -> wrongArgsLength "no more than one argument" args + name : _ -> Input.ProjectCreateI False . pure <$> handleProjectArg name } projectRenameInputPattern :: InputPattern @@ -3391,8 +3347,7 @@ branchesInputPattern = ], parse = \case [] -> Right (Input.BranchesI Nothing) - [nameString] -> Input.BranchesI . pure <$> handleProjectArg nameString - args -> wrongArgsLength "no more than one argument" args + nameString : _ -> Input.BranchesI . pure <$> handleProjectArg nameString } branchInputPattern :: InputPattern From 5f02bd47288ab5f79083f1a12da1b178fff77fbf Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Sat, 8 Feb 2025 12:50:37 -0500 Subject: [PATCH 5/5] merge trunk --- .../U/Codebase/Sqlite/Queries.hs | 6 +- docs/configuration.md | 13 +- lib/unison-sqlite/package.yaml | 1 + .../src/Unison/Sqlite/Connection.hs | 62 ++- .../src/Unison/Sqlite/Connection/Internal.hs | 8 +- lib/unison-sqlite/unison-sqlite.cabal | 1 + unison-cli/src/Unison/Cli/DownloadUtils.hs | 48 +- .../Codebase/Editor/HandleInput/SyncV2.hs | 7 + .../src/Unison/Codebase/Editor/Input.hs | 3 +- .../src/Unison/Codebase/Editor/Output.hs | 1 + .../src/Unison/CommandLine/InputPatterns.hs | 6 +- .../src/Unison/CommandLine/OutputMessages.hs | 1 + unison-cli/src/Unison/Share/SyncV2.hs | 525 +++++++++++++----- unison-share-api/src/Unison/SyncV2/API.hs | 35 ++ unison-share-api/src/Unison/SyncV2/Types.hs | 99 +++- .../src/Unison/Util/Servant/CBOR.hs | 12 + unison-share-api/unison-share-api.cabal | 1 + .../idempotent/api-list-projects-branches.md | 10 +- .../api-list-projects-branches.output.md | 74 +++ .../docs/configuration.output.md | 9 + 20 files changed, 733 insertions(+), 189 deletions(-) create mode 100644 unison-share-api/src/Unison/SyncV2/API.hs create mode 100644 unison-src/transcripts/idempotent/api-list-projects-branches.output.md diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 043fd697c7..3d94e12f2f 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -3839,8 +3839,8 @@ insertProjectBranch description causalHashId (ProjectBranch projectId branchId b execute [sql| - INSERT INTO project_branch (project_id, branch_id, name, causal_hash_id) - VALUES (:projectId, :branchId, :branchName, :causalHashId) + INSERT INTO project_branch (project_id, branch_id, name, causal_hash_id, last_accessed) + VALUES (:projectId, :branchId, :branchName, :causalHashId, strftime('%s', 'now', 'subsec')) |] whenJust maybeParentBranchId \parentBranchId -> execute @@ -4478,7 +4478,7 @@ setCurrentProjectPath projId branchId path = do execute [sql| UPDATE project_branch - SET last_accessed = strftime('%s', 'now') + SET last_accessed = strftime('%s', 'now', 'subsec') WHERE project_id = :projId AND branch_id = :branchId |] diff --git a/docs/configuration.md b/docs/configuration.md index 549f274a2a..87d38dca3a 100644 --- a/docs/configuration.md +++ b/docs/configuration.md @@ -10,6 +10,7 @@ * [`UNISON_SHARE_ACCESS_TOKEN`](#unison_share_access_token) * [`UNISON_READONLY`](#unison_readonly) * [`UNISON_ENTITY_VALIDATION`](#unison_entity_validation) + * [`UNISON_SYNC_VERSION`](#unison_sync_version) * [Local Codebase Server](#local-codebase-server) * [Codebase Configuration](#codebase-configuration) @@ -17,7 +18,7 @@ ### `UNISON_DEBUG` -Enable debugging output for various portions of the application. +Enable debugging output for various portions of the application. See `lib/unison-prelude/src/Unison/Debug.hs` for the full list of supported flags. E.g. @@ -62,7 +63,7 @@ Note for Windows users: Due to an outstanding issue with GHC's IO manager on Win Enabling the LSP on windows can cause UCM to hang on exit and may require the process to be killed by the operating system or via Ctrl-C. Note that this doesn't pose any risk of codebase corruption or cause any known issues, it's simply an annoyance. -If you accept this annoyance, you can enable the LSP server on Windows by exporting the `UNISON_LSP_ENABLED=true` environment variable. +If you accept this annoyance, you can enable the LSP server on Windows by exporting the `UNISON_LSP_ENABLED=true` environment variable. You can set this persistently in powershell using: @@ -117,6 +118,14 @@ Defaults to enabled. $ UNISON_ENTITY_VALIDATION="false" ucm ``` +### `UNISON_SYNC_VERSION` + +Allows enabling the experimental Sync Version 2 protocol when downloading code from Share. + +```sh +$ UNISON_ENTITY_VALIDATION="2" ucm +``` + ### `UNISON_PULL_WORKERS` Allows setting the number of workers to use when pulling from a codebase server. diff --git a/lib/unison-sqlite/package.yaml b/lib/unison-sqlite/package.yaml index 84d0201eab..b90bd2aa57 100644 --- a/lib/unison-sqlite/package.yaml +++ b/lib/unison-sqlite/package.yaml @@ -9,6 +9,7 @@ library: dependencies: - base + - containers - direct-sqlite - megaparsec - pretty-simple diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs index 48167980db..726cac860e 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs @@ -58,6 +58,7 @@ module Unison.Sqlite.Connection ) where +import Data.Map qualified as Map import Database.SQLite.Simple qualified as Sqlite import Database.SQLite.Simple.FromField qualified as Sqlite import Database.SQLite3 qualified as Direct.Sqlite @@ -71,7 +72,10 @@ import Unison.Sqlite.Connection.Internal (Connection (..)) import Unison.Sqlite.Exception import Unison.Sqlite.Sql (Sql (..)) import Unison.Sqlite.Sql qualified as Sql +import UnliftIO (atomically) import UnliftIO.Exception +import UnliftIO.STM (readTVar) +import UnliftIO.STM qualified as STM -- | Perform an action with a connection to a SQLite database. -- @@ -103,19 +107,47 @@ openConnection name file = do Just "" -> file _ -> "file:" <> file <> "?mode=ro" conn0 <- Sqlite.open sqliteURI `catch` rethrowAsSqliteConnectException name file - let conn = Connection {conn = conn0, file, name} + statementCache <- STM.newTVarIO Map.empty + let conn = Connection {conn = conn0, file, name, statementCache} execute conn [Sql.sql| PRAGMA foreign_keys = ON |] execute conn [Sql.sql| PRAGMA busy_timeout = 60000 |] + execute conn [Sql.sql| PRAGMA synchronous = normal |] + execute conn [Sql.sql| PRAGMA journal_size_limit = 6144000 |] + execute conn [Sql.sql| PRAGMA cache_size = -64000 |] + execute conn [Sql.sql| PRAGMA temp_store = 2 |] + pure conn -- Close a connection opened with 'openConnection'. closeConnection :: Connection -> IO () -closeConnection (Connection _ _ conn) = +closeConnection conn@(Connection {conn = conn0}) = do -- FIXME if this throws an exception, it won't be under `SomeSqliteException` -- Possible fixes: -- 1. Add close exception to the hierarchy, e.g. `SqliteCloseException` -- 2. Always ignore exceptions thrown by `close` (Mitchell prefers this one) - Sqlite.close conn + closeAllStatements conn + Sqlite.close conn0 + +withStatement :: Connection -> Text -> (Sqlite.Statement -> IO a) -> IO a +withStatement conn sql action = do + bracket (prepareStatement conn sql) Sqlite.reset action + where + prepareStatement :: Connection -> Text -> IO Sqlite.Statement + prepareStatement Connection {conn, statementCache} sql = do + cached <- atomically $ do + cache <- STM.readTVar statementCache + pure $ Map.lookup sql cache + case cached of + Just stmt -> pure stmt + Nothing -> do + stmt <- Sqlite.openStatement conn (coerce @Text @Sqlite.Query sql) + atomically $ STM.modifyTVar statementCache (Map.insert sql stmt) + pure stmt + +closeAllStatements :: Connection -> IO () +closeAllStatements Connection {statementCache} = do + cache <- atomically $ readTVar statementCache + for_ cache Sqlite.closeStatement -- An internal type, for making prettier debug logs @@ -152,7 +184,7 @@ logQuery (Sql sql params) result = -- Without results execute :: (HasCallStack) => Connection -> Sql -> IO () -execute conn@(Connection _ _ conn0) sql@(Sql s params) = do +execute conn sql@(Sql s params) = do logQuery sql Nothing doExecute `catch` \(exception :: Sqlite.SQLError) -> throwSqliteQueryException @@ -163,16 +195,16 @@ execute conn@(Connection _ _ conn0) sql@(Sql s params) = do } where doExecute :: IO () - doExecute = - Sqlite.withStatement conn0 (coerce s) \(Sqlite.Statement statement) -> do - bindParameters statement params - void (Direct.Sqlite.step statement) + doExecute = do + withStatement conn s \statement -> do + bindParameters (coerce statement) params + void (Direct.Sqlite.step $ coerce statement) -- | Execute one or more semicolon-delimited statements. -- -- This function does not support parameters, and is mostly useful for executing DDL and migrations. executeStatements :: (HasCallStack) => Connection -> Text -> IO () -executeStatements conn@(Connection _ _ (Sqlite.Connection database _tempNameCounter)) sql = do +executeStatements conn@(Connection {conn = Sqlite.Connection database _tempNameCounter}) sql = do logQuery (Sql sql []) Nothing Direct.Sqlite.exec database sql `catch` \(exception :: Sqlite.SQLError) -> throwSqliteQueryException @@ -185,7 +217,7 @@ executeStatements conn@(Connection _ _ (Sqlite.Connection database _tempNameCoun -- With results, without checks queryStreamRow :: (HasCallStack, Sqlite.FromRow a) => Connection -> Sql -> (IO (Maybe a) -> IO r) -> IO r -queryStreamRow conn@(Connection _ _ conn0) sql@(Sql s params) callback = +queryStreamRow conn sql@(Sql s params) callback = run `catch` \(exception :: Sqlite.SQLError) -> throwSqliteQueryException SqliteQueryExceptionInfo @@ -194,8 +226,8 @@ queryStreamRow conn@(Connection _ _ conn0) sql@(Sql s params) callback = sql } where - run = - bracket (Sqlite.openStatement conn0 (coerce s)) Sqlite.closeStatement \statement -> do + run = do + withStatement conn s \statement -> do Sqlite.bind statement params callback (Sqlite.nextRow statement) @@ -213,7 +245,7 @@ queryStreamCol = queryStreamRow queryListRow :: forall a. (Sqlite.FromRow a, HasCallStack) => Connection -> Sql -> IO [a] -queryListRow conn@(Connection _ _ conn0) sql@(Sql s params) = do +queryListRow conn sql@(Sql s params) = do result <- doQuery `catch` \(exception :: Sqlite.SQLError) -> @@ -228,7 +260,7 @@ queryListRow conn@(Connection _ _ conn0) sql@(Sql s params) = do where doQuery :: IO [a] doQuery = - Sqlite.withStatement conn0 (coerce s) \statement -> do + withStatement conn (coerce s) \statement -> do bindParameters (coerce statement) params let loop :: [a] -> IO [a] loop rows = @@ -347,7 +379,7 @@ queryOneColCheck conn s check = -- Rows modified rowsModified :: Connection -> IO Int -rowsModified (Connection _ _ conn) = +rowsModified (Connection {conn}) = Sqlite.changes conn -- Vacuum diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Connection/Internal.hs b/lib/unison-sqlite/src/Unison/Sqlite/Connection/Internal.hs index 5f80151f94..579c37cfb9 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Connection/Internal.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Connection/Internal.hs @@ -3,15 +3,19 @@ module Unison.Sqlite.Connection.Internal ) where +import Data.Map (Map) +import Data.Text (Text) import Database.SQLite.Simple qualified as Sqlite +import UnliftIO.STM (TVar) -- | A /non-thread safe/ connection to a SQLite database. data Connection = Connection { name :: String, file :: FilePath, - conn :: Sqlite.Connection + conn :: Sqlite.Connection, + statementCache :: TVar (Map Text Sqlite.Statement) } instance Show Connection where - show (Connection name file _conn) = + show (Connection name file _conn _statementCache) = "Connection { name = " ++ show name ++ ", file = " ++ show file ++ " }" diff --git a/lib/unison-sqlite/unison-sqlite.cabal b/lib/unison-sqlite/unison-sqlite.cabal index 3db0980a7c..13a9eb27cd 100644 --- a/lib/unison-sqlite/unison-sqlite.cabal +++ b/lib/unison-sqlite/unison-sqlite.cabal @@ -65,6 +65,7 @@ library ghc-options: -Wall build-depends: base + , containers , direct-sqlite , megaparsec , pretty-simple diff --git a/unison-cli/src/Unison/Cli/DownloadUtils.hs b/unison-cli/src/Unison/Cli/DownloadUtils.hs index 343ebfeeb5..936b2b3fba 100644 --- a/unison-cli/src/Unison/Cli/DownloadUtils.hs +++ b/unison-cli/src/Unison/Cli/DownloadUtils.hs @@ -4,6 +4,7 @@ module Unison.Cli.DownloadUtils ( downloadProjectBranchFromShare, downloadLooseCodeFromShare, + SyncVersion (..), ) where @@ -11,6 +12,7 @@ import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar (modifyTVar', newTVarIO, readTVar, readTVarIO) import Data.List.NonEmpty (pattern (:|)) import System.Console.Regions qualified as Console.Regions +import System.IO.Unsafe (unsafePerformIO) import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.Monad (Cli) @@ -28,9 +30,23 @@ import Unison.Share.API.Hash qualified as Share import Unison.Share.Codeserver qualified as Codeserver import Unison.Share.Sync qualified as Share import Unison.Share.Sync.Types qualified as Share +import Unison.Share.SyncV2 qualified as SyncV2 import Unison.Share.Types (codeserverBaseURL) import Unison.Sync.Common qualified as Sync.Common import Unison.Sync.Types qualified as Share +import Unison.SyncV2.Types qualified as SyncV2 +import UnliftIO.Environment qualified as UnliftIO + +data SyncVersion = SyncV1 | SyncV2 + deriving (Eq, Show) + +-- | The version of the sync protocol to use. +syncVersion :: SyncVersion +syncVersion = unsafePerformIO do + UnliftIO.lookupEnv "UNISON_SYNC_VERSION" + <&> \case + Just "2" -> SyncV2 + _ -> SyncV1 -- | Download a project/branch from Share. downloadProjectBranchFromShare :: @@ -41,7 +57,6 @@ downloadProjectBranchFromShare :: downloadProjectBranchFromShare useSquashed branch = Cli.labelE \done -> do let remoteProjectBranchName = branch.branchName - let repoInfo = Share.RepoInfo (into @Text (ProjectAndBranch branch.projectName remoteProjectBranchName)) causalHashJwt <- case (useSquashed, branch.squashedBranchHead) of (Share.IncludeSquashedHead, Nothing) -> done Output.ShareExpectedSquashedHead @@ -49,16 +64,27 @@ downloadProjectBranchFromShare useSquashed branch = (Share.NoSquashedHead, _) -> pure branch.branchHead exists <- Cli.runTransaction (Queries.causalExistsByHash32 (Share.hashJWTHash causalHashJwt)) when (not exists) do - (result, numDownloaded) <- - Cli.with withEntitiesDownloadedProgressCallback \(downloadedCallback, getNumDownloaded) -> do - result <- Share.downloadEntities Share.hardCodedBaseUrl repoInfo causalHashJwt downloadedCallback - numDownloaded <- liftIO getNumDownloaded - pure (result, numDownloaded) - result & onLeft \err0 -> do - done case err0 of - Share.SyncError err -> Output.ShareErrorDownloadEntities err - Share.TransportError err -> Output.ShareErrorTransport err - Cli.respond (Output.DownloadedEntities numDownloaded) + case syncVersion of + SyncV1 -> do + let repoInfo = Share.RepoInfo (into @Text (ProjectAndBranch branch.projectName remoteProjectBranchName)) + Cli.with withEntitiesDownloadedProgressCallback \(downloadedCallback, getNumDownloaded) -> do + result <- Share.downloadEntities Share.hardCodedBaseUrl repoInfo causalHashJwt downloadedCallback + numDownloaded <- liftIO getNumDownloaded + result & onLeft \err0 -> do + done case err0 of + Share.SyncError err -> Output.ShareErrorDownloadEntities err + Share.TransportError err -> Output.ShareErrorTransport err + Cli.respond (Output.DownloadedEntities numDownloaded) + SyncV2 -> do + let branchRef = SyncV2.BranchRef (into @Text (ProjectAndBranch branch.projectName remoteProjectBranchName)) + let downloadedCallback = \_ -> pure () + let shouldValidate = not $ Codeserver.isCustomCodeserver Codeserver.defaultCodeserver + result <- SyncV2.syncFromCodeserver shouldValidate Share.hardCodedBaseUrl branchRef causalHashJwt downloadedCallback + result & onLeft \err0 -> do + done case err0 of + Share.SyncError pullErr -> + Output.ShareErrorPullV2 pullErr + Share.TransportError err -> Output.ShareErrorTransport err pure (Sync.Common.hash32ToCausalHash (Share.hashJWTHash causalHashJwt)) -- | Download loose code from Share. diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/SyncV2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/SyncV2.hs index f34a64302a..39af010bfe 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/SyncV2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/SyncV2.hs @@ -2,16 +2,20 @@ module Unison.Codebase.Editor.HandleInput.SyncV2 ( handleSyncToFile, handleSyncFromFile, handleSyncFromCodebase, + handleSyncFromCodeserver, ) where import Control.Lens import Control.Monad.Reader (MonadReader (..)) +import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.Queries qualified as Q +import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.ProjectUtils qualified as Project +import Unison.Cli.Share.Projects qualified as Projects import Unison.Codebase (CodebasePath) import Unison.Codebase qualified as Codebase import Unison.Codebase.Editor.Output qualified as Output @@ -69,3 +73,6 @@ handleSyncFromCodebase description srcCodebasePath srcBranch destBranch = do Cli.setProjectBranchRootToCausalHash (projectBranch ^. #branch) description causalHash Right (Right (Left syncErr)) -> do Cli.respond (Output.SyncPullError syncErr) + +handleSyncFromCodeserver :: Projects.IncludeSquashedHead -> Projects.RemoteProjectBranch -> Cli (Either Output.ShareError CausalHash) +handleSyncFromCodeserver = downloadProjectBranchFromShare diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index acaacd23c9..75de97cd1a 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -138,7 +138,8 @@ data Input | PushRemoteBranchI PushRemoteBranchInput | SyncToFileI FilePath (ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)) | SyncFromFileI FilePath UnresolvedProjectBranch - | SyncFromCodebaseI FilePath (ProjectAndBranch ProjectName ProjectBranchName) UnresolvedProjectBranch + | -- | Sync from a codebase project branch to this codebase's project branch + SyncFromCodebaseI FilePath (ProjectAndBranch ProjectName ProjectBranchName) UnresolvedProjectBranch | ResetI (BranchId2 {- namespace to reset it to -}) (Maybe UnresolvedProjectBranch {- ProjectBranch to reset -}) | -- | used in Welcome module to give directions to user -- diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index f27bb6855c..044e9f1e5e 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -477,6 +477,7 @@ data ShareError = ShareErrorDownloadEntities Share.DownloadEntitiesError | ShareErrorGetCausalHashByPath Sync.GetCausalHashByPathError | ShareErrorPull Sync.PullError + | ShareErrorPullV2 SyncV2.PullError | ShareErrorTransport Sync.CodeserverTransportError | ShareErrorUploadEntities Share.UploadEntitiesError | ShareExpectedSquashedHead diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index c43a1873df..0b4d7f8236 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -2223,11 +2223,13 @@ syncFromCodebase = $ Optional [] Nothing, help = ( P.wrapColumn2 - [ (makeExample syncFromCodebase ["./codebase", "/feature", "/main"], "Sets the /feature branch to the contents of the codebase at ./codebase.") + [ ( makeExample syncFromCodebase ["./codebase", "srcProject/main", "destProject/main"], + "Imports srcProject/main from the specified codebase, then sets destProject/main to the imported branch." + ) ] ), parse = \case - [codebaseLocation, branchToSync, destinationBranch] -> Input.SyncFromCodebaseI <$> unsupportedStructuredArgument makeStandalone "a file name" codebaseLocation <*> handleBranchWithProject branchToSync <*> handleBranchWithOptionalProject destinationBranch + [codebaseLocation, srcBranch, destinationBranch] -> Input.SyncFromCodebaseI <$> unsupportedStructuredArgument makeStandalone "a file name" codebaseLocation <*> handleBranchWithProject srcBranch <*> handleBranchWithOptionalProject destinationBranch args -> wrongArgsLength "exactly three arguments" args } where diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index dfd09ee67d..23fc6a2df0 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -2293,6 +2293,7 @@ prettyShareError = ShareErrorDownloadEntities err -> prettyDownloadEntitiesError err ShareErrorGetCausalHashByPath err -> prettyGetCausalHashByPathError err ShareErrorPull err -> prettyPullError err + ShareErrorPullV2 err -> prettyPullV2Error err ShareErrorTransport err -> prettyTransportError err ShareErrorUploadEntities err -> prettyUploadEntitiesError err ShareExpectedSquashedHead -> "The server failed to provide a squashed branch head when requested. Please report this as a bug to the Unison team." diff --git a/unison-cli/src/Unison/Share/SyncV2.hs b/unison-cli/src/Unison/Share/SyncV2.hs index bbce0d95e6..14870f208d 100644 --- a/unison-cli/src/Unison/Share/SyncV2.hs +++ b/unison-cli/src/Unison/Share/SyncV2.hs @@ -5,6 +5,7 @@ module Unison.Share.SyncV2 ( syncFromFile, syncToFile, syncFromCodebase, + syncFromCodeserver, ) where @@ -21,24 +22,37 @@ import Data.Attoparsec.ByteString.Char8 qualified as A8 import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BL import Data.Conduit.Attoparsec qualified as C -import Data.Conduit.List qualified as C +import Data.Conduit.Combinators qualified as C +import Data.Conduit.List qualified as CL import Data.Conduit.Zlib qualified as C +import Data.Foldable qualified as Foldable import Data.Graph qualified as Graph import Data.Map qualified as Map +import Data.Proxy import Data.Set qualified as Set import Data.Text.IO qualified as Text +import Data.Text.Lazy qualified as Text.Lazy +import Data.Text.Lazy.Encoding qualified as Text.Lazy +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Network.HTTP.Client qualified as Http.Client +import Network.HTTP.Types qualified as HTTP +import Servant.API qualified as Servant +import Servant.Client.Streaming qualified as Servant import Servant.Conduit () +import Servant.Types.SourceT qualified as Servant import System.Console.Regions qualified as Console.Regions import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.Queries qualified as Q import U.Codebase.Sqlite.TempEntity (TempEntity) import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle) +import Unison.Auth.HTTPClient qualified as Auth import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Codebase qualified as Codebase -import Unison.Debug qualified as Debug import Unison.Hash32 (Hash32) import Unison.Prelude +import Unison.Share.API.Hash qualified as Share import Unison.Share.ExpectedHashMismatches (expectedCausalHashMismatches, expectedComponentHashMismatches) import Unison.Share.Sync.Types import Unison.Sqlite qualified as Sqlite @@ -47,7 +61,9 @@ import Unison.Sync.Common qualified as Sync import Unison.Sync.EntityValidation qualified as EV import Unison.Sync.Types qualified as Share import Unison.Sync.Types qualified as Sync -import Unison.SyncV2.Types (CBORBytes) +import Unison.SyncV2.API (Routes (downloadEntitiesStream)) +import Unison.SyncV2.API qualified as SyncV2 +import Unison.SyncV2.Types (CBORBytes, CBORStream, DependencyType (..)) import Unison.SyncV2.Types qualified as SyncV2 import Unison.Util.Servant.CBOR qualified as CBOR import Unison.Util.Timing qualified as Timing @@ -57,20 +73,123 @@ type Stream i o = ConduitT i o StreamM () type SyncErr = SyncError SyncV2.PullError +-- The base monad we use within the conduit pipeline. type StreamM = (ExceptT SyncErr (C.ResourceT IO)) +-- | The number of entities to process in a single transaction. +-- +-- SQLite transactions have some fixed overhead, so setting this too low can really slow things down, +-- but going too high here means we may be waiting on the network to get a full batch when we could be starting work. batchSize :: Int batchSize = 5000 ------------------------------------------------------------------------------------------------------------------------ --- Download entities +-- Main methods +------------------------------------------------------------------------------------------------------------------------ + +-- | Sync a given causal hash and its dependencies to a sync-file. +syncToFile :: + Codebase.Codebase IO v a -> + -- | Root hash to sync + CausalHash -> + -- | Optional name of the branch begin synced + Maybe SyncV2.BranchRef -> + -- | Location of the sync-file + FilePath -> + IO (Either SyncErr ()) +syncToFile codebase rootHash mayBranchRef destFilePath = do + liftIO $ Codebase.withConnection codebase \conn -> do + C.runResourceT $ + withCodebaseEntityStream conn rootHash mayBranchRef \mayTotal stream -> do + withStreamProgressCallback (Just mayTotal) \countC -> runExceptT do + C.runConduit $ + stream + C..| countC + C..| C.map (BL.toStrict . CBOR.serialise) + C..| C.transPipe liftIO C.gzip + C..| C.sinkFile destFilePath + +syncFromFile :: + -- | Whether to validate entities as they're imported. + Bool -> + -- | Location of the sync-file + FilePath -> + Cli (Either (SyncError SyncV2.PullError) CausalHash) +syncFromFile shouldValidate syncFilePath = do + Cli.Env {codebase} <- ask + -- Every insert into SQLite checks the temp entity tables, but syncv2 doesn't actually use them, so it's faster + -- if we clear them out before starting a sync. + Cli.runTransaction Q.clearTempEntityTables + runExceptT do + mapExceptT liftIO $ Timing.time "File Sync" $ do + header <- mapExceptT C.runResourceT $ do + let stream = C.sourceFile syncFilePath C..| C.ungzip C..| decodeUnframedEntities + (header, rest) <- initializeStream stream + streamIntoCodebase shouldValidate codebase header rest + pure header + afterSyncChecks codebase (SyncV2.rootCausalHash header) + pure . hash32ToCausalHash $ SyncV2.rootCausalHash header + +syncFromCodebase :: + Bool -> + -- | The codebase to sync from. + Sqlite.Connection -> + (Codebase.Codebase IO v a) -> + -- | The hash to sync. + CausalHash -> + IO (Either (SyncError SyncV2.PullError) ()) +syncFromCodebase shouldValidate srcConn destCodebase causalHash = do + -- Every insert into SQLite checks the temp entity tables, but syncv2 doesn't actually use them, so it's faster + -- if we clear them out before starting a sync. + Sqlite.runTransaction srcConn Q.clearTempEntityTables + liftIO . C.runResourceT . runExceptT $ withCodebaseEntityStream srcConn causalHash Nothing \_total entityStream -> do + (header, rest) <- initializeStream entityStream + streamIntoCodebase shouldValidate destCodebase header rest + mapExceptT liftIO (afterSyncChecks destCodebase (causalHashToHash32 causalHash)) -validateAndSave :: Bool -> (Codebase.Codebase IO v a) -> [(Hash32, TempEntity)] -> StreamM () +syncFromCodeserver :: + Bool -> + -- | The Unison Share URL. + Servant.BaseUrl -> + -- | The branch to download from. + SyncV2.BranchRef -> + -- | The hash to download. + Share.HashJWT -> + -- | Callback that's given a number of entities we just downloaded. + (Int -> IO ()) -> + Cli (Either (SyncError SyncV2.PullError) ()) +syncFromCodeserver shouldValidate unisonShareUrl branchRef hashJwt _downloadedCallback = do + Cli.Env {authHTTPClient, codebase} <- ask + -- Every insert into SQLite checks the temp entity tables, but syncv2 doesn't actually use them, so it's faster + -- if we clear them out before starting a sync. + Cli.runTransaction Q.clearTempEntityTables + runExceptT do + knownHashes <- ExceptT $ negotiateKnownCausals unisonShareUrl branchRef hashJwt + let hash = Share.hashJWTHash hashJwt + ExceptT $ do + (Cli.runTransaction (Q.entityLocation hash)) >>= \case + Just Q.EntityInMainStorage -> pure $ Right () + _ -> do + Timing.time "Entity Download" $ do + liftIO . C.runResourceT . runExceptT $ httpStreamEntities + authHTTPClient + unisonShareUrl + SyncV2.DownloadEntitiesRequest {branchRef, causalHash = hashJwt, knownHashes} + \header stream -> do + streamIntoCodebase shouldValidate codebase header stream + mapExceptT liftIO (afterSyncChecks codebase hash) + +------------------------------------------------------------------------------------------------------------------------ +-- Helpers +------------------------------------------------------------------------------------------------------------------------ + +-- | Validate that the provided entities match their expected hashes, and if so, save them to the codebase. +validateAndSave :: Bool -> (Codebase.Codebase IO v a) -> Vector (Hash32, TempEntity) -> StreamM () validateAndSave shouldValidate codebase entities = do let validateEntities = runExceptT $ when shouldValidate (batchValidateEntities entities) - -- Validation is slow, run it in parallel with insertion, but don't commit the transaction until we're done - -- validation. + -- Validation is slow, so we run it in parallel with insertion (which can also be slow), + -- but we don't commit the transaction until we're done validation to avoid inserting invalid entities. ExceptT . liftIO $ IO.withAsync validateEntities \validationTask -> do Timing.time "Inserting entities" $ Codebase.runTransactionExceptT codebase do for_ entities \(hash, entity) -> do @@ -79,6 +198,26 @@ validateAndSave shouldValidate codebase entities = do Left err -> throwError err Right _ -> pure () +-- | Validate that a batch of entities matches the hashes they're keyed by, throwing an error if any of them fail validation. +batchValidateEntities :: Vector (Hash32, TempEntity) -> ExceptT SyncErr IO () +batchValidateEntities entities = do + mismatches <- fmap Vector.catMaybes $ liftIO $ IO.pooledForConcurrently entities \(hash, entity) -> do + IO.evaluate $ EV.validateTempEntity hash entity + for_ mismatches \case + err@(Share.EntityHashMismatch et (Share.HashMismatchForEntity {supplied, computed})) -> + let expectedMismatches = case et of + Share.TermComponentType -> expectedComponentHashMismatches + Share.DeclComponentType -> expectedComponentHashMismatches + Share.CausalType -> expectedCausalHashMismatches + _ -> mempty + in case Map.lookup supplied expectedMismatches of + Just expected + | expected == computed -> pure () + _ -> do + throwError . SyncError . SyncV2.PullError'DownloadEntities . SyncV2.DownloadEntitiesEntityValidationFailure $ err + err -> do + throwError . SyncError . SyncV2.PullError'DownloadEntities . SyncV2.DownloadEntitiesEntityValidationFailure $ err + -- | Syncs a stream which could send entities in any order. syncUnsortedStream :: Bool -> @@ -86,26 +225,50 @@ syncUnsortedStream :: Stream () SyncV2.EntityChunk -> StreamM () syncUnsortedStream shouldValidate codebase stream = do - Debug.debugLogM Debug.Temp $ "Syncing unsorted stream" - allResults <- C.runConduit $ stream C..| C.sinkList - allEntities <- ExceptT $ Timing.time "Unpacking chunks" $ liftIO $ Codebase.runTransactionExceptT codebase $ do unpackChunks allResults + allEntities <- + C.runConduit $ + stream + C..| CL.chunksOf batchSize + C..| unpackChunks codebase + C..| validateBatch + C..| C.concat + C..| C.sinkVector @Vector let sortedEntities = sortDependencyFirst allEntities - validateAndSave shouldValidate codebase sortedEntities + liftIO $ withEntitySavingCallback (Just $ Vector.length allEntities) \countC -> do + Codebase.runTransaction codebase $ for_ sortedEntities \(hash, entity) -> do + r <- Q.saveTempEntityInMain v2HashHandle hash entity + Sqlite.unsafeIO $ countC 1 + pure r + where + validateBatch :: Stream (Vector (Hash32, TempEntity)) (Vector (Hash32, TempEntity)) + validateBatch = C.iterM \entities -> do + when shouldValidate (mapExceptT lift $ batchValidateEntities entities) -- | Syncs a stream which sends entities which are already sorted in dependency order. +-- This allows us to stream them directly into the codebase as they're received. syncSortedStream :: Bool -> (Codebase.Codebase IO v a) -> Stream () SyncV2.EntityChunk -> StreamM () syncSortedStream shouldValidate codebase stream = do - Debug.debugLogM Debug.Temp $ "Syncing sorted stream" - let handler :: Stream [SyncV2.EntityChunk] o - handler = C.mapM_C \chunkBatch -> do - entityBatch <- mapExceptT lift . ExceptT $ Codebase.runTransactionExceptT codebase do for chunkBatch unpackChunk - validateAndSave shouldValidate codebase (catMaybes entityBatch) - C.runConduit $ stream C..| C.chunksOf batchSize C..| handler + let handler :: Stream (Vector (Hash32, TempEntity)) o + handler = C.mapM_C \entityBatch -> do + validateAndSave shouldValidate codebase entityBatch + C.runConduit $ + stream + C..| CL.chunksOf batchSize + C..| unpackChunks codebase + C..| handler + +-- | Topologically sort entities based on their dependencies, returning a list in dependency-first order. +sortDependencyFirst :: (Foldable f, Functor f) => f (Hash32, TempEntity) -> [(Hash32, TempEntity)] +sortDependencyFirst entities = do + let adjList = entities <&> \(hash32, entity) -> ((hash32, entity), hash32, Set.toList $ Share.entityDependencies (tempEntityToEntity entity)) + (graph, vertexInfo, _vertexForKey) = Graph.graphFromEdges (Foldable.toList adjList) + in Graph.reverseTopSort graph <&> \v -> (view _1 $ vertexInfo v) +-- | Unpack a single entity chunk, returning the entity if it's not already in the codebase, Nothing otherwise. unpackChunk :: SyncV2.EntityChunk -> ExceptT SyncErr Sqlite.Transaction (Maybe (Hash32, TempEntity)) unpackChunk = \case SyncV2.EntityChunk {hash, entityCBOR = entityBytes} -> do @@ -121,33 +284,23 @@ unpackChunk = \case Left err -> do throwError $ (SyncError . SyncV2.PullError'Sync $ SyncV2.SyncErrorDeserializationFailure err) Right entity -> pure entity -unpackChunks :: [SyncV2.EntityChunk] -> ExceptT SyncErr Sqlite.Transaction [(Hash32, TempEntity)] -unpackChunks xs = do +unpackChunks :: Codebase.Codebase IO v a -> Stream [SyncV2.EntityChunk] (Vector (Hash32, TempEntity)) +unpackChunks codebase = C.mapM \xs -> ExceptT . lift . Codebase.runTransactionExceptT codebase $ do for xs unpackChunk <&> catMaybes + <&> Vector.fromList -batchValidateEntities :: [(Hash32, TempEntity)] -> ExceptT SyncErr IO () -batchValidateEntities entities = do - mismatches <- fmap catMaybes $ liftIO $ IO.pooledForConcurrently entities \(hash, entity) -> do - IO.evaluate $ EV.validateTempEntity hash entity - for_ mismatches \case - err@(Share.EntityHashMismatch et (Share.HashMismatchForEntity {supplied, computed})) -> - let expectedMismatches = case et of - Share.TermComponentType -> expectedComponentHashMismatches - Share.DeclComponentType -> expectedComponentHashMismatches - Share.CausalType -> expectedCausalHashMismatches - _ -> mempty - in case Map.lookup supplied expectedMismatches of - Just expected - | expected == computed -> pure () - _ -> do - throwError . SyncError . SyncV2.PullError'DownloadEntities . SyncV2.DownloadEntitiesEntityValidationFailure $ err - err -> do - throwError . SyncError . SyncV2.PullError'DownloadEntities . SyncV2.DownloadEntitiesEntityValidationFailure $ err - -streamIntoCodebase :: Bool -> Codebase.Codebase IO v a -> SyncV2.StreamInitInfo -> Stream () SyncV2.EntityChunk -> StreamM () +-- | Stream entities from one codebase into another. +streamIntoCodebase :: + -- | Whether to validate entities as they're imported. + Bool -> + Codebase.Codebase IO v a -> + SyncV2.StreamInitInfo -> + Stream () SyncV2.EntityChunk -> + StreamM () streamIntoCodebase shouldValidate codebase SyncV2.StreamInitInfo {version, entitySorting, numEntities = numEntities} stream = ExceptT do withStreamProgressCallback (fromIntegral <$> numEntities) \countC -> runExceptT do + -- Add a counter to the stream to track how many entities we've processed. let stream' = stream C..| countC case version of (SyncV2.Version 1) -> pure () @@ -157,6 +310,7 @@ streamIntoCodebase shouldValidate codebase SyncV2.StreamInitInfo {version, entit SyncV2.DependenciesFirst -> syncSortedStream shouldValidate codebase stream' SyncV2.Unsorted -> syncUnsortedStream shouldValidate codebase stream' +-- | A sanity-check to verify that the hash we expected to import from the stream was successfully loaded into the codebase. afterSyncChecks :: Codebase.Codebase IO v a -> Hash32 -> ExceptT (SyncError SyncV2.PullError) IO () afterSyncChecks codebase hash = do lift (didCausalSuccessfullyImport codebase hash) >>= \case @@ -171,53 +325,16 @@ afterSyncChecks codebase hash = do let expectedHash = hash32ToCausalHash hash isJust <$> (Codebase.runTransaction codebase $ Q.loadCausalByCausalHash expectedHash) --- | Topologically sort entities based on their dependencies. -sortDependencyFirst :: [(Hash32, TempEntity)] -> [(Hash32, TempEntity)] -sortDependencyFirst entities = do - let adjList = entities <&> \(hash32, entity) -> ((hash32, entity), hash32, Set.toList $ Share.entityDependencies (tempEntityToEntity entity)) - (graph, vertexInfo, _vertexForKey) = Graph.graphFromEdges adjList - in Graph.reverseTopSort graph <&> \v -> (view _1 $ vertexInfo v) - -syncFromFile :: - Bool -> - -- | Location of the sync-file - FilePath -> - Cli (Either (SyncError SyncV2.PullError) CausalHash) -syncFromFile shouldValidate syncFilePath = do - Cli.Env {codebase} <- ask - runExceptT do - Debug.debugLogM Debug.Temp $ "Kicking off sync" - mapExceptT liftIO $ Timing.time "File Sync" $ do - header <- mapExceptT C.runResourceT $ do - let stream = C.sourceFile syncFilePath C..| C.ungzip C..| decodeUnframedEntities - (header, rest) <- initializeStream stream - streamIntoCodebase shouldValidate codebase header rest - pure header - afterSyncChecks codebase (SyncV2.rootCausalHash header) - pure . hash32ToCausalHash $ SyncV2.rootCausalHash header - -syncFromCodebase :: - Bool -> - -- | The codebase to sync from. - Sqlite.Connection -> - (Codebase.Codebase IO v a) -> - -- | The hash to sync. - CausalHash -> - IO (Either (SyncError SyncV2.PullError) ()) -syncFromCodebase shouldValidate srcConn destCodebase causalHash = do - liftIO . C.runResourceT . runExceptT $ withEntityStream srcConn causalHash Nothing \_total entityStream -> do - (header, rest) <- initializeStream entityStream - streamIntoCodebase shouldValidate destCodebase header rest - mapExceptT liftIO (afterSyncChecks destCodebase (causalHashToHash32 causalHash)) - -withEntityStream :: +-- | Load and stream entities for a given causal hash from a codebase into a stream. +withCodebaseEntityStream :: (MonadIO m) => Sqlite.Connection -> CausalHash -> Maybe SyncV2.BranchRef -> + -- | Callback to call with the total count of entities and the stream. (Int -> Stream () SyncV2.DownloadEntitiesChunk -> m r) -> m r -withEntityStream conn rootHash mayBranchRef callback = do +withCodebaseEntityStream conn rootHash mayBranchRef callback = do entities <- liftIO $ withEntityLoadingCallback $ \counter -> do Sqlite.runTransaction conn (depsForCausal rootHash counter) liftIO $ Text.hPutStrLn IO.stderr $ "Finished loading entities, writing sync-file." @@ -244,34 +361,21 @@ withEntityStream conn rootHash mayBranchRef callback = do & (initialChunk :) let stream = C.yieldMany contents callback totalEntities stream - -syncToFile :: - Codebase.Codebase IO v a -> - CausalHash -> - Maybe SyncV2.BranchRef -> - FilePath -> - IO (Either SyncErr ()) -syncToFile codebase rootHash mayBranchRef destFilePath = do - liftIO $ Codebase.withConnection codebase \conn -> do - C.runResourceT $ - withEntityStream conn rootHash mayBranchRef \mayTotal stream -> do - withStreamProgressCallback (Just mayTotal) \countC -> runExceptT do - C.runConduit $ stream C..| countC C..| C.map (BL.toStrict . CBOR.serialise) C..| C.transPipe liftIO C.gzip C..| C.sinkFile destFilePath - --- | Collect all dependencies of a given causal hash. -depsForCausal :: CausalHash -> (Int -> IO ()) -> Sqlite.Transaction (Map Hash32 (Sync.Entity Text Hash32 Hash32)) -depsForCausal causalHash counter = do - flip execStateT mempty $ expandEntities (causalHashToHash32 causalHash) where - expandEntities :: Hash32 -> ((StateT (Map Hash32 (Sync.Entity Text Hash32 Hash32)) Sqlite.Transaction)) () - expandEntities hash32 = do - gets (Map.member hash32) >>= \case - True -> pure () - False -> do - entity <- lift $ Sync.expectEntity hash32 - modify (Map.insert hash32 entity) - lift . Sqlite.unsafeIO $ counter 1 - traverseOf_ Sync.entityHashes_ expandEntities entity + -- Collect all dependencies of a given causal hash. + depsForCausal :: CausalHash -> (Int -> IO ()) -> Sqlite.Transaction (Map Hash32 (Sync.Entity Text Hash32 Hash32)) + depsForCausal causalHash counter = do + flip execStateT mempty $ expandEntities (causalHashToHash32 causalHash) + where + expandEntities :: Hash32 -> ((StateT (Map Hash32 (Sync.Entity Text Hash32 Hash32)) Sqlite.Transaction)) () + expandEntities hash32 = do + gets (Map.member hash32) >>= \case + True -> pure () + False -> do + entity <- lift $ Sync.expectEntity hash32 + modify (Map.insert hash32 entity) + lift . Sqlite.unsafeIO $ counter 1 + traverseOf_ Sync.entityHashes_ expandEntities entity -- | Gets the framed chunks from a NetString framed stream. _unNetString :: ConduitT ByteString ByteString StreamM () @@ -290,8 +394,8 @@ _decodeFramedEntity bs = do Left err -> throwError . SyncError . SyncV2.PullError'Sync $ SyncV2.SyncErrorDeserializationFailure err Right chunk -> pure chunk --- Expects a stream of tightly-packed CBOR entities without any framing/separators. -decodeUnframedEntities :: ConduitT ByteString SyncV2.DownloadEntitiesChunk StreamM () +-- | Unpacks a stream of tightly-packed CBOR entities without any framing/separators. +decodeUnframedEntities :: forall a. (CBOR.Serialise a) => Stream ByteString a decodeUnframedEntities = C.transPipe (mapExceptT (lift . stToIO)) $ do C.await >>= \case Nothing -> pure () @@ -299,13 +403,13 @@ decodeUnframedEntities = C.transPipe (mapExceptT (lift . stToIO)) $ do d <- newDecoder loop bs d where - newDecoder :: ConduitT ByteString SyncV2.DownloadEntitiesChunk (ExceptT SyncErr (ST s)) (Maybe ByteString -> ST s (CBOR.IDecode s (SyncV2.DownloadEntitiesChunk))) + newDecoder :: ConduitT ByteString a (ExceptT SyncErr (ST s)) (Maybe ByteString -> ST s (CBOR.IDecode s a)) newDecoder = do (lift . lift) CBOR.deserialiseIncremental >>= \case CBOR.Done _ _ _ -> throwError . SyncError . SyncV2.PullError'Sync $ SyncV2.SyncErrorStreamFailure "Invalid initial decoder" CBOR.Fail _ _ err -> throwError . SyncError . SyncV2.PullError'Sync $ SyncV2.SyncErrorDeserializationFailure err CBOR.Partial k -> pure k - loop :: ByteString -> (Maybe ByteString -> ST s (CBOR.IDecode s (SyncV2.DownloadEntitiesChunk))) -> ConduitT ByteString SyncV2.DownloadEntitiesChunk (ExceptT SyncErr (ST s)) () + loop :: ByteString -> (Maybe ByteString -> ST s (CBOR.IDecode s a)) -> ConduitT ByteString a (ExceptT SyncErr (ST s)) () loop bs k = do (lift . lift) (k (Just bs)) >>= \case CBOR.Fail _ _ err -> throwError . SyncError . SyncV2.PullError'Sync $ SyncV2.SyncErrorDeserializationFailure err @@ -338,11 +442,80 @@ decodeUnframedEntities = C.transPipe (mapExceptT (lift . stToIO)) $ do k <- newDecoder loop rem k --- | Peel the header off the stream and parse the remaining entity chunks. +------------------------------------------------------------------------------------------------------------------------ +-- Servant stuff + +type SyncAPI = ("ucm" Servant.:> "v2" Servant.:> "sync" Servant.:> SyncV2.API) + +syncAPI :: Proxy SyncAPI +syncAPI = Proxy @SyncAPI + +downloadEntitiesStreamClientM :: SyncV2.DownloadEntitiesRequest -> Servant.ClientM (Servant.SourceT IO (CBORStream SyncV2.DownloadEntitiesChunk)) +causalDependenciesStreamClientM :: SyncV2.CausalDependenciesRequest -> Servant.ClientM (Servant.SourceT IO (CBORStream SyncV2.CausalDependenciesChunk)) +SyncV2.Routes + { downloadEntitiesStream = downloadEntitiesStreamClientM, + causalDependenciesStream = causalDependenciesStreamClientM + } = Servant.client syncAPI + +-- | Helper for running clientM that returns a stream of entities. +-- You MUST consume the stream within the callback, it will be closed when the callback returns. +withConduit :: forall r chunk. (CBOR.Serialise chunk) => Servant.ClientEnv -> (Stream () chunk -> StreamM r) -> Servant.ClientM (Servant.SourceIO (CBORStream chunk)) -> StreamM r +withConduit clientEnv callback clientM = do + ExceptT $ withRunInIO \runInIO -> do + Servant.withClientM clientM clientEnv $ \case + Left err -> pure . Left . TransportError $ (handleClientError clientEnv err) + Right sourceT -> do + conduit <- liftIO $ Servant.fromSourceIO sourceT + (runInIO . runExceptT $ callback (conduit C..| unpackCBORBytesStream)) + +unpackCBORBytesStream :: (CBOR.Serialise a) => Stream (CBORStream a) a +unpackCBORBytesStream = + C.map (BL.toStrict . coerce @_ @BL.ByteString) C..| decodeUnframedEntities + +handleClientError :: Servant.ClientEnv -> Servant.ClientError -> CodeserverTransportError +handleClientError clientEnv err = + case err of + Servant.FailureResponse _req resp -> + case HTTP.statusCode $ Servant.responseStatusCode resp of + 401 -> Unauthenticated (Servant.baseUrl clientEnv) + -- The server should provide semantically relevant permission-denied messages + -- when possible, but this should catch any we miss. + 403 -> PermissionDenied (Text.Lazy.toStrict . Text.Lazy.decodeUtf8 $ Servant.responseBody resp) + 408 -> Timeout + 429 -> RateLimitExceeded + 504 -> Timeout + _ -> UnexpectedResponse resp + Servant.DecodeFailure msg resp -> DecodeFailure msg resp + Servant.UnsupportedContentType _ct resp -> UnexpectedResponse resp + Servant.InvalidContentTypeHeader resp -> UnexpectedResponse resp + Servant.ConnectionError _ -> UnreachableCodeserver (Servant.baseUrl clientEnv) + +-- | Stream entities from the codeserver. +httpStreamEntities :: + Auth.AuthenticatedHttpClient -> + Servant.BaseUrl -> + SyncV2.DownloadEntitiesRequest -> + (SyncV2.StreamInitInfo -> Stream () SyncV2.EntityChunk -> StreamM ()) -> + StreamM () +httpStreamEntities (Auth.AuthenticatedHttpClient httpClient) unisonShareUrl req callback = do + let clientEnv = + (Servant.mkClientEnv httpClient unisonShareUrl) + { Servant.makeClientRequest = \url request -> + -- Disable client-side timeouts + (Servant.defaultMakeClientRequest url request) + <&> \r -> + r + { Http.Client.responseTimeout = Http.Client.responseTimeoutNone + } + } + (downloadEntitiesStreamClientM req) & withConduit clientEnv \stream -> do + (init, entityStream) <- initializeStream stream + callback init entityStream + +-- | Peel the header off the stream and parse the remaining entity chunks into EntityChunks initializeStream :: Stream () SyncV2.DownloadEntitiesChunk -> StreamM (SyncV2.StreamInitInfo, Stream () SyncV2.EntityChunk) initializeStream stream = do (streamRemainder, init) <- stream C.$$+ C.headC - Debug.debugM Debug.Temp "Got initial chunk: " init case init of Nothing -> throwError . SyncError . SyncV2.PullError'Sync $ SyncV2.SyncErrorMissingInitialChunk Just chunk -> do @@ -351,7 +524,6 @@ initializeStream stream = do let entityStream = C.unsealConduitT streamRemainder C..| C.mapM parseEntity pure $ (info, entityStream) SyncV2.EntityC _ -> do - Debug.debugLogM Debug.Temp $ "Got unexpected entity chunk" throwError . SyncError . SyncV2.PullError'Sync $ SyncV2.SyncErrorMissingInitialChunk SyncV2.ErrorC (SyncV2.ErrorChunk err) -> throwError . SyncError . SyncV2.PullError'DownloadEntities $ err where @@ -361,35 +533,112 @@ initializeStream stream = do SyncV2.ErrorC (SyncV2.ErrorChunk err) -> throwError . SyncError $ SyncV2.PullError'DownloadEntities err SyncV2.InitialC {} -> throwError . SyncError $ SyncV2.PullError'Sync SyncV2.SyncErrorMisplacedInitialChunk --- Provide the given action a callback that display to the terminal. -withStreamProgressCallback :: (MonadIO m, MonadUnliftIO n) => Maybe Int -> (ConduitT i i m () -> n a) -> n a -withStreamProgressCallback total action = do - entitiesDownloadedVar <- IO.newTVarIO (0 :: Int) - IO.withRunInIO \toIO -> do - Console.Regions.displayConsoleRegions do - Console.Regions.withConsoleRegion Console.Regions.Linear \region -> do - Console.Regions.setConsoleRegion region do - entitiesDownloaded <- IO.readTVar entitiesDownloadedVar - pure $ - "\n Processed " - <> tShow entitiesDownloaded - <> maybe "" (\total -> " / " <> tShow total) total - <> " entities...\n\n" - toIO $ action $ C.awaitForever \i -> do - liftIO $ IO.atomically (IO.modifyTVar' entitiesDownloadedVar (+ 1)) - C.yield i +------------------------------------------------------------------------------------------------------------------------ +-- Causal Dependency negotiation +------------------------------------------------------------------------------------------------------------------------ -withEntityLoadingCallback :: (MonadUnliftIO m) => ((Int -> m ()) -> m a) -> m a -withEntityLoadingCallback action = do +httpStreamCausalDependencies :: + forall r. + Auth.AuthenticatedHttpClient -> + Servant.BaseUrl -> + SyncV2.CausalDependenciesRequest -> + (Stream () SyncV2.CausalDependenciesChunk -> StreamM r) -> + StreamM r +httpStreamCausalDependencies (Auth.AuthenticatedHttpClient httpClient) unisonShareUrl req callback = do + let clientEnv = + (Servant.mkClientEnv httpClient unisonShareUrl) + { Servant.makeClientRequest = \url request -> + -- Disable client-side timeouts + (Servant.defaultMakeClientRequest url request) + <&> \r -> + r + { Http.Client.responseTimeout = Http.Client.responseTimeoutNone + } + } + (causalDependenciesStreamClientM req) & withConduit clientEnv callback + +-- | Ask Share for the dependencies of a given hash jwt, +-- then filter them to get the set of causals which we have and don't need sent. +negotiateKnownCausals :: + -- | The Unison Share URL. + Servant.BaseUrl -> + -- | The branch to download from. + SyncV2.BranchRef -> + -- | The hash to download. + Share.HashJWT -> + Cli (Either (SyncError SyncV2.PullError) (Set Hash32)) +negotiateKnownCausals unisonShareUrl branchRef hashJwt = do + Cli.Env {authHTTPClient, codebase} <- ask + liftIO $ Text.hPutStrLn IO.stderr $ " 🔎 Identifying missing entities..." + Timing.time "Causal Negotiation" $ do + liftIO . C.runResourceT . runExceptT $ httpStreamCausalDependencies + authHTTPClient + unisonShareUrl + SyncV2.CausalDependenciesRequest {branchRef, rootCausal = hashJwt} + \stream -> do + Set.fromList <$> C.runConduit (stream C..| C.map unpack C..| findKnownDeps codebase C..| C.sinkList) + where + -- Go through the dependencies of the remote root from top-down, yielding all causal hashes that we already + -- have until we find one in the causal spine we already have, then yield that one and stop since we'll implicitly + -- have all of its dependencies. + findKnownDeps :: Codebase.Codebase IO v a -> Stream (Hash32, DependencyType) Hash32 + findKnownDeps codebase = do + C.await >>= \case + Just (hash, LibDependency) -> do + -- We yield all lib dependencies we have, it's possible we don't have any of the causal spine in common, but _do_ have + -- some of the libraries we can still save a lot of work. + whenM (lift $ haveCausalHash codebase hash) (C.yield hash) + -- We continue regardless. + findKnownDeps codebase + Just (hash, CausalSpineDependency) -> do + lift (haveCausalHash codebase hash) >>= \case + True -> do + -- If we find a causal hash we have in the spine, we don't need to look further, + -- we can pass it on, then hang up the stream. + C.yield hash + False -> do + -- Otherwise we keep looking, maybe we'll have one further in. + findKnownDeps codebase + Nothing -> pure () + unpack :: SyncV2.CausalDependenciesChunk -> (Hash32, DependencyType) + unpack = \case + SyncV2.CausalHashDepC {causalHash, dependencyType} -> (causalHash, dependencyType) + haveCausalHash :: Codebase.Codebase IO v a -> Hash32 -> StreamM Bool + haveCausalHash codebase causalHash = do + liftIO $ Codebase.runTransaction codebase do + Q.causalExistsByHash32 causalHash + +------------------------------------------------------------------------------------------------------------------------ +-- Progress Tracking +------------------------------------------------------------------------------------------------------------------------ + +counterProgress :: (MonadIO m, MonadUnliftIO n) => (Int -> Text) -> ((Int -> m ()) -> n a) -> n a +counterProgress msgBuilder action = do counterVar <- IO.newTVarIO (0 :: Int) IO.withRunInIO \toIO -> do Console.Regions.displayConsoleRegions do Console.Regions.withConsoleRegion Console.Regions.Linear \region -> do Console.Regions.setConsoleRegion region do - processed <- IO.readTVar counterVar - pure $ - "\n Loading " - <> tShow processed - <> " entities...\n\n" + num <- IO.readTVar counterVar + pure $ msgBuilder num toIO $ action $ \i -> do liftIO $ IO.atomically (IO.modifyTVar' counterVar (+ i)) + +-- | Track how many entities have been downloaded using a counter stream. +withStreamProgressCallback :: (MonadIO m, MonadUnliftIO n) => Maybe Int -> (ConduitT i i m () -> n a) -> n a +withStreamProgressCallback total action = do + let msg n = "\n 📦 Unpacked " <> tShow n <> maybe "" (\total -> " / " <> tShow total) total <> " entities...\n\n" + let action' f = action (C.iterM \_i -> f 1) + counterProgress msg action' + +-- | Track how many entities have been saved. +withEntitySavingCallback :: (MonadUnliftIO m) => Maybe Int -> ((Int -> m ()) -> m a) -> m a +withEntitySavingCallback total action = do + let msg n = "\n 💾 Saved " <> tShow n <> maybe "" (\total -> " / " <> tShow total) total <> " new entities...\n\n" + counterProgress msg action + +-- | Track how many entities have been loaded. +withEntityLoadingCallback :: (MonadUnliftIO m) => ((Int -> m ()) -> m a) -> m a +withEntityLoadingCallback action = do + let msg n = "\n 📦 Unpacked " <> tShow n <> " entities...\n\n" + counterProgress msg action diff --git a/unison-share-api/src/Unison/SyncV2/API.hs b/unison-share-api/src/Unison/SyncV2/API.hs new file mode 100644 index 0000000000..ef80d3d1cf --- /dev/null +++ b/unison-share-api/src/Unison/SyncV2/API.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DataKinds #-} + +module Unison.SyncV2.API + ( API, + api, + Routes (..), + ) +where + +import Data.Proxy +import GHC.Generics (Generic) +import Servant.API +import Unison.SyncV2.Types +import Unison.Util.Servant.CBOR (CBOR) + +api :: Proxy API +api = Proxy + +type API = NamedRoutes Routes + +type DownloadEntitiesStream = + -- | The causal hash the client needs. The server should provide it and all of its dependencies + ReqBody '[CBOR, JSON] DownloadEntitiesRequest + :> StreamPost NoFraming OctetStream (SourceIO (CBORStream DownloadEntitiesChunk)) + +-- | Get the relevant dependencies of a causal, including the causal spine and the causal hashes of any library roots. +type CausalDependenciesStream = + ReqBody '[CBOR, JSON] CausalDependenciesRequest + :> StreamPost NoFraming OctetStream (SourceIO (CBORStream CausalDependenciesChunk)) + +data Routes mode = Routes + { downloadEntitiesStream :: mode :- "entities" :> "download" :> DownloadEntitiesStream, + causalDependenciesStream :: mode :- "entities" :> "dependencies" :> CausalDependenciesStream + } + deriving stock (Generic) diff --git a/unison-share-api/src/Unison/SyncV2/Types.hs b/unison-share-api/src/Unison/SyncV2/Types.hs index 2f4432ee74..0a716a5c37 100644 --- a/unison-share-api/src/Unison/SyncV2/Types.hs +++ b/unison-share-api/src/Unison/SyncV2/Types.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + module Unison.SyncV2.Types ( DownloadEntitiesRequest (..), DownloadEntitiesChunk (..), @@ -6,7 +8,11 @@ module Unison.SyncV2.Types StreamInitInfo (..), SyncError (..), DownloadEntitiesError (..), + CausalDependenciesRequest (..), + CausalDependenciesChunk (..), + DependencyType (..), CBORBytes (..), + CBORStream (..), EntityKind (..), serialiseCBORBytes, deserialiseOrFailCBORBytes, @@ -23,6 +29,7 @@ import Codec.Serialise qualified as CBOR import Codec.Serialise.Decoding qualified as CBOR import Control.Exception (Exception) import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=)) +import Data.Aeson qualified as Aeson import Data.Map (Map) import Data.Map qualified as Map import Data.Set (Set) @@ -32,7 +39,6 @@ import Data.Word (Word16, Word64) import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.TempEntity (TempEntity) import Unison.Core.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) -import Unison.Debug qualified as Debug import Unison.Hash32 (Hash32) import Unison.Prelude (From (..)) import Unison.Server.Orphans () @@ -186,7 +192,7 @@ optionalDecodeMapKey k m = Nothing -> pure Nothing Just bs -> Just <$> decodeUnknownCBORBytes bs --- | Serialised as a map to allow for future expansion +-- | Serialised as a map to be future compatible, allowing for future expansion. instance Serialise StreamInitInfo where encode (StreamInitInfo {version, entitySorting, numEntities, rootCausalHash, rootBranchRef}) = CBOR.encode @@ -199,18 +205,11 @@ instance Serialise StreamInitInfo where <> maybe [] (\br -> [("br", serialiseUnknownCBORBytes br)]) rootBranchRef ) decode = do - Debug.debugLogM Debug.Temp "Decoding StreamInitInfo" - Debug.debugLogM Debug.Temp "Decoding Map" m <- CBOR.decode - Debug.debugLogM Debug.Temp "Decoding Version" version <- decodeMapKey "v" m - Debug.debugLogM Debug.Temp "Decoding Entity Sorting" entitySorting <- decodeMapKey "es" m - Debug.debugLogM Debug.Temp "Decoding Number of Entities" numEntities <- (optionalDecodeMapKey "ne" m) - Debug.debugLogM Debug.Temp "Decoding Root Causal Hash" rootCausalHash <- decodeMapKey "rc" m - Debug.debugLogM Debug.Temp "Decoding Branch Ref" rootBranchRef <- optionalDecodeMapKey "br" m pure StreamInitInfo {version, entitySorting, numEntities, rootCausalHash, rootBranchRef} @@ -306,3 +305,85 @@ instance Serialise EntityKind where 3 -> pure TypeEntity 4 -> pure PatchEntity _ -> fail "invalid tag" + +------------------------------------------------------------------------------------------------------------------------ +-- Causal Dependencies + +data CausalDependenciesRequest = CausalDependenciesRequest + { branchRef :: BranchRef, + rootCausal :: HashJWT + } + deriving stock (Show, Eq, Ord) + +instance ToJSON CausalDependenciesRequest where + toJSON (CausalDependenciesRequest branchRef rootCausal) = + object + [ "branch_ref" .= branchRef, + "root_causal" .= rootCausal + ] + +instance FromJSON CausalDependenciesRequest where + parseJSON = Aeson.withObject "CausalDependenciesRequest" \obj -> do + branchRef <- obj .: "branch_ref" + rootCausal <- obj .: "root_causal" + pure CausalDependenciesRequest {..} + +instance Serialise CausalDependenciesRequest where + encode (CausalDependenciesRequest {branchRef, rootCausal}) = + encode branchRef <> encode rootCausal + decode = CausalDependenciesRequest <$> decode <*> decode + +data DependencyType + = -- This is a top-level history node of the root we're pulling. + CausalSpineDependency + | -- This is the causal root of a library dependency. + LibDependency + deriving (Show, Eq, Ord) + +instance Serialise DependencyType where + encode = \case + CausalSpineDependency -> CBOR.encodeWord8 0 + LibDependency -> CBOR.encodeWord8 1 + decode = do + tag <- CBOR.decodeWord8 + case tag of + 0 -> pure CausalSpineDependency + 1 -> pure LibDependency + _ -> fail "invalid tag" + +instance ToJSON DependencyType where + toJSON = \case + CausalSpineDependency -> "causal_spine" + LibDependency -> "lib" + +instance FromJSON DependencyType where + parseJSON = Aeson.withText "DependencyType" \case + "causal_spine" -> pure CausalSpineDependency + "lib" -> pure LibDependency + _ -> fail "invalid DependencyType" + +-- | A chunk of the download entities response stream. +data CausalDependenciesChunk + = CausalHashDepC {causalHash :: Hash32, dependencyType :: DependencyType} + deriving (Show, Eq, Ord) + +data CausalDependenciesChunkTag = CausalHashDepChunkTag + deriving (Show, Eq, Ord) + +instance Serialise CausalDependenciesChunkTag where + encode = \case + CausalHashDepChunkTag -> CBOR.encodeWord8 0 + decode = do + tag <- CBOR.decodeWord8 + case tag of + 0 -> pure CausalHashDepChunkTag + _ -> fail "invalid tag" + +instance Serialise CausalDependenciesChunk where + encode = \case + (CausalHashDepC {causalHash, dependencyType}) -> do + encode CausalHashDepChunkTag <> CBOR.encode causalHash <> CBOR.encode dependencyType + decode = do + tag <- decode + case tag of + CausalHashDepChunkTag -> CausalHashDepC <$> CBOR.decode <*> CBOR.decode diff --git a/unison-share-api/src/Unison/Util/Servant/CBOR.hs b/unison-share-api/src/Unison/Util/Servant/CBOR.hs index 18fd94904c..580b1a7124 100644 --- a/unison-share-api/src/Unison/Util/Servant/CBOR.hs +++ b/unison-share-api/src/Unison/Util/Servant/CBOR.hs @@ -5,6 +5,7 @@ module Unison.Util.Servant.CBOR ( CBOR, UnknownCBORBytes, CBORBytes (..), + CBORStream (..), deserialiseOrFailCBORBytes, serialiseCBORBytes, decodeCBORBytes, @@ -86,3 +87,14 @@ serialiseUnknownCBORBytes = CBORBytes . CBOR.serialise data Unknown type UnknownCBORBytes = CBORBytes Unknown + +-- | Wrapper for a stream of CBOR data. Each chunk may not be a complete CBOR value, but the concatenation of all the chunks is a valid CBOR stream. +newtype CBORStream a = CBORStream BL.ByteString + deriving (Serialise) via (BL.ByteString) + deriving (Eq, Show, Ord) + +instance MimeRender OctetStream (CBORStream a) where + mimeRender Proxy (CBORStream bs) = bs + +instance MimeUnrender OctetStream (CBORStream a) where + mimeUnrender Proxy bs = Right (CBORStream bs) diff --git a/unison-share-api/unison-share-api.cabal b/unison-share-api/unison-share-api.cabal index d56eb5fb7a..d30617278b 100644 --- a/unison-share-api/unison-share-api.cabal +++ b/unison-share-api/unison-share-api.cabal @@ -50,6 +50,7 @@ library Unison.Sync.Common Unison.Sync.EntityValidation Unison.Sync.Types + Unison.SyncV2.API Unison.SyncV2.Types Unison.Util.Find Unison.Util.Servant.CBOR diff --git a/unison-src/transcripts/idempotent/api-list-projects-branches.md b/unison-src/transcripts/idempotent/api-list-projects-branches.md index 2f3bc28b22..0599cbf799 100644 --- a/unison-src/transcripts/idempotent/api-list-projects-branches.md +++ b/unison-src/transcripts/idempotent/api-list-projects-branches.md @@ -8,17 +8,15 @@ lump many of those together. Doing it this way ensures both the creation timesta the same direction so we don't end up with flaky non-deterministic tests. ``` ucm :hide -scratch/main> project.create-empty project-cherry +project-apple/main> project.create-empty project-cherry -scratch/main> project.create-empty project-banana - -scratch/main> project.create-empty project-apple +project-apple/main> project.create-empty project-banana project-apple/main> branch a-branch-cherry -project-apple/main> branch a-branch-banana +project-apple/a-branch-cherry> branch a-branch-banana -project-apple/main> branch a-branch-apple +project-apple/a-branch-banana> branch a-branch-apple ``` ``` api diff --git a/unison-src/transcripts/idempotent/api-list-projects-branches.output.md b/unison-src/transcripts/idempotent/api-list-projects-branches.output.md new file mode 100644 index 0000000000..0599cbf799 --- /dev/null +++ b/unison-src/transcripts/idempotent/api-list-projects-branches.output.md @@ -0,0 +1,74 @@ +# List Projects And Branches Test + +I create projects and branches in reverse alphabetical order, and starting with `z` +to place them after `main` alphabetically. +This is because the results from the listing endpoints is sorted by (timestamp, name); but +the default sqlite timestamp only has second-level precision and the transcript will sometimes +lump many of those together. Doing it this way ensures both the creation timestamp and name sort +the same direction so we don't end up with flaky non-deterministic tests. + +``` ucm :hide +project-apple/main> project.create-empty project-cherry + +project-apple/main> project.create-empty project-banana + +project-apple/main> branch a-branch-cherry + +project-apple/a-branch-cherry> branch a-branch-banana + +project-apple/a-branch-banana> branch a-branch-apple +``` + +``` api +-- Should list all projects +GET /api/projects + [ + { + "activeBranchRef": "a-branch-apple", + "projectName": "project-apple" + }, + { + "activeBranchRef": "main", + "projectName": "project-banana" + }, + { + "activeBranchRef": "main", + "projectName": "project-cherry" + }, + { + "activeBranchRef": "main", + "projectName": "scratch" + } + ] +-- Can query for some infix of the project name +GET /api/projects?query=bana + [ + { + "activeBranchRef": "main", + "projectName": "project-banana" + } + ] +-- Should list all branches +GET /api/projects/project-apple/branches + [ + { + "branchName": "a-branch-apple" + }, + { + "branchName": "a-branch-banana" + }, + { + "branchName": "a-branch-cherry" + }, + { + "branchName": "main" + } + ] +-- Can query for some infix of the project name +GET /api/projects/project-apple/branches?query=bana + [ + { + "branchName": "a-branch-banana" + } + ] +``` diff --git a/unison-src/transcripts/project-outputs/docs/configuration.output.md b/unison-src/transcripts/project-outputs/docs/configuration.output.md index 0bf4d06de5..bcae1f8b5a 100644 --- a/unison-src/transcripts/project-outputs/docs/configuration.output.md +++ b/unison-src/transcripts/project-outputs/docs/configuration.output.md @@ -9,6 +9,7 @@ - [`UNISON_SHARE_ACCESS_TOKEN`](#unison_share_access_token) - [`UNISON_READONLY`](#unison_readonly) - [`UNISON_ENTITY_VALIDATION`](#unison_entity_validation) + - [`UNISON_SYNC_VERSION`](#unison_sync_version) - [Local Codebase Server](#local-codebase-server) - [Codebase Configuration](#codebase-configuration) @@ -116,6 +117,14 @@ Defaults to enabled. $ UNISON_ENTITY_VALIDATION="false" ucm ``` +### `UNISON_SYNC_VERSION` + +Allows enabling the experimental Sync Version 2 protocol when downloading code from Share. + +``` sh +$ UNISON_ENTITY_VALIDATION="2" ucm +``` + ### `UNISON_PULL_WORKERS` Allows setting the number of workers to use when pulling from a codebase server.