ui.scm 92 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322
  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2012-2023 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2013, 2018 Mark H Weaver <mhw@netris.org>
  4. ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
  5. ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
  6. ;;; Copyright © 2014 Cyrill Schenkel <cyrill.schenkel@gmail.com>
  7. ;;; Copyright © 2014, 2015, 2017 Alex Kost <alezost@gmail.com>
  8. ;;; Copyright © 2015 David Thompson <davet@gnu.org>
  9. ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
  10. ;;; Copyright © 2016 Roel Janssen <roel@gnu.org>
  11. ;;; Copyright © 2016 Benz Schenk <benz.schenk@uzh.ch>
  12. ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
  13. ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
  14. ;;; Copyright © 2019 Chris Marusich <cmmarusich@gmail.com>
  15. ;;; Copyright © 2019, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
  16. ;;; Copyright © 2019, 2021 Simon Tournier <zimon.toutoune@gmail.com>
  17. ;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net>
  18. ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
  19. ;;; Copyright © 2018 Steve Sprang <scs@stevesprang.com>
  20. ;;; Copyright © 2022 Taiju HIGASHI <higashi@taiju.info>
  21. ;;; Copyright © 2022 Liliana Marie Prikler <liliana.prikler@gmail.com>
  22. ;;; Copyright © 2023 Sarthak Shah <shahsarthakw@gmail.com> ; g23
  23. ;;;
  24. ;;; This file is part of GNU Guix.
  25. ;;;
  26. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  27. ;;; under the terms of the GNU General Public License as published by
  28. ;;; the Free Software Foundation; either version 3 of the License, or (at
  29. ;;; your option) any later version.
  30. ;;;
  31. ;;; GNU Guix is distributed in the hope that it will be useful, but
  32. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  33. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  34. ;;; GNU General Public License for more details.
  35. ;;;
  36. ;;; You should have received a copy of the GNU General Public License
  37. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  38. (define-module (guix ui)
  39. #:use-module (guix i18n)
  40. #:use-module (guix colors)
  41. #:use-module (guix diagnostics)
  42. #:use-module (guix gexp)
  43. #:use-module (guix sets)
  44. #:use-module (guix utils)
  45. #:use-module (guix store)
  46. #:use-module (guix config)
  47. #:use-module (guix packages)
  48. #:autoload (guix parameters) ; g23
  49. (all-spec-parameters-with-types package-parameter-spec) ; g23
  50. #:use-module (guix profiles)
  51. #:use-module (guix derivations)
  52. #:use-module (guix build-system)
  53. #:use-module (guix serialization)
  54. #:use-module ((guix licenses)
  55. #:select (license? license-name license-uri))
  56. #:use-module ((guix build syscalls)
  57. #:select (free-disk-space terminal-columns terminal-rows
  58. with-file-lock/no-wait))
  59. #:use-module ((guix build utils)
  60. ;; XXX: All we need are the bindings related to
  61. ;; '&invoke-error'. However, to work around the bug described
  62. ;; in 5d669883ecc104403c5d3ba7d172e9c02234577c, #:hide
  63. ;; unwanted bindings instead of #:select'ing the needed
  64. ;; bindings.
  65. #:hide (package-name->name+version
  66. ;; Avoid "overrides core binding" warning.
  67. delete))
  68. #:use-module (srfi srfi-1)
  69. #:use-module (srfi srfi-9 gnu)
  70. #:use-module (srfi srfi-11)
  71. #:use-module (srfi srfi-19)
  72. #:use-module (srfi srfi-26)
  73. #:use-module (srfi srfi-31)
  74. #:use-module (srfi srfi-34)
  75. #:use-module (srfi srfi-35)
  76. #:autoload (ice-9 ftw) (scandir)
  77. #:use-module (ice-9 match)
  78. #:use-module (ice-9 format)
  79. #:use-module (ice-9 regex)
  80. #:autoload (ice-9 popen) (open-pipe* close-pipe)
  81. #:autoload (system repl repl) (start-repl)
  82. #:autoload (system repl debug) (make-debug stack->vector)
  83. #:use-module (texinfo)
  84. #:use-module (texinfo plain-text)
  85. #:use-module (texinfo string-utils)
  86. ;; Re-exports for backward compatibility.
  87. #:re-export (G_ N_ P_ ;now in (guix i18n)
  88. warning info report-error leave ;now in (guix diagnostics)
  89. location->string
  90. guix-warning-port program-name)
  91. #:export (display-hint
  92. make-user-module
  93. load*
  94. warn-about-load-error
  95. show-version-and-exit
  96. show-bug-report-information
  97. make-regexp*
  98. string->number*
  99. size->number
  100. show-derivation-outputs
  101. build-notifier
  102. show-what-to-build
  103. show-what-to-build*
  104. show-manifest-transaction
  105. guard*
  106. call-with-error-handling
  107. with-error-handling
  108. with-unbound-variable-handling
  109. leave-on-EPIPE
  110. read/eval
  111. read/eval-package-expression
  112. check-available-space
  113. indented-string
  114. fill-paragraph
  115. %text-width
  116. texi->plain-text
  117. package-description-string
  118. package-synopsis-string
  119. string->recutils
  120. package->recutils
  121. package-specification->name+version+output
  122. pager-wrapped-port
  123. with-paginated-output-port
  124. relevance
  125. package-relevance
  126. display-search-results
  127. with-profile-lock
  128. string->generations
  129. string->duration
  130. matching-generations
  131. display-generation
  132. display-profile-content
  133. display-profile-content-diff
  134. roll-back*
  135. switch-to-generation*
  136. delete-generation*
  137. %default-message-language
  138. current-message-language
  139. run-guix-command
  140. run-guix
  141. guix-main))
  142. ;;; Commentary:
  143. ;;;
  144. ;;; User interface facilities for command-line tools.
  145. ;;;
  146. ;;; Code:
  147. (define (print-unbound-variable-error port key args default-printer)
  148. ;; Print unbound variable errors more nicely, and in the right language.
  149. (match args
  150. ((proc message (variable) _ ...)
  151. ;; We can always omit PROC because when it's useful (i.e., different from
  152. ;; "module-lookup"), it gets displayed before.
  153. (format port (G_ "error: ~a: unbound variable") variable))
  154. (_
  155. (default-printer))))
  156. (set-exception-printer! 'unbound-variable print-unbound-variable-error)
  157. (define (make-user-module modules)
  158. "Return a new user module with the additional MODULES loaded."
  159. ;; Module in which the machine description file is loaded.
  160. (let ((module (make-fresh-user-module)))
  161. (for-each (lambda (iface)
  162. (module-use! module (resolve-interface iface)))
  163. modules)
  164. module))
  165. (define (last-frame-with-source stack)
  166. "Walk stack upwards and return the last frame that has source location
  167. information, or #f if it could not be found."
  168. (define (frame-with-source frame)
  169. ;; Walk from FRAME upwards until source location information is found.
  170. (let loop ((frame frame)
  171. (previous frame))
  172. (if (not frame)
  173. previous
  174. ;; On Guile 3, the latest frame with source may be that of
  175. ;; 'raise-exception' in boot-9.scm. Skip it.
  176. (if (and (frame-source frame)
  177. (not (eq? 'raise-exception (frame-procedure-name frame))))
  178. frame
  179. (loop (frame-previous frame) frame)))))
  180. (let* ((depth (stack-length stack))
  181. (last (and (> depth 0) (stack-ref stack 0))))
  182. (frame-with-source (if (> depth 1)
  183. (stack-ref stack 1) ;skip the 'throw' frame
  184. last))))
  185. (define-syntax-rule (without-compiler-optimizations exp)
  186. ;; Compile with the baseline compiler (-O1), which is much less expensive
  187. ;; than -O2.
  188. (parameterize (((@ (system base compile) default-optimization-level) 1))
  189. exp))
  190. (define* (load* file user-module
  191. #:key (on-error 'nothing-special))
  192. "Load the user provided Scheme source code FILE."
  193. (define (error-string frame args)
  194. (call-with-output-string
  195. (lambda (port)
  196. (apply display-error frame port (cdr args)))))
  197. (define tag
  198. (make-prompt-tag "user-code"))
  199. (catch #t
  200. (lambda ()
  201. ;; XXX: Force a recompilation to avoid ABI issues.
  202. (set! %fresh-auto-compile #t)
  203. (set! %load-should-auto-compile #t)
  204. (save-module-excursion
  205. (lambda ()
  206. (set-current-module user-module)
  207. ;; Hide the "auto-compiling" messages.
  208. (parameterize ((current-warning-port (%make-void-port "w")))
  209. (call-with-prompt tag
  210. (lambda ()
  211. ;; Give 'load' an absolute file name so that it doesn't try to
  212. ;; search for FILE in %LOAD-PATH. Note: use 'load', not
  213. ;; 'primitive-load', so that FILE is compiled, which then allows
  214. ;; us to provide better error reporting with source line numbers.
  215. (without-compiler-optimizations
  216. (load (canonicalize-path file))))
  217. (const #f))))))
  218. (lambda _
  219. ;; XXX: Errors are reported from the pre-unwind handler below, but
  220. ;; calling 'exit' from there has no effect, so we call it here.
  221. (exit 1))
  222. (rec (handle-error . args)
  223. ;; Capture the stack up to this procedure call, excluded, and pass
  224. ;; the faulty stack frame to 'report-load-error'.
  225. (let* ((stack (make-stack #t handle-error tag))
  226. (frame (last-frame-with-source stack)))
  227. (report-load-error file args frame)
  228. (case on-error
  229. ((debug)
  230. (newline)
  231. (display (G_ "entering debugger; type ',bt' for a backtrace\n"))
  232. (start-repl #:debug (make-debug (stack->vector stack) 0
  233. (error-string frame args)
  234. #f)))
  235. ((backtrace)
  236. (newline (current-error-port))
  237. (display-backtrace stack (current-error-port)))
  238. (else
  239. #t))))))
  240. (define (known-variable-definition variable)
  241. "Search among the currently loaded modules one that defines a variable named
  242. VARIABLE and return it, or #f if none was found."
  243. (define (module<? m1 m2)
  244. (match (module-name m2)
  245. (('gnu _ ...) #t)
  246. (('guix _ ...)
  247. (match (module-name m1)
  248. (('gnu _ ...) #f)
  249. (_ #t)))
  250. (_ #f)))
  251. (let loop ((modules (list (resolve-module '() #f #f #:ensure #f)))
  252. (suggestions '())
  253. (visited (setq)))
  254. (match modules
  255. (()
  256. ;; Pick the "best" suggestion.
  257. (match (sort suggestions module<?)
  258. (() #f)
  259. ((first _ ...) first)))
  260. ((head tail ...)
  261. (if (set-contains? visited head)
  262. (loop tail suggestions visited)
  263. (let ((visited (set-insert head visited))
  264. (next (append tail
  265. (hash-map->list (lambda (name module)
  266. module)
  267. (module-submodules head)))))
  268. (match (and=> (module-public-interface head)
  269. (cut module-local-variable <> variable))
  270. (#f (loop next suggestions visited))
  271. (_
  272. (match (module-name head)
  273. (('gnu _ ...) head) ;must be that one
  274. (_ (loop next (cons head suggestions) visited)))))))))))
  275. (define %hint-color (color BOLD CYAN))
  276. (define (texinfo-quote str)
  277. "Quote at signs and braces in STR to obtain its Texinfo represention."
  278. (list->string
  279. (string-fold-right (lambda (chr result)
  280. (if (memq chr '(#\@ #\{ #\}))
  281. (cons* #\@ chr result)
  282. (cons chr result)))
  283. '()
  284. str)))
  285. (define* (display-hint message
  286. #:key (port (current-error-port))
  287. #:rest arguments)
  288. "Display MESSAGE, a l10n message possibly containing Texinfo markup and
  289. 'format' escape, to PORT. ARGUMENTS is a (possibly empty) list of strings or
  290. other objects that must match the 'format' escapes in MESSAGE."
  291. (define colorize
  292. (if (color-output? port)
  293. (lambda (str)
  294. (colorize-string str %hint-color))
  295. identity))
  296. (display (colorize (G_ "hint: ")) port)
  297. (display
  298. ;; XXX: We should arrange so that the initial indent is wider.
  299. (parameterize ((%text-width (max 15 (- (terminal-columns) 5))))
  300. (texi->plain-text (match arguments
  301. (() (format #f message))
  302. (_ (apply format #f message
  303. (map (match-lambda
  304. ((? string? str)
  305. (texinfo-quote str))
  306. (obj
  307. (texinfo-quote
  308. (object->string obj))))
  309. arguments))))))
  310. port))
  311. (define* (report-unbound-variable-error args #:key frame)
  312. "Return the given unbound-variable error, where ARGS is the list of 'throw'
  313. arguments."
  314. (match args
  315. ((key . args)
  316. (print-exception (current-error-port) frame key args)))
  317. (match args
  318. (('unbound-variable proc message (variable) _ ...)
  319. (match (known-variable-definition variable)
  320. (#f
  321. (display-hint (G_ "Did you forget a @code{use-modules} form?")))
  322. ((? module? module)
  323. (display-hint (G_ "Did you forget @code{(use-modules ~a)}?")
  324. (module-name module)))))))
  325. (define (check-module-matches-file module file)
  326. "Check whether FILE starts with 'define-module MODULE' and print a hint if
  327. it doesn't."
  328. ;; This is a common mistake when people start writing their own package
  329. ;; definitions and try loading them with 'guix build -L …', so help them
  330. ;; diagnose the problem.
  331. (define (hint)
  332. (display-hint (G_ "File @file{~a} should probably start with:
  333. @example\n(define-module ~a)\n@end example")
  334. file module))
  335. (catch 'system-error
  336. (lambda ()
  337. (let* ((sexp (call-with-input-file file read))
  338. (loc (and (pair? sexp)
  339. (source-properties->location (source-properties sexp)))))
  340. (match sexp
  341. (('define-module (names ...) _ ...)
  342. (unless (equal? module names)
  343. (warning loc
  344. (G_ "module name ~a does not match file name '~a'~%")
  345. names (module->source-file-name module))
  346. (hint)))
  347. ((? eof-object?)
  348. (warning (G_ "~a: file is empty~%") file))
  349. (else
  350. (hint)))))
  351. (const #f)))
  352. (define* (report-load-error file args #:optional frame)
  353. "Report the failure to load FILE, a user-provided Scheme file.
  354. ARGS is the list of arguments received by the 'throw' handler."
  355. (match args
  356. (('system-error . rest)
  357. (let ((err (system-error-errno args)))
  358. (report-error (G_ "failed to load '~a': ~a~%") file (strerror err))))
  359. (('read-error _ message args ...)
  360. ;; Guile's missing-paren messages are obscure so we make them more
  361. ;; intelligible here.
  362. (if (or (string-suffix? "end of file" message) ;Guile < 3.0.6
  363. (and (string-contains message "unexpected end of input")
  364. (member '(#\)) args)))
  365. (let ((location (string-take message
  366. (+ 2 (string-contains message ": ")))))
  367. (format (current-error-port) (G_ "~amissing closing parenthesis~%")
  368. location))
  369. (report-error (G_ "read error while loading '~a': ~a~%")
  370. file (apply format #f message args))))
  371. (('syntax-error proc message properties form subform . rest)
  372. (let ((loc (source-properties->location properties)))
  373. (report-error loc (G_ "~s: ~a~%")
  374. (or subform form) message)))
  375. (('unbound-variable _ ...)
  376. (report-unbound-variable-error args #:frame frame))
  377. (((or 'srfi-34 '%exception) obj)
  378. (cond ((message-condition? obj)
  379. (report-error (and (error-location? obj)
  380. (error-location obj))
  381. (G_ "~a~%")
  382. (gettext (condition-message obj) %gettext-domain)))
  383. ((formatted-message? obj)
  384. (apply report-error
  385. (and (error-location? obj) (error-location obj))
  386. (gettext (formatted-message-string obj) %gettext-domain)
  387. (formatted-message-arguments obj)))
  388. (else
  389. (report-error (G_ "exception thrown: ~s~%") obj)))
  390. (when (fix-hint? obj)
  391. (display-hint (condition-fix-hint obj))))
  392. ((key args ...)
  393. (report-error (G_ "failed to load '~a':~%") file)
  394. (match args
  395. (((? symbol? proc) (? string? message) (args ...) . rest)
  396. (display-error frame (current-error-port) proc message
  397. args rest))
  398. (_
  399. ;; Some exceptions like 'git-error' do not follow Guile's convention
  400. ;; above and need to be printed with 'print-exception'.
  401. (print-exception (current-error-port) frame key args))))))
  402. (define (warn-about-load-error file module args) ;FIXME: factorize with ↑
  403. "Report the failure to load FILE, a user-provided Scheme file, without
  404. exiting. ARGS is the list of arguments received by the 'throw' handler."
  405. (match args
  406. (('system-error . rest)
  407. (let ((err (system-error-errno args)))
  408. (warning (G_ "failed to load '~a': ~a~%") module (strerror err))))
  409. (('syntax-error proc message properties form . rest)
  410. (let ((loc (source-properties->location properties)))
  411. (warning loc (G_ "~a~%") message)))
  412. (('unbound-variable _ ...)
  413. (report-unbound-variable-error args))
  414. (((or 'srfi-34 '%exception) obj)
  415. (cond ((message-condition? obj)
  416. (warning (G_ "failed to load '~a': ~a~%")
  417. file
  418. (gettext (condition-message obj) %gettext-domain)))
  419. ((formatted-message? obj)
  420. (warning (G_ "failed to load '~a': ~a~%")
  421. file
  422. (apply format #f
  423. (gettext (formatted-message-string obj)
  424. %gettext-domain)
  425. (formatted-message-arguments obj))))
  426. (else
  427. (warning (G_ "failed to load '~a': exception thrown: ~s~%")
  428. file obj))))
  429. ((error args ...)
  430. (warning (G_ "failed to load '~a':~%") module)
  431. (apply display-error #f (current-error-port) args)
  432. (check-module-matches-file module file))))
  433. (define (call-with-unbound-variable-handling thunk)
  434. (define tag
  435. (make-prompt-tag "user-code"))
  436. (catch 'unbound-variable
  437. (lambda ()
  438. (call-with-prompt tag
  439. thunk
  440. (const #f)))
  441. (const #t)
  442. (rec (handle-error . args)
  443. (let* ((stack (make-stack #t handle-error tag))
  444. (frame (and stack (last-frame-with-source stack))))
  445. (report-unbound-variable-error args #:frame frame)
  446. (exit 1)))))
  447. (define-syntax-rule (with-unbound-variable-handling exp ...)
  448. "Capture 'unbound-variable' exceptions in the dynamic extent of EXP... and
  449. report them in a user-friendly way."
  450. (call-with-unbound-variable-handling (lambda () exp ...)))
  451. (define %default-message-language
  452. ;; Default language to use for messages.
  453. (make-parameter "en"))
  454. (define (current-message-language)
  455. "Return the language used for messages according to the current locale.
  456. Return %DEFAULT-MESSAGE-LANGUAGE if that information could not be obtained. The
  457. result is an ISO-639-2 language code such as \"ar\", without the territory
  458. part."
  459. (let ((locale (setlocale LC_MESSAGES)))
  460. (match (string-index locale #\_)
  461. (#f locale)
  462. (index (string-take locale index)))))
  463. (define (install-locale)
  464. "Install the current locale settings."
  465. (catch 'system-error
  466. (lambda _
  467. (setlocale LC_ALL ""))
  468. (lambda args
  469. (display-hint (G_ "Consider installing the @code{glibc-locales} package
  470. and defining @code{GUIX_LOCPATH}, along these lines:
  471. @example
  472. guix install glibc-locales
  473. export GUIX_LOCPATH=\"$HOME/.guix-profile/lib/locale\"
  474. @end example
  475. See the \"Application Setup\" section in the manual, for more info.\n"))
  476. ;; We're now running in the "C" locale. Try to install a UTF-8 locale
  477. ;; instead. This one is guaranteed to be available in 'guix' from 'guix
  478. ;; pull'.
  479. (false-if-exception (setlocale LC_ALL "en_US.utf8")))))
  480. (define (initialize-guix)
  481. "Perform the usual initialization for stand-alone Guix commands."
  482. ;; By default don't annoy users with deprecation warnings. In practice,
  483. ;; 'define-deprecated' in (ice-9 deprecated) arranges so that those warnings
  484. ;; are emitted at expansion-time only, but there are cases where they could
  485. ;; slip through, for instance when interpreting code.
  486. (unless (getenv "GUILE_WARN_DEPRECATED")
  487. (debug-disable 'warn-deprecated))
  488. (install-locale)
  489. (textdomain %gettext-domain)
  490. ;; Ignore SIGPIPE. If the daemon closes the connection, we prefer to be
  491. ;; notified via an EPIPE later.
  492. (sigaction SIGPIPE SIG_IGN)
  493. (setvbuf (current-output-port) 'line)
  494. (setvbuf (current-error-port) 'line))
  495. (define* (show-version-and-exit #:optional (command (car (command-line))))
  496. "Display version information for COMMAND and `(exit 0)'."
  497. (simple-format #t "~a (~a) ~a~%"
  498. command %guix-package-name %guix-version)
  499. (format #t "Copyright ~a 2023 ~a"
  500. ;; TRANSLATORS: Translate "(C)" to the copyright symbol
  501. ;; (C-in-a-circle), if this symbol is available in the user's
  502. ;; locale. Otherwise, do not translate "(C)"; leave it as-is. */
  503. (G_ "(C)")
  504. (G_ "the Guix authors\n"))
  505. (display (G_"\
  506. License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
  507. This is free software: you are free to change and redistribute it.
  508. There is NO WARRANTY, to the extent permitted by law.
  509. "))
  510. (exit 0))
  511. (define (show-bug-report-information)
  512. ;; TRANSLATORS: The placeholder indicates the bug-reporting address for this
  513. ;; package. Please add another line saying "Report translation bugs to
  514. ;; ...\n" with the address for translation bugs (typically your translation
  515. ;; team's web or email address).
  516. (format #t (G_ "
  517. Report bugs to: ~a.") %guix-bug-report-address)
  518. (format #t (G_ "
  519. ~a home page: <~a>") %guix-package-name %guix-home-page-url)
  520. (format #t (G_ "
  521. General help using Guix and GNU software: <~a>")
  522. ;; TRANSLATORS: Change the "/en" bit of this URL appropriately if
  523. ;; the web site is translated in your language.
  524. (G_ "https://guix.gnu.org/en/help/"))
  525. (newline))
  526. (define (augmented-system-error-handler file)
  527. "Return a 'system-error' handler that mentions FILE in its message."
  528. (lambda (key proc fmt args errno)
  529. ;; Augment the FMT and ARGS with information about TARGET (this
  530. ;; information is missing as of Guile 2.0.11, making the exception
  531. ;; uninformative.)
  532. (apply throw key proc "~A: ~S"
  533. (list (strerror (car errno)) file)
  534. (list errno))))
  535. (define-syntax apply-formals
  536. (syntax-rules ()
  537. ((_ proc (args ...)) (proc args ...))
  538. ((_ proc (arg1 args ... . rest)) (apply proc arg1 args ... rest))))
  539. (define-syntax-rule (error-reporting-wrapper proc formals file)
  540. "Wrap PROC such that its 'system-error' exceptions are augmented to mention
  541. FILE."
  542. (let ((real-proc (@ (guile) proc)))
  543. (lambda formals
  544. (catch 'system-error
  545. (lambda ()
  546. (apply-formals real-proc formals))
  547. (augmented-system-error-handler file)))))
  548. (set! symlink
  549. ;; We 'set!' the global binding because (gnu build ...) modules and similar
  550. ;; typically don't use (guix ui).
  551. (error-reporting-wrapper symlink (source target) target))
  552. (set! copy-file
  553. ;; Note: here we use 'set!', not #:replace, because UIs typically use
  554. ;; 'copy-recursively', which doesn't use (guix ui).
  555. (error-reporting-wrapper copy-file (source target) target))
  556. (set! canonicalize-path
  557. (error-reporting-wrapper canonicalize-path (file) file))
  558. (set! delete-file
  559. (error-reporting-wrapper delete-file (file) file))
  560. (set! execlp
  561. (error-reporting-wrapper execlp (filename . args) filename))
  562. (set! mkdir
  563. (error-reporting-wrapper mkdir (directory . args) directory))
  564. (define (make-regexp* regexp . flags)
  565. "Like 'make-regexp' but error out if REGEXP is invalid, reporting the error
  566. nicely."
  567. (catch 'regular-expression-syntax
  568. (lambda ()
  569. (apply make-regexp regexp flags))
  570. (lambda (key proc message . rest)
  571. (leave (G_ "'~a' is not a valid regular expression: ~a~%")
  572. regexp message))))
  573. (define (string->number* str)
  574. "Like `string->number', but error out with an error message on failure."
  575. (or (string->number str)
  576. (leave (G_ "~a: invalid number~%") str)))
  577. (define (size->number str)
  578. "Convert STR, a storage measurement representation such as \"1024\" or
  579. \"1MiB\", to a number of bytes. Raise an error if STR could not be
  580. interpreted."
  581. (define unit-pos
  582. (string-rindex str
  583. (char-set-union (char-set #\.) char-set:digit)))
  584. (define unit
  585. (and unit-pos (substring str (+ 1 unit-pos))))
  586. (let* ((numstr (if unit-pos
  587. (substring str 0 (+ 1 unit-pos))
  588. str))
  589. (num (string->number numstr)))
  590. (unless num
  591. (leave (G_ "invalid number: ~a~%") numstr))
  592. ((compose inexact->exact round)
  593. (* num
  594. (match unit
  595. ((or "KiB" "K" "k") (expt 2 10))
  596. ((or "MiB" "M") (expt 2 20))
  597. ((or "GiB" "G") (expt 2 30))
  598. ((or "TiB" "T") (expt 2 40))
  599. ((or "PiB" "P") (expt 2 50))
  600. ((or "EiB" "E") (expt 2 60))
  601. ((or "ZiB" "Z") (expt 2 70))
  602. ((or "YiB" "Y") (expt 2 80))
  603. ("kB" (expt 10 3))
  604. ("MB" (expt 10 6))
  605. ("GB" (expt 10 9))
  606. ("TB" (expt 10 12))
  607. ("PB" (expt 10 15))
  608. ("EB" (expt 10 18))
  609. ("ZB" (expt 10 21))
  610. ("YB" (expt 10 24))
  611. ("" 1)
  612. (x
  613. (leave (G_ "unknown unit: ~a~%") unit)))))))
  614. (define (display-collision-resolution-hint collision)
  615. "Display hints on how to resolve COLLISION, a &profile-collistion-error."
  616. (define (top-most-entry entry)
  617. (let loop ((entry entry))
  618. (match (force (manifest-entry-parent entry))
  619. (#f entry)
  620. (parent (loop parent)))))
  621. (let* ((first (profile-collision-error-entry collision))
  622. (second (profile-collision-error-conflict collision))
  623. (name1 (manifest-entry-name (top-most-entry first)))
  624. (name2 (manifest-entry-name (top-most-entry second))))
  625. (if (string=? name1 name2)
  626. (display-hint (G_ "You cannot have two different versions
  627. or variants of @code{~a} in the same profile.")
  628. name1)
  629. (display-hint (G_ "Try upgrading both @code{~a} and @code{~a},
  630. or remove one of them from the profile.")
  631. name1 name2))))
  632. ;; On Guile 3.0, in 'call-with-error-handling' we need to re-raise. To
  633. ;; preserve useful backtraces in case of unhandled errors, we want that to
  634. ;; happen before the stack has been unwound, hence 'guard*'.
  635. (define-syntax-rule (guard* (var clauses ...) exp ...)
  636. "This variant of SRFI-34 'guard' does not unwind the stack before
  637. evaluating the tests and bodies of CLAUSES."
  638. (with-exception-handler
  639. (lambda (var)
  640. (cond clauses ... (else (raise var))))
  641. (lambda () exp ...)
  642. #:unwind? #f))
  643. (define (call-with-error-handling thunk)
  644. "Call THUNK within a user-friendly error handler."
  645. (define (port-filename* port)
  646. ;; 'port-filename' returns #f for non-file ports, but it raises an
  647. ;; exception for file ports that are closed. Work around that.
  648. (and (not (port-closed? port))
  649. (port-filename port)))
  650. (guard* (c ((package-input-error? c)
  651. (let* ((package (package-error-package c))
  652. (input (package-error-invalid-input c))
  653. (location (package-location package))
  654. (file (location-file location))
  655. (line (location-line location))
  656. (column (location-column location)))
  657. (leave (G_ "~a:~a:~a: package `~a' has an invalid input: ~s~%")
  658. file line column
  659. (package-full-name package) input)))
  660. ((package-cross-build-system-error? c)
  661. (let* ((package (package-error-package c))
  662. (loc (package-location package))
  663. (system (package-build-system package)))
  664. (leave (G_ "~a: ~a: build system `~a' does not support cross builds~%")
  665. (location->string loc)
  666. (package-full-name package)
  667. (build-system-name system))))
  668. ((gexp-input-error? c)
  669. (let ((input (gexp-error-invalid-input c)))
  670. (leave (G_ "~s: invalid G-expression input~%")
  671. (gexp-error-invalid-input c))))
  672. ((profile-not-found-error? c)
  673. (leave (G_ "profile '~a' does not exist~%")
  674. (profile-error-profile c)))
  675. ((missing-generation-error? c)
  676. (leave (G_ "generation ~a of profile '~a' does not exist~%")
  677. (missing-generation-error-generation c)
  678. (profile-error-profile c)))
  679. ((unmatched-pattern-error? c)
  680. (let ((pattern (unmatched-pattern-error-pattern c)))
  681. (leave (G_ "package '~a~@[@~a~]~@[:~a~]' not found in profile~%")
  682. (manifest-pattern-name pattern)
  683. (manifest-pattern-version pattern)
  684. (match (manifest-pattern-output pattern)
  685. ("out" #f)
  686. (output output)))))
  687. ((profile-collision-error? c)
  688. (let ((entry (profile-collision-error-entry c))
  689. (conflict (profile-collision-error-conflict c)))
  690. (define (report-parent-entries entry)
  691. (let ((parent (force (manifest-entry-parent entry))))
  692. (when (manifest-entry? parent)
  693. (report-error (G_ " ... propagated from ~a@~a~%")
  694. (manifest-entry-name parent)
  695. (manifest-entry-version parent))
  696. (report-parent-entries parent))))
  697. (define (manifest-entry-output* entry)
  698. (match (manifest-entry-output entry)
  699. ("out" "")
  700. (output (string-append ":" output))))
  701. (report-error (G_ "profile contains conflicting entries for ~a~a~%")
  702. (manifest-entry-name entry)
  703. (manifest-entry-output* entry))
  704. (report-error (G_ " first entry: ~a@~a~a ~a~%")
  705. (manifest-entry-name entry)
  706. (manifest-entry-version entry)
  707. (manifest-entry-output* entry)
  708. (manifest-entry-item entry))
  709. (report-parent-entries entry)
  710. (report-error (G_ " second entry: ~a@~a~a ~a~%")
  711. (manifest-entry-name conflict)
  712. (manifest-entry-version conflict)
  713. (manifest-entry-output* conflict)
  714. (manifest-entry-item conflict))
  715. (report-parent-entries conflict)
  716. (display-collision-resolution-hint c)
  717. (exit 1)))
  718. ((nar-error? c)
  719. (let ((file (nar-error-file c))
  720. (port (nar-error-port c)))
  721. (if file
  722. (leave (G_ "corrupt input while restoring '~a' from ~s~%")
  723. file (or (port-filename* port) port))
  724. (leave (G_ "corrupt input while restoring archive from ~s~%")
  725. (or (port-filename* port) port)))))
  726. ((store-connection-error? c)
  727. (leave (G_ "failed to connect to `~a': ~a~%")
  728. (store-connection-error-file c)
  729. (strerror (store-connection-error-code c))))
  730. ((store-protocol-error? c)
  731. ;; FIXME: Server-provided error messages aren't i18n'd.
  732. (leave (G_ "~a~%")
  733. (store-protocol-error-message c)))
  734. ((derivation-missing-output-error? c)
  735. (leave (G_ "reference to invalid output '~a' of derivation '~a'~%")
  736. (derivation-missing-output c)
  737. (derivation-file-name (derivation-error-derivation c))))
  738. ((file-search-error? c)
  739. (leave (G_ "file '~a' could not be found in these \
  740. directories:~{ ~a~}~%")
  741. (file-search-error-file-name c)
  742. (file-search-error-search-path c)))
  743. ((invoke-error? c)
  744. (leave (G_ "program exited\
  745. ~@[ with non-zero exit status ~a~]\
  746. ~@[ terminated by signal ~a~]\
  747. ~@[ stopped by signal ~a~]: ~s~%")
  748. (invoke-error-exit-status c)
  749. (invoke-error-term-signal c)
  750. (invoke-error-stop-signal c)
  751. (cons (invoke-error-program c)
  752. (invoke-error-arguments c))))
  753. ((formatted-message? c)
  754. (apply report-error
  755. (and (error-location? c) (error-location c))
  756. (gettext (formatted-message-string c) %gettext-domain)
  757. (formatted-message-arguments c))
  758. (when (fix-hint? c)
  759. (display-hint (condition-fix-hint c)))
  760. (exit 1))
  761. ;; On Guile 3.0.0, exceptions such as 'unbound-variable' are
  762. ;; compound and include a '&message'. However, that message only
  763. ;; contains the format string. Thus, special-case it here to
  764. ;; avoid displaying a bare format string.
  765. ;;
  766. ;; Furthermore, use of 'guard*' ensures that the stack has not
  767. ;; been unwound when we re-raise, since that would otherwise show
  768. ;; useless backtraces.
  769. (((exception-predicate &exception-with-kind-and-args) c)
  770. (if (eq? 'system-error (exception-kind c)) ;EPIPE & co.
  771. (match (exception-args c)
  772. ((proc format-string format-args . _)
  773. (leave (G_ "~a: ~a~%") proc
  774. (apply format #f format-string format-args))))
  775. (raise c)))
  776. ((message-condition? c)
  777. ;; Normally '&message' error conditions have an i18n'd message.
  778. (report-error (and (error-location? c) (error-location c))
  779. (G_ "~a~%")
  780. (gettext (condition-message c) %gettext-domain))
  781. (when (fix-hint? c)
  782. (display-hint (condition-fix-hint c)))
  783. (exit 1)))
  784. (thunk)))
  785. (define-syntax-rule (leave-on-EPIPE exp ...)
  786. "Run EXP... in a context where EPIPE errors are caught and lead to 'exit'
  787. with successful exit code. This is useful when writing to the standard output
  788. may lead to EPIPE, because the standard output is piped through 'head' or
  789. similar."
  790. (catch 'system-error
  791. (lambda ()
  792. exp ...)
  793. (lambda args
  794. ;; We really have to exit this brutally, otherwise Guile eventually
  795. ;; attempts to flush all the ports, leading to an uncaught EPIPE down
  796. ;; the path.
  797. (if (= EPIPE (system-error-errno args))
  798. (primitive-_exit 0)
  799. (apply throw args)))))
  800. (define %guix-user-module
  801. ;; Module in which user expressions are evaluated.
  802. ;; Compute lazily to avoid circularity with (guix gexp).
  803. (delay
  804. (let ((module (make-module)))
  805. (beautify-user-module! module)
  806. ;; Use (guix gexp) so that one can use #~ & co.
  807. (module-use! module (resolve-interface '(guix gexp)))
  808. module)))
  809. (define (read/eval str)
  810. "Read and evaluate STR, raising an error if something goes wrong."
  811. (let ((exp (catch #t
  812. (lambda ()
  813. (call-with-input-string str read))
  814. (lambda args
  815. (leave (G_ "failed to read expression ~s: ~s~%")
  816. str args)))))
  817. (catch #t
  818. (lambda ()
  819. (eval exp (force %guix-user-module)))
  820. (lambda args
  821. (report-error (G_ "failed to evaluate expression '~a':~%") exp)
  822. (match args
  823. (('syntax-error proc message properties form . rest)
  824. (report-error (G_ "syntax error: ~a~%") message))
  825. (((or 'srfi-34 '%exception) obj)
  826. (cond ((message-condition? obj)
  827. (report-error (G_ "~a~%")
  828. (gettext (condition-message obj)
  829. %gettext-domain)))
  830. ((formatted-message? obj)
  831. (apply report-error #f
  832. (gettext (formatted-message-string obj)
  833. %gettext-domain)
  834. (formatted-message-arguments obj)))
  835. (else
  836. (report-error (G_ "exception thrown: ~s~%") obj))))
  837. ((error args ...)
  838. (apply display-error #f (current-error-port) args))
  839. (what? #f))
  840. (exit 1)))))
  841. (define (read/eval-package-expression str)
  842. "Read and evaluate STR and return the package it refers to, or exit an
  843. error."
  844. (match (read/eval str)
  845. ((? package? p) p)
  846. (x
  847. (leave (G_ "expression ~s does not evaluate to a package~%")
  848. str))))
  849. (define (show-derivation-outputs derivation)
  850. "Show the output file names of DERIVATION, which can be a derivation or a
  851. derivation input."
  852. (define (show-outputs derivation outputs)
  853. (format #t "~{~a~%~}"
  854. (map (cut derivation->output-path derivation <>)
  855. outputs)))
  856. (match derivation
  857. ((? derivation?)
  858. (show-outputs derivation (derivation-output-names derivation)))
  859. ((? derivation-input? input)
  860. (show-outputs (derivation-input-derivation input)
  861. (derivation-input-sub-derivations input)))))
  862. (define* (check-available-space need
  863. #:optional (directory (%store-prefix)))
  864. "Make sure at least NEED bytes are available in DIRECTORY. Otherwise emit a
  865. warning."
  866. (let ((free (catch 'system-error
  867. (lambda ()
  868. (free-disk-space directory))
  869. (const #f))))
  870. (when (and free (>= need free))
  871. (warning (G_ "at least ~,1h MB needed but only ~,1h MB available in ~a~%")
  872. (/ need 1e6) (/ free 1e6) directory))))
  873. (define (graft-derivation? drv)
  874. "Return true if DRV is definitely a graft derivation, false otherwise."
  875. (match (assq-ref (derivation-properties drv) 'type)
  876. ('graft #t)
  877. (_ #f)))
  878. (define (profile-hook-derivation? drv)
  879. "Return true if DRV is definitely a profile hook derivation, false otherwise."
  880. (match (assq-ref (derivation-properties drv) 'type)
  881. ('profile-hook #t)
  882. (_ #f)))
  883. (define (colorize-store-file-name file)
  884. "Colorize FILE, a store file name, such that the hash part is less prominent
  885. than the rest."
  886. (let ((len (string-length file))
  887. (prefix (+ (string-length (%store-prefix)) 32 2)))
  888. (if (< len prefix)
  889. file
  890. (string-append (colorize-string (string-take file prefix)
  891. (color DARK))
  892. (string-drop file prefix)))))
  893. (define %default-verbosity
  894. ;; Default verbosity level for 'show-what-to-build'.
  895. 2)
  896. (define* (show-what-to-build store drv
  897. #:key dry-run? (use-substitutes? #t)
  898. (verbosity %default-verbosity)
  899. (mode (build-mode normal)))
  900. "Show what will or would (depending on DRY-RUN?) be built in realizing the
  901. derivations listed in DRV using MODE, a 'build-mode' value. The elements of
  902. DRV can be either derivations or derivation inputs.
  903. Return two values: a Boolean indicating whether there's something to build,
  904. and a Boolean indicating whether there's something to download.
  905. When USE-SUBSTITUTES?, check and report what is prerequisites are available
  906. for download. VERBOSITY is an integer indicating the level of details to be
  907. shown: level 2 and higher provide all the details, level 1 shows a high-level
  908. summary, and level 0 shows nothing."
  909. (define inputs
  910. (map (match-lambda
  911. ((? derivation? drv) (derivation-input drv))
  912. ((? derivation-input? input) input))
  913. drv))
  914. (define substitutable-info
  915. ;; Call 'substitution-oracle' upfront so we don't end up launching the
  916. ;; substituter many times. This makes a big difference, especially when
  917. ;; DRV is a long list as is the case with 'guix environment'.
  918. (if use-substitutes?
  919. (substitution-oracle store inputs #:mode mode)
  920. (const #f)))
  921. (define colorized-store-item
  922. (if (color-output? (current-error-port))
  923. colorize-store-file-name
  924. identity))
  925. (let*-values (((build/full download)
  926. (derivation-build-plan store inputs
  927. #:mode mode
  928. #:substitutable-info
  929. substitutable-info))
  930. ((graft hook build)
  931. (match (fold (lambda (drv acc)
  932. (let ((file (derivation-file-name drv)))
  933. (match acc
  934. ((#:graft graft #:hook hook #:build build)
  935. (cond
  936. ((graft-derivation? drv)
  937. `(#:graft ,(cons file graft)
  938. #:hook ,hook
  939. #:build ,build))
  940. ((profile-hook-derivation? drv)
  941. `(#:graft ,graft
  942. #:hook ,(cons file hook)
  943. #:build ,build))
  944. (else
  945. `(#:graft ,graft
  946. #:hook ,hook
  947. #:build ,(cons file build))))))))
  948. '(#:graft () #:hook () #:build ())
  949. build/full)
  950. ((#:graft graft #:hook hook #:build build)
  951. (values graft hook build)))))
  952. (define installed-size
  953. (reduce + 0 (map substitutable-nar-size download)))
  954. (define download-size
  955. (/ (reduce + 0 (map substitutable-download-size download))
  956. 1e6))
  957. (define display-download-size?
  958. ;; Sometimes narinfos lack information about the download size. Only
  959. ;; display when we have information for all of DOWNLOAD.
  960. (not (any (compose zero? substitutable-download-size) download)))
  961. ;; Combinatorial explosion ahead along two axes: DRY-RUN? and VERBOSITY.
  962. ;; Unfortunately, this is hardly avoidable for proper i18n.
  963. (if dry-run?
  964. (begin
  965. (unless (or (zero? verbosity) (null? build))
  966. (format (current-error-port)
  967. (highlight/warn
  968. (N_ "The following derivation would be built:~%"
  969. "The following derivations would be built:~%"
  970. (length build))))
  971. (format (current-error-port) "~{ ~a~%~}"
  972. (map colorized-store-item build)))
  973. (cond ((>= verbosity 2)
  974. (if display-download-size?
  975. (begin
  976. (format (current-error-port)
  977. (highlight
  978. ;; TRANSLATORS: "MB" is for "megabyte"; it
  979. ;; should be translated to the corresponding
  980. ;; abbreviation.
  981. (G_ "~:[~,1h MB would be downloaded:~%~;~]"))
  982. (null? download)
  983. download-size)
  984. (format (current-error-port) "~{ ~a~%~}"
  985. (map (compose colorized-store-item substitutable-path)
  986. download)))
  987. (begin
  988. (format (current-error-port)
  989. (highlight
  990. (N_ "~:[The following file would be downloaded:~%~;~]"
  991. "~:[The following files would be downloaded:~%~;~]"
  992. (length download)))
  993. (null? download))
  994. (format (current-error-port) "~{ ~a~%~}"
  995. (map (compose colorized-store-item substitutable-path)
  996. download))))
  997. (format (current-error-port)
  998. (N_ "~:[The following graft would be made:~%~{ ~a~%~}~;~]"
  999. "~:[The following grafts would be made:~%~{ ~a~%~}~;~]"
  1000. (length graft))
  1001. (null? graft) (map colorized-store-item graft))
  1002. (format (current-error-port)
  1003. (N_ "~:[The following profile hook would be built:~%~{ ~a~%~}~;~]"
  1004. "~:[The following profile hooks would be built:~%~{ ~a~%~}~;~]"
  1005. (length hook))
  1006. (null? hook) (map colorized-store-item hook)))
  1007. ((= verbosity 1)
  1008. ;; Display the bare minimum; don't mention grafts and hooks.
  1009. (unless (null? build)
  1010. (newline (current-error-port)))
  1011. (if display-download-size?
  1012. (format (current-error-port)
  1013. ;; TRANSLATORS: "MB" is for "megabyte"; it should be
  1014. ;; translated to the corresponding abbreviation.
  1015. (highlight (G_ "~:[~,1h MB would be downloaded~%~;~]"))
  1016. (null? download) download-size)
  1017. (format (current-error-port)
  1018. (highlight
  1019. (N_ "~:[~h item would be downloaded~%~;~]"
  1020. "~:[~h items would be downloaded~%~;~]"
  1021. (length download)))
  1022. (null? download) (length download))))))
  1023. (begin
  1024. (unless (or (zero? verbosity) (null? build))
  1025. (format (current-error-port)
  1026. (highlight/warn
  1027. (N_ "The following derivation will be built:~%"
  1028. "The following derivations will be built:~%"
  1029. (length build))))
  1030. (format (current-error-port) "~{ ~a~%~}"
  1031. (map colorized-store-item build)))
  1032. (cond ((>= verbosity 2)
  1033. (if display-download-size?
  1034. (begin
  1035. (format (current-error-port)
  1036. (highlight
  1037. ;; TRANSLATORS: "MB" is for "megabyte"; it
  1038. ;; should be translated to the corresponding
  1039. ;; abbreviation.
  1040. (G_ "~:[~,1h MB will be downloaded:~%~;~]"))
  1041. (null? download)
  1042. download-size)
  1043. (format (current-error-port) "~{ ~a~%~}"
  1044. (map (compose colorized-store-item substitutable-path)
  1045. download)))
  1046. (begin
  1047. (format (current-error-port)
  1048. (highlight
  1049. (N_ "~:[The following file will be downloaded:~%~;~]"
  1050. "~:[The following files will be downloaded:~%~;~]"
  1051. (length download)))
  1052. (null? download))
  1053. (format (current-error-port) "~{ ~a~%~}"
  1054. (map (compose colorized-store-item substitutable-path)
  1055. download))))
  1056. (format (current-error-port)
  1057. (N_ "~:[The following graft will be made:~%~{ ~a~%~}~;~]"
  1058. "~:[The following grafts will be made:~%~{ ~a~%~}~;~]"
  1059. (length graft))
  1060. (null? graft) (map colorized-store-item graft))
  1061. (format (current-error-port)
  1062. (N_ "~:[The following profile hook will be built:~%~{ ~a~%~}~;~]"
  1063. "~:[The following profile hooks will be built:~%~{ ~a~%~}~;~]"
  1064. (length hook))
  1065. (null? hook) (map colorized-store-item hook)))
  1066. ((= verbosity 1)
  1067. ;; Display the bare minimum; don't mention grafts and hooks.
  1068. (unless (null? build)
  1069. (newline (current-error-port)))
  1070. (if display-download-size?
  1071. (format (current-error-port)
  1072. ;; TRANSLATORS: "MB" is for "megabyte"; it should be
  1073. ;; translated to the corresponding abbreviation.
  1074. (highlight (G_ "~:[~,1h MB will be downloaded~%~;~]"))
  1075. (null? download) download-size)
  1076. (format (current-error-port)
  1077. (highlight
  1078. (N_ "~:[~h item will be downloaded~%~;~]"
  1079. "~:[~h items will be downloaded~%~;~]"
  1080. (length download)))
  1081. (null? download) (length download)))))))
  1082. (check-available-space installed-size)
  1083. (values (pair? build/full) (pair? download))))
  1084. (define show-what-to-build*
  1085. (store-lift show-what-to-build))
  1086. (define* (build-notifier #:key (dry-run? #f) (use-substitutes? #t)
  1087. (verbosity %default-verbosity))
  1088. "Return a procedure suitable for 'with-build-handler' that, when
  1089. 'build-things' is called, invokes 'show-what-to-build' to display the build
  1090. plan. When DRY-RUN? is true, the 'with-build-handler' form returns without
  1091. any build happening."
  1092. (define not-comma
  1093. (char-set-complement (char-set #\,)))
  1094. (define (read-derivation-from-file* item)
  1095. (catch 'system-error
  1096. (lambda ()
  1097. (read-derivation-from-file item))
  1098. (const #f)))
  1099. (lambda (continue store things mode)
  1100. (define inputs
  1101. ;; List of derivation inputs to build. Filter out non-existent '.drv'
  1102. ;; files because the daemon transparently tries to substitute them.
  1103. (filter-map (match-lambda
  1104. (((? derivation-path? drv) . output)
  1105. (let ((drv (read-derivation-from-file* drv))
  1106. (outputs (string-tokenize output not-comma)))
  1107. (and drv (derivation-input drv outputs))))
  1108. ((? derivation-path? drv)
  1109. (and=> (read-derivation-from-file* drv)
  1110. derivation-input))
  1111. (_
  1112. #f))
  1113. things))
  1114. (let-values (((build? download?)
  1115. (show-what-to-build store inputs
  1116. #:dry-run? dry-run?
  1117. #:use-substitutes? use-substitutes?
  1118. #:verbosity verbosity
  1119. #:mode mode)))
  1120. (unless (and (or build? download?)
  1121. dry-run?)
  1122. (continue #t)))))
  1123. (define (right-arrow port)
  1124. "Return either a string containing the 'RIGHT ARROW' character, or an ASCII
  1125. replacement if PORT is not Unicode-capable."
  1126. (let ((encoding (port-encoding port))
  1127. (arrow "→"))
  1128. (catch 'encoding-error
  1129. (lambda ()
  1130. (call-with-output-string
  1131. (lambda (port)
  1132. (set-port-encoding! port encoding)
  1133. (set-port-conversion-strategy! port 'error)
  1134. (display arrow port))))
  1135. (lambda (key . args)
  1136. "->"))))
  1137. (define* (tabulate rows #:key (initial-indent 0) (max-width 25)
  1138. (inter-column " "))
  1139. "Return a list of strings where each string is a tabulated representation of
  1140. an element of ROWS. All the ROWS must be lists of the same number of cells.
  1141. Add INITIAL-INDENT white space at the beginning of each row. Ensure that
  1142. columns are at most MAX-WIDTH characters wide. Use INTER-COLUMN as a
  1143. separator between subsequent columns."
  1144. (define column-widths
  1145. ;; List of column widths.
  1146. (let loop ((rows rows)
  1147. (widths '()))
  1148. (match rows
  1149. (((? null?) ...)
  1150. (reverse widths))
  1151. (((column rest ...) ...)
  1152. (loop rest
  1153. (cons (min (apply max (map string-length column))
  1154. max-width)
  1155. widths))))))
  1156. (define indent
  1157. (make-string initial-indent #\space))
  1158. (define (string-pad-right* str len)
  1159. (if (> (string-length str) len)
  1160. str
  1161. (string-pad-right str len)))
  1162. (map (lambda (row)
  1163. (string-trim-right
  1164. (string-append indent
  1165. (string-join
  1166. (map string-pad-right* row column-widths)
  1167. inter-column))))
  1168. rows))
  1169. (define* (show-manifest-transaction store manifest transaction
  1170. #:key dry-run?)
  1171. "Display what will/would be installed/removed from MANIFEST by TRANSACTION."
  1172. (define* (package-strings names versions outputs #:key old-versions)
  1173. (tabulate (stable-sort
  1174. (zip (map (lambda (name output)
  1175. (if (string=? output "out")
  1176. name
  1177. (string-append name ":" output)))
  1178. names outputs)
  1179. (if old-versions
  1180. (map (lambda (old new)
  1181. (if (string=? old new)
  1182. (G_ "(dependencies or package changed)")
  1183. (string-append old " "" " new)))
  1184. old-versions versions)
  1185. versions))
  1186. (lambda (x y)
  1187. (string<? (first x) (first y))))
  1188. #:initial-indent 3))
  1189. (define → ;an arrow that can be represented on stderr
  1190. (right-arrow (current-error-port)))
  1191. (let-values (((remove install upgrade downgrade)
  1192. (manifest-transaction-effects manifest transaction)))
  1193. (match remove
  1194. ((($ <manifest-entry> name version output item) ..1)
  1195. (let ((len (length name))
  1196. (remove (package-strings name version output)))
  1197. (if dry-run?
  1198. (format (current-error-port)
  1199. (N_ "The following package would be removed:~%~{~a~%~}~%"
  1200. "The following packages would be removed:~%~{~a~%~}~%"
  1201. len)
  1202. remove)
  1203. (format (current-error-port)
  1204. (N_ "The following package will be removed:~%~{~a~%~}~%"
  1205. "The following packages will be removed:~%~{~a~%~}~%"
  1206. len)
  1207. remove))))
  1208. (x #f))
  1209. (match downgrade
  1210. (((($ <manifest-entry> name old-version)
  1211. . ($ <manifest-entry> _ new-version output item)) ..1)
  1212. (let ((len (length name))
  1213. (downgrade (package-strings name new-version output
  1214. #:old-versions old-version)))
  1215. (if dry-run?
  1216. (format (current-error-port)
  1217. (N_ "The following package would be downgraded:~%~{~a~%~}~%"
  1218. "The following packages would be downgraded:~%~{~a~%~}~%"
  1219. len)
  1220. downgrade)
  1221. (format (current-error-port)
  1222. (N_ "The following package will be downgraded:~%~{~a~%~}~%"
  1223. "The following packages will be downgraded:~%~{~a~%~}~%"
  1224. len)
  1225. downgrade))))
  1226. (x #f))
  1227. (match upgrade
  1228. (((($ <manifest-entry> name old-version)
  1229. . ($ <manifest-entry> _ new-version output item)) ..1)
  1230. (let ((len (length name))
  1231. (upgrade (package-strings name new-version output
  1232. #:old-versions old-version)))
  1233. (if dry-run?
  1234. (format (current-error-port)
  1235. (N_ "The following package would be upgraded:~%~{~a~%~}~%"
  1236. "The following packages would be upgraded:~%~{~a~%~}~%"
  1237. len)
  1238. upgrade)
  1239. (format (current-error-port)
  1240. (N_ "The following package will be upgraded:~%~{~a~%~}~%"
  1241. "The following packages will be upgraded:~%~{~a~%~}~%"
  1242. len)
  1243. upgrade))))
  1244. (x #f))
  1245. (match install
  1246. ((($ <manifest-entry> name version output item _) ..1)
  1247. (let ((len (length name))
  1248. (install (package-strings name version output)))
  1249. (if dry-run?
  1250. (format (current-error-port)
  1251. (N_ "The following package would be installed:~%~{~a~%~}~%"
  1252. "The following packages would be installed:~%~{~a~%~}~%"
  1253. len)
  1254. install)
  1255. (format (current-error-port)
  1256. (N_ "The following package will be installed:~%~{~a~%~}~%"
  1257. "The following packages will be installed:~%~{~a~%~}~%"
  1258. len)
  1259. install))))
  1260. (x #f))))
  1261. (define-syntax with-error-handling
  1262. (syntax-rules ()
  1263. "Run BODY within a user-friendly error condition handler."
  1264. ((_ body ...)
  1265. (call-with-error-handling
  1266. (lambda ()
  1267. body ...)))))
  1268. (define* (indented-string str indent
  1269. #:key (initial-indent? #t))
  1270. "Return STR with each newline preceded by INDENT spaces. When
  1271. INITIAL-INDENT? is true, the first line is also indented."
  1272. (define indent-string
  1273. (make-list indent #\space))
  1274. (list->string
  1275. (string-fold-right (lambda (chr result)
  1276. (if (eqv? chr #\newline)
  1277. (cons chr (append indent-string result))
  1278. (cons chr result)))
  1279. '()
  1280. (if initial-indent?
  1281. (string-append (list->string indent-string) str)
  1282. str))))
  1283. (define* (fill-paragraph str width #:optional (column 0))
  1284. "Fill STR such that each line contains at most WIDTH characters, assuming
  1285. that the first character is at COLUMN.
  1286. When STR contains a single line break surrounded by other characters, it is
  1287. converted to a space; sequences of more than one line break are preserved."
  1288. (define (maybe-break chr result)
  1289. (match result
  1290. ((column newlines chars)
  1291. (case chr
  1292. ((#\newline)
  1293. `(,column ,(+ 1 newlines) ,chars))
  1294. (else
  1295. (let* ((spaces (if (and (pair? chars) (eqv? (car chars) #\.)) 2 1))
  1296. (chars (case newlines
  1297. ((0) chars)
  1298. ((1)
  1299. (append (make-list spaces #\space) chars))
  1300. (else
  1301. (append (make-list newlines #\newline) chars))))
  1302. (column (case newlines
  1303. ((0) column)
  1304. ((1) (+ spaces column))
  1305. (else 0))))
  1306. (let ((chars (cons chr chars))
  1307. (column (+ 1 column)))
  1308. (if (> column width)
  1309. (let*-values (((before after)
  1310. (break (cut eqv? #\space <>) chars))
  1311. ((len)
  1312. (length before)))
  1313. (if (<= len width)
  1314. `(,len
  1315. 0
  1316. ,(if (null? after)
  1317. before
  1318. (append before
  1319. (cons #\newline
  1320. (drop-while (cut eqv? #\space <>)
  1321. after)))))
  1322. `(,column 0 ,chars))) ; unbreakable
  1323. `(,column 0 ,chars)))))))))
  1324. (match (string-fold maybe-break
  1325. `(,column 0 ())
  1326. str)
  1327. ((column newlines chars)
  1328. (list->string (reverse chars)))))
  1329. ;;;
  1330. ;;; Packages.
  1331. ;;;
  1332. (define %text-width
  1333. ;; '*line-width*' was introduced in Guile 2.2.7/3.0.1. On older versions of
  1334. ;; Guile, monkey-patch 'wrap*' below.
  1335. (if (defined? '*line-width*)
  1336. (let ((parameter (fluid->parameter *line-width*)))
  1337. (parameter (terminal-columns))
  1338. parameter)
  1339. (make-parameter (terminal-columns))))
  1340. (unless (defined? '*line-width*) ;Guile < 2.2.7
  1341. (set! (@@ (texinfo plain-text) wrap*)
  1342. ;; XXX: Monkey patch this private procedure to let 'package->recutils'
  1343. ;; parameterize the fill of description field correctly.
  1344. (lambda strings
  1345. (let ((indent (fluid-ref (@@ (texinfo plain-text) *indent*))))
  1346. (fill-string (string-concatenate strings)
  1347. #:line-width (%text-width) #:initial-indent indent
  1348. #:subsequent-indent indent)))))
  1349. (define (texi->plain-text str)
  1350. "Return a plain-text representation of texinfo fragment STR."
  1351. ;; 'texi-fragment->stexi' uses a string port so make sure it's a
  1352. ;; Unicode-capable one (see <http://bugs.gnu.org/11197>.)
  1353. (with-fluids ((%default-port-encoding "UTF-8"))
  1354. (stexi->plain-text (texi-fragment->stexi str))))
  1355. (define (texi->plain-text* package str)
  1356. "Same as 'texi->plain-text', but gracefully handle Texinfo errors."
  1357. (catch 'parser-error
  1358. (lambda ()
  1359. (texi->plain-text str))
  1360. (lambda args
  1361. (warning (package-location package)
  1362. (G_ "~a: invalid Texinfo markup~%")
  1363. (package-full-name package))
  1364. str)))
  1365. (define (package-field-string package field-accessor)
  1366. "Return a plain-text representation of PACKAGE field."
  1367. (and=> (field-accessor package)
  1368. (lambda (str)
  1369. (texi->plain-text* package (P_ str)))))
  1370. (define (package-description-string package)
  1371. "Return a plain-text representation of PACKAGE description field."
  1372. (package-field-string package package-description))
  1373. (define (package-synopsis-string package)
  1374. "Return a plain-text representation of PACKAGE synopsis field."
  1375. (package-field-string package package-synopsis))
  1376. (define (string->recutils str)
  1377. "Return a version of STR where newlines have been replaced by newlines
  1378. followed by \"+ \", which makes for a valid multi-line field value in the
  1379. `recutils' syntax."
  1380. (list->string
  1381. (string-fold-right (lambda (chr result)
  1382. (if (eqv? chr #\newline)
  1383. (cons* chr #\+ #\space result)
  1384. (cons chr result)))
  1385. '()
  1386. str)))
  1387. (define* (package->recutils p port #:optional (width (%text-width))
  1388. #:key
  1389. (hyperlinks? (supports-hyperlinks? port))
  1390. (extra-fields '())
  1391. (highlighting identity))
  1392. "Write to PORT a `recutils' record of package P, arranging to fit within
  1393. WIDTH columns. EXTRA-FIELDS is a list of symbol/value pairs to emit. When
  1394. HYPERLINKS? is true, emit hyperlink escape sequences when appropriate. Pass
  1395. the synopsis and description through HIGHLIGHTING, a one-argument procedure
  1396. that may return a colorized version of its argument."
  1397. (define port*
  1398. (or (pager-wrapped-port port) port))
  1399. (define width*
  1400. ;; The available number of columns once we've taken into account space for
  1401. ;; the initial "+ " prefix.
  1402. (if (> width 2) (- width 2) width))
  1403. (define (split-lines str indent)
  1404. (string->recutils
  1405. (fill-paragraph str width* indent)))
  1406. (define (dependencies->recutils packages)
  1407. (let ((list (string-join (delete-duplicates
  1408. (map package-full-name
  1409. (sort packages package<?))) " ")))
  1410. (split-lines list (string-length "dependencies: "))))
  1411. (define %default-output-synopses
  1412. `(("bin" . ,(G_ "executable programs and scripts"))
  1413. ("debug" . ,(G_ "debug information"))
  1414. ("doc" . ,(G_ "documentation"))
  1415. ("lib" . ,(G_ "shared libraries"))
  1416. ("static" . ,(G_ "static libraries"))
  1417. ("out" . ,(G_ "everything else"))))
  1418. (define* (output->recutils package output #:optional
  1419. (default-synopses %default-output-synopses))
  1420. (string-append
  1421. "+ " output ": "
  1422. (or
  1423. (any
  1424. (match-lambda
  1425. (('output-synopsis key synopsis)
  1426. (and (string=? key output) (P_ synopsis)))
  1427. (_ #f))
  1428. (package-properties package))
  1429. (assoc-ref default-synopses output)
  1430. (G_ "[description missing]"))))
  1431. (define (package-outputs/out-last package)
  1432. ((compose append partition)
  1433. (negate (cut string=? "out" <>))
  1434. (package-outputs package)))
  1435. (define (package<? p1 p2)
  1436. (string<? (package-full-name p1) (package-full-name p2)))
  1437. (define highlighting*
  1438. (if (color-output? port*)
  1439. highlighting
  1440. identity))
  1441. ;; Note: Don't i18n field names so that people can post-process it.
  1442. (format port "name: ~a~%" (highlight (package-name p) port*))
  1443. (format port "version: ~a~%" (highlight (package-version p) port*))
  1444. (match (package-outputs/out-last p)
  1445. (("out") ; one output has everything
  1446. (format port "outputs:~%~a~%"
  1447. (output->recutils p "out"
  1448. (alist-cons "out" (G_ "everything")
  1449. %default-output-synopses))))
  1450. (outputs ; multiple outputs
  1451. (format port "outputs:~%~{~a~%~}"
  1452. (map (cut output->recutils p <>) (package-outputs/out-last p)))))
  1453. ;; {g23
  1454. (match (all-spec-parameters-with-types
  1455. (package-parameter-spec p))
  1456. (() #t)
  1457. (lst (format port "parameters:~{ ~a~}~%"
  1458. lst)))
  1459. ;; }
  1460. (format port "systems: ~a~%"
  1461. (split-lines (string-join (package-transitive-supported-systems p))
  1462. (string-length "systems: ")))
  1463. (format port "dependencies: ~a~%"
  1464. (match (package-direct-inputs p)
  1465. (((labels inputs . _) ...)
  1466. (dependencies->recutils (filter package? inputs)))))
  1467. (format port "location: ~a~%"
  1468. (or (and=> (package-location p)
  1469. (if hyperlinks? location->hyperlink location->string))
  1470. (G_ "unknown")))
  1471. ;; Note: Starting from version 1.6 or recutils, hyphens are not allowed in
  1472. ;; field identifiers.
  1473. (format port "homepage: ~a~%" (package-home-page p))
  1474. (format port "license: ~a~%"
  1475. (match (package-license p)
  1476. (((? license? licenses) ...)
  1477. (string-join (map license-name licenses)
  1478. ", "))
  1479. ((? license? license)
  1480. (let ((text (license-name license))
  1481. (uri (license-uri license)))
  1482. (if (and hyperlinks? uri (string-prefix? "http" uri))
  1483. (hyperlink uri text)
  1484. text)))
  1485. (x
  1486. (G_ "unknown"))))
  1487. (format port "synopsis: ~a~%"
  1488. (highlighting*
  1489. (string-map (match-lambda
  1490. (#\newline #\space)
  1491. (chr chr))
  1492. (or (package-synopsis-string p) ""))))
  1493. (format port "~a~%"
  1494. (highlighting*
  1495. (string->recutils
  1496. (string-trim-right
  1497. (parameterize ((%text-width width*))
  1498. ;; Call 'texi->plain-text' on the concatenated string to account
  1499. ;; for the width of "description:" in paragraph filling.
  1500. (texi->plain-text*
  1501. p
  1502. (string-append "description: "
  1503. (or (and=> (package-description p) P_)
  1504. ""))))
  1505. #\newline))))
  1506. (for-each (match-lambda
  1507. ((field . value)
  1508. (let ((field (symbol->string field)))
  1509. (format port "~a: ~a~%"
  1510. field
  1511. (fill-paragraph (object->string value) width*
  1512. (string-length field))))))
  1513. extra-fields)
  1514. (newline port))
  1515. ;;;
  1516. ;;; Searching.
  1517. ;;;
  1518. (define (relevance obj regexps metrics)
  1519. "Compute a \"relevance score\" for OBJ as a function of its number of
  1520. matches of REGEXPS and accordingly to METRICS. METRICS is list of
  1521. field/weight pairs, where FIELD is a procedure that returns a string or list
  1522. of strings describing OBJ, and WEIGHT is a positive integer denoting the
  1523. weight of this field in the final score.
  1524. A score of zero means that OBJ does not match any of REGEXPS. The higher the
  1525. score, the more relevant OBJ is to REGEXPS."
  1526. (define (score regexp str)
  1527. (fold-matches regexp str 0
  1528. (lambda (m score)
  1529. (+ score
  1530. (if (string=? (match:substring m) str)
  1531. 5 ;exact match
  1532. 1)))))
  1533. (define (regexp->score regexp)
  1534. (let ((score-regexp (lambda (str) (score regexp str))))
  1535. (fold (lambda (metric relevance)
  1536. (match metric
  1537. ((field . weight)
  1538. (match (field obj)
  1539. (#f relevance)
  1540. ((? string? str)
  1541. (+ relevance (* (score-regexp str) weight)))
  1542. ((lst ...)
  1543. (+ relevance (* weight (apply + (map score-regexp lst)))))))))
  1544. 0 metrics)))
  1545. (let loop ((regexps regexps)
  1546. (total-score 0))
  1547. (match regexps
  1548. ((head . tail)
  1549. (let ((score (regexp->score head)))
  1550. ;; Return zero if one of PATTERNS doesn't match.
  1551. (if (zero? score)
  1552. 0
  1553. (loop tail (+ total-score score)))))
  1554. (() total-score))))
  1555. (define %package-metrics
  1556. ;; Metrics used to compute the "relevance score" of a package against a set
  1557. ;; of regexps.
  1558. `((,package-name . 4)
  1559. (,package-upstream-name* . 2)
  1560. ;; Match against uncommon outputs.
  1561. (,(lambda (package)
  1562. (filter (lambda (output)
  1563. (not (member output
  1564. ;; Some common outputs shared by many packages.
  1565. '("out" "doc" "debug" "lib" "include" "bin"))))
  1566. (package-outputs package)))
  1567. . 1)
  1568. ;; Match regexps on the raw Texinfo since formatting it is quite expensive
  1569. ;; and doesn't have much of an effect on search results.
  1570. (,(lambda (package)
  1571. (and=> (package-synopsis package) P_)) . 3)
  1572. (,(lambda (package)
  1573. (and=> (package-description package) P_)) . 2)
  1574. (,(lambda (type)
  1575. (match (and=> (package-location type) location-file)
  1576. ((? string? file) (basename file ".scm"))
  1577. (#f "")))
  1578. . 1)))
  1579. (define (package-relevance package regexps)
  1580. "Return a score denoting the relevance of PACKAGE for REGEXPS. A score of
  1581. zero means that PACKAGE does not match any of REGEXPS."
  1582. (relevance package regexps %package-metrics))
  1583. (define pager-port-mapping
  1584. ;; If a pager is being used, via 'with-paginated-output-port', this maps the
  1585. ;; pager port (pipe) to the underlying output port.
  1586. (make-parameter #f))
  1587. (define* (pager-wrapped-port #:optional (port (current-output-port)))
  1588. "If PORT is a pipe to a pager created by 'with-paginated-output-port',
  1589. return the underlying port. Otherwise return #f."
  1590. (match (pager-port-mapping)
  1591. ((pager . wrapped)
  1592. (and (eq? pager port) wrapped))
  1593. (_
  1594. #f)))
  1595. (define (find-available-pager)
  1596. "Return the program name of an available pager or the empty string if none is
  1597. available."
  1598. (or (getenv "GUIX_PAGER")
  1599. (getenv "PAGER")
  1600. (which "less")
  1601. (which "more")
  1602. ""))
  1603. (define* (call-with-paginated-output-port proc
  1604. #:key (less-options "FrX"))
  1605. (let ((pager-command-line (find-available-pager)))
  1606. ;; Setting PAGER to the empty string conventionally disables paging.
  1607. (if (and (not (string-null? pager-command-line))
  1608. (isatty?* (current-output-port)))
  1609. ;; Set 'LESS' so that 'less' exits if everything fits on the screen
  1610. ;; (F), lets ANSI escapes through (r), does not send the termcap
  1611. ;; initialization string (X). Set it unconditionally because some
  1612. ;; distros set it to something that doesn't work here.
  1613. ;;
  1614. ;; For things that produce long lines, such as 'guix processes', use
  1615. ;; 'R' instead of 'r': this strips hyperlinks but allows 'less' to
  1616. ;; make a good estimate of the line length.
  1617. (let* ((pager (with-environment-variables `(("LESS" ,less-options))
  1618. (apply open-pipe* OPEN_WRITE
  1619. ;; Split into arguments. Treat runs of multiple
  1620. ;; whitespace characters as one. libpipeline-
  1621. ;; style "cmd one\ arg" escaping is unsupported.
  1622. (remove (lambda (s) (string-null? s))
  1623. (string-split pager-command-line
  1624. char-set:whitespace))))))
  1625. (dynamic-wind
  1626. (const #t)
  1627. (lambda ()
  1628. (parameterize ((pager-port-mapping
  1629. (cons pager (current-output-port))))
  1630. (proc pager)))
  1631. (lambda () (close-pipe pager))))
  1632. (proc (current-output-port)))))
  1633. (define-syntax with-paginated-output-port
  1634. (syntax-rules ()
  1635. "Evaluate EXP... with PORT bound to a port that talks to the pager if
  1636. standard output is a tty, or with PORT set to the current output port."
  1637. ((_ port exp ... #:less-options opts)
  1638. (call-with-paginated-output-port (lambda (port) exp ...)
  1639. #:less-options opts))
  1640. ((_ port exp ...)
  1641. (call-with-paginated-output-port (lambda (port) exp ...)))))
  1642. (define* (display-search-results matches port
  1643. #:key
  1644. (regexps '())
  1645. (command "guix search")
  1646. (print package->recutils))
  1647. "Display MATCHES, a list of object/score pairs, by calling PRINT on each of
  1648. them. If PORT is a terminal, print at most a full screen of results. REGEXPS
  1649. is a list of regexps to highlight in search results."
  1650. (define first-line
  1651. (port-line port))
  1652. (define max-rows
  1653. (and first-line (isatty? port)
  1654. (terminal-rows port)))
  1655. (define (line-count str)
  1656. (string-count str #\newline))
  1657. (define highlighting
  1658. (let ((match-color (color ON-RED BOLD)))
  1659. (colorize-full-matches (map (lambda (regexp)
  1660. (cons regexp match-color))
  1661. regexps))))
  1662. (with-paginated-output-port paginated
  1663. (let loop ((matches matches))
  1664. (match matches
  1665. (((package . score) rest ...)
  1666. (let* ((links? (supports-hyperlinks? port)))
  1667. (print package paginated
  1668. #:hyperlinks? links?
  1669. #:extra-fields `((relevance . ,score))
  1670. #:highlighting highlighting)
  1671. (loop rest)))
  1672. (()
  1673. #t)))))
  1674. (define (string->generations str)
  1675. "Return the list of generations matching a pattern in STR. This function
  1676. accepts the following patterns: \"1\", \"1,2,3\", \"1..9\", \"1..\", \"..9\"."
  1677. (define (maybe-integer)
  1678. (let ((x (string->number str)))
  1679. (and (integer? x)
  1680. x)))
  1681. (define (maybe-comma-separated-integers)
  1682. (let ((lst (delete-duplicates
  1683. (map string->number
  1684. (string-split str #\,)))))
  1685. (and (every integer? lst)
  1686. lst)))
  1687. (cond ((maybe-integer)
  1688. =>
  1689. list)
  1690. ((maybe-comma-separated-integers)
  1691. =>
  1692. identity)
  1693. ((string-match "^([0-9]+)\\.\\.([0-9]+)$" str)
  1694. =>
  1695. (lambda (match)
  1696. (let ((s (string->number (match:substring match 1)))
  1697. (e (string->number (match:substring match 2))))
  1698. (and (every integer? (list s e))
  1699. (<= s e)
  1700. (iota (1+ (- e s)) s)))))
  1701. ((string-match "^([0-9]+)\\.\\.$" str)
  1702. =>
  1703. (lambda (match)
  1704. (let ((s (string->number (match:substring match 1))))
  1705. (and (integer? s)
  1706. `(>= ,s)))))
  1707. ((string-match "^\\.\\.([0-9]+)$" str)
  1708. =>
  1709. (lambda (match)
  1710. (let ((e (string->number (match:substring match 1))))
  1711. (and (integer? e)
  1712. `(<= ,e)))))
  1713. (else #f)))
  1714. (define (string->duration str)
  1715. "Return the duration matching a pattern in STR. This function accepts the
  1716. following patterns: \"1d\", \"1w\", \"1m\"."
  1717. (define (hours->duration hours match)
  1718. (make-time time-duration 0
  1719. (* 3600 hours (string->number (match:substring match 1)))))
  1720. (cond ((string-match "^([0-9]+)s$" str)
  1721. =>
  1722. (lambda (match)
  1723. (make-time time-duration 0
  1724. (string->number (match:substring match 1)))))
  1725. ((string-match "^([0-9]+)h$" str)
  1726. =>
  1727. (lambda (match)
  1728. (hours->duration 1 match)))
  1729. ((string-match "^([0-9]+)d$" str)
  1730. =>
  1731. (lambda (match)
  1732. (hours->duration 24 match)))
  1733. ((string-match "^([0-9]+)w$" str)
  1734. =>
  1735. (lambda (match)
  1736. (hours->duration (* 24 7) match)))
  1737. ((string-match "^([0-9]+)m$" str)
  1738. =>
  1739. (lambda (match)
  1740. (hours->duration (* 24 30) match)))
  1741. (else #f)))
  1742. (define* (matching-generations str profile
  1743. #:key (duration-relation <=))
  1744. "Return the list of available generations matching a pattern in STR. See
  1745. 'string->generations' and 'string->duration' for the list of valid patterns.
  1746. When STR is a duration pattern, return all the generations whose ctime has
  1747. DURATION-RELATION with the current time."
  1748. (define (valid-generations lst)
  1749. (define (valid-generation? n)
  1750. (any (cut = n <>) (generation-numbers profile)))
  1751. (fold-right (lambda (x acc)
  1752. (if (valid-generation? x)
  1753. (cons x acc)
  1754. acc))
  1755. '()
  1756. lst))
  1757. (define (filter-generations generations)
  1758. (match generations
  1759. (() '())
  1760. (('>= n)
  1761. (drop-while (cut > n <>)
  1762. (generation-numbers profile)))
  1763. (('<= n)
  1764. (valid-generations (iota n 1)))
  1765. ((lst ..1)
  1766. (valid-generations lst))
  1767. (x #f)))
  1768. (define (filter-by-duration duration)
  1769. (define (time-at-midnight time)
  1770. ;; Return TIME at midnight by setting nanoseconds, seconds, minutes, and
  1771. ;; hours to zeros.
  1772. (let ((d (time-utc->date time)))
  1773. (date->time-utc
  1774. (make-date 0 0 0 0
  1775. (date-day d) (date-month d)
  1776. (date-year d) (date-zone-offset d)))))
  1777. (define generation-ctime-alist
  1778. (map (lambda (number)
  1779. (cons number
  1780. (time-second
  1781. (time-at-midnight
  1782. (generation-time profile number)))))
  1783. (generation-numbers profile)))
  1784. (match duration
  1785. (#f #f)
  1786. (res
  1787. (let ((s (time-second
  1788. (subtract-duration (time-at-midnight (current-time))
  1789. duration))))
  1790. (delete #f (map (lambda (x)
  1791. (and (duration-relation s (cdr x))
  1792. (first x)))
  1793. generation-ctime-alist))))))
  1794. (cond ((string->generations str)
  1795. =>
  1796. filter-generations)
  1797. ((string->duration str)
  1798. =>
  1799. filter-by-duration)
  1800. (else
  1801. (raise
  1802. (formatted-message (G_ "invalid syntax: ~a~%") str)))))
  1803. (define (display-generation profile number)
  1804. "Display a one-line summary of generation NUMBER of PROFILE."
  1805. (unless (zero? number)
  1806. (let* ((file (generation-file-name profile number))
  1807. (link (if (supports-hyperlinks?)
  1808. (cut file-hyperlink file <>)
  1809. identity))
  1810. (header (format #f (link (highlight (G_ "Generation ~a\t~a")
  1811. (or (pager-wrapped-port)
  1812. (current-output-port))))
  1813. number
  1814. (date->string
  1815. (time-utc->date
  1816. (generation-time profile number))
  1817. ;; TRANSLATORS: This is a format-string for date->string.
  1818. ;; Please choose a format that corresponds to the
  1819. ;; usual way of presenting dates in your locale.
  1820. ;; See https://www.gnu.org/software/guile/manual/html_node/SRFI_002d19-Date-to-string.html
  1821. ;; for details.
  1822. (G_ "~b ~d ~Y ~T"))))
  1823. (current (generation-number profile)))
  1824. (if (= number current)
  1825. ;; TRANSLATORS: The word "current" here is an adjective for
  1826. ;; "Generation", as in "current generation". Use the appropriate
  1827. ;; gender where applicable.
  1828. (format #t (G_ "~a\t(current)~%") header)
  1829. (format #t "~a~%" header)))))
  1830. (define (display-profile-content-diff profile gen1 gen2)
  1831. "Display the changed packages in PROFILE GEN2 compared to generation GEN1."
  1832. (define (equal-entry? first second)
  1833. (string= (manifest-entry-item first) (manifest-entry-item second)))
  1834. (define (make-row entry prefix)
  1835. (match entry
  1836. (($ <manifest-entry> name version output location _)
  1837. (list (format #f " ~a ~a" prefix name) version output location))))
  1838. (define (list-entries number)
  1839. (manifest-entries (profile-manifest (generation-file-name profile number))))
  1840. (define (display-diff profile old new)
  1841. (display-generation profile new)
  1842. (let ((added (lset-difference
  1843. equal-entry? (list-entries new) (list-entries old)))
  1844. (removed (lset-difference
  1845. equal-entry? (list-entries old) (list-entries new))))
  1846. (pretty-print-table (append (map (cut make-row <> "+") added)
  1847. (map (cut make-row <> "-") removed)))
  1848. (newline)))
  1849. (display-diff profile gen1 gen2))
  1850. (define (profile-lock-handler profile errno . _)
  1851. "Handle failure to acquire PROFILE's lock."
  1852. ;; NFS mounts can return ENOLCK. When that happens, there's not much that
  1853. ;; can be done, so warn the user and keep going.
  1854. (if (= errno ENOLCK)
  1855. (warning (G_ "cannot lock profile ~a: ~a~%")
  1856. profile (strerror errno))
  1857. (leave (G_ "profile ~a is locked by another process~%")
  1858. profile)))
  1859. (define profile-lock-file
  1860. (cut string-append <> ".lock"))
  1861. (define-syntax-rule (with-profile-lock profile exp ...)
  1862. "Grab PROFILE's lock and evaluate EXP... Call 'leave' if the lock is
  1863. already taken."
  1864. (with-file-lock/no-wait (profile-lock-file profile)
  1865. (cut profile-lock-handler profile <...>)
  1866. exp ...))
  1867. (define (display-profile-content profile number)
  1868. "Display the packages in PROFILE, generation NUMBER, in a human-readable
  1869. way."
  1870. (define entry->row
  1871. (match-lambda
  1872. (($ <manifest-entry> name version output location _)
  1873. (list (string-append " " name) version output location))))
  1874. (let* ((manifest (profile-manifest (generation-file-name profile number)))
  1875. (entries (manifest-entries manifest))
  1876. (rows (map entry->row entries)))
  1877. ;; Show most recently installed packages last.
  1878. (pretty-print-table (reverse rows))))
  1879. (define (display-generation-change previous current)
  1880. (format #t (G_ "switched from generation ~a to ~a~%") previous current))
  1881. (define (roll-back* store profile)
  1882. "Like 'roll-back', but display what is happening."
  1883. (call-with-values
  1884. (lambda ()
  1885. (roll-back store profile))
  1886. display-generation-change))
  1887. (define (switch-to-generation* profile number)
  1888. "Like 'switch-to-generation', but display what is happening."
  1889. (let ((previous (switch-to-generation profile number)))
  1890. (display-generation-change previous number)))
  1891. (define (delete-generation* store profile generation)
  1892. "Like 'delete-generation', but display what is going on."
  1893. (format #t (G_ "deleting ~a~%")
  1894. (generation-file-name profile generation))
  1895. (delete-generation store profile generation))
  1896. (define* (package-specification->name+version+output spec
  1897. #:optional (output "out"))
  1898. "Parse package specification SPEC and return three value: the specified
  1899. package name, version number (or #f), and output name (or OUTPUT). SPEC may
  1900. optionally contain a version number and an output name, as in these examples:
  1901. guile
  1902. guile@2.0.9
  1903. guile:debug
  1904. guile@2.0.9:debug
  1905. "
  1906. (let*-values (((name sub-drv)
  1907. (match (string-rindex spec #\:)
  1908. (#f (values spec output))
  1909. (colon (values (substring spec 0 colon)
  1910. (substring spec (+ 1 colon))))))
  1911. ((name version)
  1912. (package-name->name+version name)))
  1913. (values name version sub-drv)))
  1914. ;;;
  1915. ;;; Command-line option processing.
  1916. ;;;
  1917. (define (show-guix-usage)
  1918. (format (current-error-port)
  1919. (G_ "Try `guix --help' for more information.~%"))
  1920. (exit 1))
  1921. ;; Representation of a 'guix' command.
  1922. (define-immutable-record-type <command>
  1923. (command name synopsis category)
  1924. command?
  1925. (name command-name)
  1926. (synopsis command-synopsis)
  1927. (category command-category))
  1928. (define (source-file-command file)
  1929. "Read FILE, a Scheme source file, and return either a <command> object based
  1930. on the 'define-command' top-level form found therein, or #f if FILE does not
  1931. contain a 'define-command' form."
  1932. (define command-name
  1933. (match (filter (negate string-null?)
  1934. (string-split file #\/))
  1935. ((_ ... "guix" (or "scripts" "extensions") name)
  1936. (list (file-sans-extension name)))
  1937. ((_ ... "guix" (or "scripts" "extensions") first second)
  1938. (list first (file-sans-extension second)))))
  1939. ;; The strategy here is to parse FILE. This is much cheaper than a
  1940. ;; technique based on run-time introspection where we'd load FILE and all
  1941. ;; the modules it depends on.
  1942. (call-with-input-file file
  1943. (lambda (port)
  1944. (let loop ()
  1945. (match (read port)
  1946. (('define-command _ ('synopsis synopsis)
  1947. _ ...)
  1948. (command command-name synopsis 'main))
  1949. (('define-command _
  1950. ('category category) ('synopsis synopsis)
  1951. _ ...)
  1952. (command command-name synopsis category))
  1953. ((? eof-object?)
  1954. #f)
  1955. (_
  1956. (loop)))))))
  1957. (define* (command-files #:optional directory)
  1958. "Return the list of source files that define Guix sub-commands."
  1959. (define directory*
  1960. (or directory
  1961. (and=> (search-path %load-path "guix.scm")
  1962. (compose (cut string-append <> "/guix/scripts")
  1963. dirname))))
  1964. (define dot-scm?
  1965. (cut string-suffix? ".scm" <>))
  1966. (if directory*
  1967. (map (cut string-append directory* "/" <>)
  1968. (scandir directory* dot-scm?))
  1969. '()))
  1970. (define (extension-directories)
  1971. "Return the list of directories containing Guix extensions."
  1972. (filter file-exists?
  1973. (parse-path
  1974. (getenv "GUIX_EXTENSIONS_PATH"))))
  1975. (define (commands)
  1976. "Return the list of commands, alphabetically sorted."
  1977. (filter-map source-file-command
  1978. (append (command-files)
  1979. (append-map command-files
  1980. (extension-directories)))))
  1981. (define (show-guix-help)
  1982. (define (internal? command)
  1983. (member command '("substitute" "authenticate" "offload"
  1984. "perform-download")))
  1985. (define (display-commands commands)
  1986. (let* ((names (map (lambda (command)
  1987. (string-join (command-name command)))
  1988. commands))
  1989. (max-width (reduce max 0 (map string-length names))))
  1990. (for-each (lambda (name command)
  1991. (format #t " ~a ~a~%"
  1992. (string-pad-right name max-width)
  1993. (G_ (command-synopsis command))))
  1994. names
  1995. commands)))
  1996. (define (category-predicate category)
  1997. (lambda (command)
  1998. (eq? category (command-category command))))
  1999. (display (G_ "Usage: guix OPTION | COMMAND ARGS...
  2000. Run COMMAND with ARGS, if given.\n"))
  2001. (display (G_ "
  2002. -h, --help display this helpful text again and exit"))
  2003. (display (G_ "
  2004. -V, --version display version and copyright information and exit"))
  2005. (newline)
  2006. (newline)
  2007. (display (G_ "COMMAND must be one of the sub-commands listed below:\n"))
  2008. (let ((commands (commands))
  2009. (categories (module-ref (resolve-interface '(guix scripts))
  2010. '%command-categories)))
  2011. (for-each (match-lambda
  2012. (('internal . _)
  2013. #t) ;hide internal commands
  2014. ((category . synopsis)
  2015. (let ((relevant-commands (filter (category-predicate category)
  2016. commands)))
  2017. ;; Only print categories that contain commands.
  2018. (match relevant-commands
  2019. ((one . more)
  2020. (format #t "~% ~a~%" (G_ synopsis))
  2021. (display-commands relevant-commands))
  2022. (_ #f)))))
  2023. categories))
  2024. (show-bug-report-information))
  2025. (define (run-guix-command command . args)
  2026. "Run COMMAND with the given ARGS. Report an error when COMMAND is not
  2027. found."
  2028. (define (command-hint guess commands)
  2029. (define command-names
  2030. (map (lambda (command)
  2031. (match (command-name command)
  2032. ((head tail ...) head)))
  2033. commands))
  2034. (string-closest (symbol->string guess) command-names #:threshold 3))
  2035. (define module
  2036. ;; Check if there is a matching extension.
  2037. (match (search-path (extension-directories)
  2038. (format #f "~a.scm" command))
  2039. (#f
  2040. (catch 'misc-error
  2041. (lambda ()
  2042. (resolve-interface `(guix scripts ,command)))
  2043. (lambda _
  2044. (let ((hint (command-hint command (commands))))
  2045. (format (current-error-port)
  2046. (G_ "guix: ~a: command not found~%") command)
  2047. (when hint
  2048. (display-hint (G_ "Did you mean @code{~a}?") hint))
  2049. (show-guix-usage)))))
  2050. (file
  2051. (load file)
  2052. (resolve-interface `(guix extensions ,command)))))
  2053. (let ((command-main (module-ref module
  2054. (symbol-append 'guix- command))))
  2055. (parameterize ((program-name command))
  2056. (dynamic-wind
  2057. (const #f)
  2058. (lambda ()
  2059. (apply command-main args))
  2060. (lambda ()
  2061. ;; Abuse 'exit-hook' (which is normally meant to be used by the
  2062. ;; REPL) to run things like profiling hooks upon completion.
  2063. (run-hook exit-hook))))))
  2064. (define (run-guix . args)
  2065. "Run the 'guix' command defined by command line ARGS.
  2066. Unlike 'guix-main', this procedure assumes that locale, i18n support,
  2067. and signal handling have already been set up."
  2068. (define option? (cut string-prefix? "-" <>))
  2069. ;; The default %LOAD-EXTENSIONS includes the empty string, which doubles the
  2070. ;; number of 'stat' calls per entry in %LOAD-PATH. Shamelessly remove it.
  2071. (set! %load-extensions '(".scm"))
  2072. ;; Disable canonicalization so we don't don't stat unreasonably.
  2073. (with-fluids ((%file-port-name-canonicalization #f))
  2074. (match args
  2075. (()
  2076. (format (current-error-port)
  2077. (G_ "guix: missing command name~%"))
  2078. (show-guix-usage))
  2079. ((or ("-h") ("--help"))
  2080. (leave-on-EPIPE (show-guix-help)))
  2081. ((or ("-V") ("--version"))
  2082. (show-version-and-exit "guix"))
  2083. (((? option? o) args ...)
  2084. (format (current-error-port)
  2085. (G_ "guix: unrecognized option '~a'~%") o)
  2086. (show-guix-usage))
  2087. (("help" command)
  2088. (apply run-guix-command (string->symbol command)
  2089. '("--help")))
  2090. (("help" args ...)
  2091. (leave-on-EPIPE (show-guix-help)))
  2092. ((command args ...)
  2093. (apply run-guix-command
  2094. (string->symbol command)
  2095. args)))))
  2096. (define (guix-main arg0 . args)
  2097. (initialize-guix)
  2098. (apply run-guix args))
  2099. ;;; Local Variables:
  2100. ;;; eval: (put 'guard* 'scheme-indent-function 2)
  2101. ;;; End:
  2102. ;;; ui.scm ends here