Regarding "Use Invoke" or "Return a boolean from phase" commits

[Mark H Weaver]

Hello Guix,

Many thanks to those of you who have been contributing to the effort to
clean up our error reporting from phases, with the eventual goal of
ignoring the return value from phases and snippets, and relying on
exceptions as the sole method to report errors.

I just wanted to clarify that what's really important when looking at a
package is that its phases and snippets should always return #t, and
that errors generate exceptions.

Fixing phases to merely "returning a boolean" is a good thing to do, but
not enough to bring us to the ultimate goal stated above.  For that, we
need to return #t.

Similarly, fixing a package to "use invoke" is also not, in itself,
enough to ensure this goal.  That is merely a convenient way to achieve
the goal in phases or snippets that end with (zero? (system* ...)).

So, although I've used both of these phrases in my commit logs in the
past, now I see that it's be more useful to say "Return #t from all
phases", because that's what we really need.

Furthermore, it will be important for a static code analyzer to be able
to infer that phases and snippets always return #t, so let's try not to
be too clever about it.  We'll need a static analyzer to gain confidence
that we can start ignoring the return values without losing failure
reports.

Quite a while ago, I hacked up a preliminary static analyzer to do this.
Obviously it would be good to integrate something like this into our
linter, but I haven't gotten around to it yet.  In the meantime, I've
attached my preliminary code below.  Here's how it's used:

--8<---------------cut here---------------start------------->8---
address@hidden ~/guix$ ./pre-inst-env guile
GNU Guile 2.2.3
Copyright (C) 1995-2017 Free Software Foundation, Inc.

Guile comes with ABSOLUTELY NO WARRANTY; for details type `,show w'.
This program is free software, and you are welcome to redistribute it
under certain conditions; type `,show c' for details.

Enter `,help' for help.
scheme@(guile-user)> (load "/home/mhw/src/returns-t-checker.scm")
scheme@(guile-user)> (define builder-probs (possible-builder-problem-pkgs))
scheme@(guile-user)> ,pp (sort builder-probs package-name<?)
$1 = (#<package address@hidden gnu/packages/boost.scm:117 38a5780>
 #<package address@hidden gnu/packages/video.scm:2891 330a900>)
scheme@(guile-user)> (define phase-probs (possible-phase-problem-pkgs))
scheme@(guile-user)> ,pp (sort phase-probs package-name<?)
$2 = (#<package address@hidden gnu/packages/games.scm:4133 408f180>
 #<package address@hidden gnu/packages/databases.scm:118 25b5480>
 #<package address@hidden gnu/packages/pretty-print.scm:45 3986f00>
 #<package address@hidden gnu/packages/games.scm:927 406b540>
 #<package address@hidden gnu/packages/fpga.scm:51 3fb6a80>
 #<package address@hidden gnu/packages/cdrom.scm:473 36420c0>
 #<package address@hidden gnu/packages/version-control.scm:1377 30d0a80>
 #<package address@hidden gnu/packages/video.scm:2679 330acc0>
 #<package address@hidden gnu/packages/graphics.scm:622 31526c0>

[...]

 #<package address@hidden gnu/packages/games.scm:4534 4099d80>
 #<package address@hidden gnu/packages/fpga.scm:120 3fb6900>
 #<package address@hidden gnu/packages/video.scm:1262 32fb780>
 #<package address@hidden gnu/packages/maths.scm:3770 37bbf00>
 #<package address@hidden gnu/packages/pdf.scm:495 317ce40>
 #<package address@hidden gnu/packages/zile.scm:83 2cff0c0>
 #<package address@hidden gnu/packages/image.scm:1039 3968e40>
 #<package address@hidden gnu/packages/audio.scm:2938 365fd80>
 #<package address@hidden gnu/packages/audio.scm:2841 365ff00>
 #<package address@hidden gnu/packages/audio.scm:2888 365fe40>
 #<package address@hidden gnu/packages/shells.scm:293 38a5f00>)
scheme@(guile-user)> 
--8<---------------cut here---------------end--------------->8---

Comments and suggestions welcome.

       Mark


;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Mark H Weaver <address@hidden>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.


;;; This is very preliminary work.

(use-modules (guix)
             (guix derivations)
             (gnu)
             (ice-9 match)
             (srfi srfi-1))

(define proc-returns-t?
  (match-lambda
    (((or 'lambda
          'lambda*)
      formals bodies ... last)
     (returns-t? last))
    (((or 'let
          'let*
          'letrec
          'letrec*
          'with-fluids)
      (bindings ...) bodies ... last)
     (proc-returns-t? last))
    (('begin exprs ... last)
     (proc-returns-t? last))
    (('const expr)
     (returns-t? expr))
    ('invoke #t)
    (_ #f)))

(define returns-t?
  (match-lambda
    (#t #t)
    (('begin exprs ... last)
     (returns-t? last))
    (((or 'let
          'let*
          'letrec
          'letrec*
          'with-fluids)
      (bindings ...) bodies ... last)
     (returns-t? last))
    (('match expr (pattern bodies ... last) ...)
     (every returns-t? last))
    (('with-directory-excursion dir bodies ... last)
     (returns-t? last))
    (((or 'call-with-input-file
          'call-with-output-file
          'with-input-to-file
          'with-output-to-file
          'with-atomic-file-replacement)
      file-name proc)
     (proc-returns-t? proc))
    (('apply proc args ... tail)
     (proc-returns-t? proc))
    ((proc args ...)
     (proc-returns-t? proc))
    (_ #f)))

(define mod-spec-returns-t?
  (match-lambda
    (((or 'add-before 'add-after) _ _ proc)
     (proc-returns-t? proc))
    (('replace _ proc)
     (proc-returns-t? proc))
    (('delete _)
     #t)))

(define phases-return-t?
  (match-lambda
    (#f #t)
    ('%standard-phases #t)
    (('modify-phases orig mod-specs ...)
     (and (every mod-spec-returns-t? mod-specs)
          (phases-return-t? orig)))
    (((or 'alist-cons-before 'alist-cons-after) _ _ proc orig)
     (and (proc-returns-t? proc)
          (phases-return-t? orig)))
    (('alist-replace _ proc orig)
     (and (proc-returns-t? proc)
          (phases-return-t? orig)))
    (('alist-delete _ orig)
     (phases-return-t? orig))
    (_ #f)))

(define (package-snippet pkg)
  (and=> (package-source pkg)
         origin-snippet))

(define (snippet-returns-t? snippet)
  (or (not snippet)
      (returns-t? snippet)))

(define (possible-snippet-problem-pkgs)
  (fold-packages cons '() #:select? (negate (compose snippet-returns-t?
                                                     package-snippet))))

(define (arguments->phases arguments)
  (apply (lambda* (#:key phases #:allow-other-keys)
                    phases)
                  arguments))

(define (package-phases pkg)
  (and=> (package-arguments pkg)
         arguments->phases))

(define (possible-phase-problem-pkgs)
  (fold-packages cons '() #:select? (negate (compose phases-return-t?
                                                     package-phases))))

(define (arguments->builder arguments)
  (apply (lambda* (#:key builder #:allow-other-keys)
           builder)
         arguments))

(define (package-builder pkg)
  (and=> (package-arguments pkg)
         arguments->builder))

(define (builder-returns-t? builder)
  (or (not builder)
      (returns-t? builder)))

(define (possible-builder-problem-pkgs)
  (fold-packages cons '() #:select? (negate (compose builder-returns-t?
                                                     package-builder))))

(define (package-name<? a b)
  (string<? (package-name a) (package-name b)))

;; (sort probs package-name<?)


(define (possible-phase-problem-pkgs-from-drvs drv-files)
  (filter (lambda (drv-file)
            (and (file-exists? drv-file)
                 (let ((drv (read-derivation-from-file drv-file)))
                   (match (derivation-builder-arguments drv)
                     ((_ ... file)
                      (and (string-suffix? "-guile-builder" file)
                           (let ((builder (call-with-input-file file
                                            (lambda (p) (read p) (read p)))))
                             (match builder
                               (('exit ('begin ('gnu-build . arguments)))
                                (let ((phases (arguments->phases arguments)))
                                  (not (phases-return-t? phases))))
                               (_ #f)))))
                     (_ #f)))))
          drv-files))