[bug#52974] [PATCH 2/5] style: Allow special forms to be scoped.

["Ludovic Courtès" <ludo@gnu.org>]

* guix/scripts/style.scm (vhashq): Add clause for 'lst, and change
default clause.
(%special-forms): Add context for 'add-after and 'add-before.  Add
'replace.
(prefix?, special-form-lead): New procedures.
(special-form?): Remove.
(pretty-print-with-comments): Add 'context' to the threaded state.
Adjust 'print-sequence' and adjust 'loop' calls accordingly.
* tests/style.scm: Add tests for 'replace.
---
 guix/scripts/style.scm | 88 +++++++++++++++++++++++++++++-------------
 tests/style.scm        | 12 ++++++
 2 files changed, 73 insertions(+), 27 deletions(-)

diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm
index a5204d02ef..625e942613 100644
--- a/guix/scripts/style.scm
+++ b/guix/scripts/style.scm
@@ -114,14 +114,19 @@ (define (read-with-comments port)
 ;;;
 
 (define-syntax vhashq
-  (syntax-rules ()
+  (syntax-rules (quote)
     ((_) vlist-null)
+    ((_ (key (quote (lst ...))) rest ...)
+     (vhash-consq key '(lst ...) (vhashq rest ...)))
     ((_ (key value) rest ...)
-     (vhash-consq key value (vhashq rest ...)))))
+     (vhash-consq key '((() . value)) (vhashq rest ...)))))
 
 (define %special-forms
   ;; Forms that are indented specially.  The number is meant to be understood
-  ;; like Emacs' 'scheme-indent-function' symbol property.
+  ;; like Emacs' 'scheme-indent-function' symbol property.  When given an
+  ;; alist instead of a number, the alist gives "context" in which the symbol
+  ;; is a special form; for instance, context (modify-phases) means that the
+  ;; symbol must appear within a (modify-phases ...) expression.
   (vhashq
    ('begin 1)
    ('lambda 2)
@@ -148,9 +153,9 @@ (define %special-forms
    ('operating-system 1)
    ('modify-inputs 2)
    ('modify-phases 2)
-   ('add-after 3)
-   ('add-before 3)
-   ;; ('replace 2)
+   ('add-after '(((modify-phases) . 3)))
+   ('add-before '(((modify-phases) . 3)))
+   ('replace '(((modify-phases) . 2)))         ;different from 'modify-inputs'
    ('substitute* 2)
    ('substitute-keyword-arguments 2)
    ('call-with-input-file 2)
@@ -158,8 +163,30 @@ (define %special-forms
    ('with-output-to-file 2)
    ('with-input-from-file 2)))
 
-(define (special-form? symbol)
-  (vhash-assq symbol %special-forms))
+(define (prefix? candidate lst)
+  "Return true if CANDIDATE is a prefix of LST."
+  (let loop ((candidate candidate)
+             (lst lst))
+    (match candidate
+      (() #t)
+      ((head1 . rest1)
+       (match lst
+         (() #f)
+         ((head2 . rest2)
+          (and (equal? head1 head2)
+               (loop rest1 rest2))))))))
+
+(define (special-form-lead symbol context)
+  "If SYMBOL is a special form in the given CONTEXT, return its number of
+arguments; otherwise return #f.  CONTEXT is a stack of symbols lexically
+surrounding SYMBOL."
+  (match (vhash-assq symbol %special-forms)
+    (#f #f)
+    ((_ . alist)
+     (any (match-lambda
+            ((prefix . level)
+             (and (prefix? prefix context) (- level 1))))
+          alist))))
 
 (define (escaped-string str)
   "Return STR with backslashes and double quotes escaped.  Everything else, in
@@ -192,8 +219,9 @@ (define* (pretty-print-with-comments port obj
   (let loop ((indent indent)
              (column indent)
              (delimited? #t)                  ;true if comes after a delimiter
+             (context '())                    ;list of "parent" symbols
              (obj obj))
-    (define (print-sequence indent column lst delimited?)
+    (define (print-sequence context indent column lst delimited?)
       (define long?
         (> (length lst) long-list))
 
@@ -223,6 +251,7 @@ (define newline?
                     (comment? item)
                     (loop indent column
                           (or newline? delimited?)
+                          context
                           item)))))))
 
     (define (sequence-would-protrude? indent lst)
@@ -243,6 +272,9 @@ (define (sequence-would-protrude? indent lst)
                #f))
             lst))
 
+    (define (special-form? head)
+      (special-form-lead head context))
+
     (match obj
       ((? comment? comment)
        (if (comment-margin? comment)
@@ -261,45 +293,46 @@ (define (sequence-would-protrude? indent lst)
       (('quote lst)
        (unless delimited? (display " " port))
        (display "'" port)
-       (loop indent (+ column (if delimited? 1 2)) #t lst))
+       (loop indent (+ column (if delimited? 1 2)) #t context lst))
       (('quasiquote lst)
        (unless delimited? (display " " port))
        (display "`" port)
-       (loop indent (+ column (if delimited? 1 2)) #t lst))
+       (loop indent (+ column (if delimited? 1 2)) #t context lst))
       (('unquote lst)
        (unless delimited? (display " " port))
        (display "," port)
-       (loop indent (+ column (if delimited? 1 2)) #t lst))
+       (loop indent (+ column (if delimited? 1 2)) #t context lst))
       (('unquote-splicing lst)
        (unless delimited? (display " " port))
        (display ",@" port)
-       (loop indent (+ column (if delimited? 2 3)) #t lst))
+       (loop indent (+ column (if delimited? 2 3)) #t context lst))
       (('gexp lst)
        (unless delimited? (display " " port))
        (display "#~" port)
-       (loop indent (+ column (if delimited? 2 3)) #t lst))
+       (loop indent (+ column (if delimited? 2 3)) #t context lst))
       (('ungexp obj)
        (unless delimited? (display " " port))
        (display "#$" port)
-       (loop indent (+ column (if delimited? 2 3)) #t obj))
+       (loop indent (+ column (if delimited? 2 3)) #t context obj))
       (('ungexp-native obj)
        (unless delimited? (display " " port))
        (display "#+" port)
-       (loop indent (+ column (if delimited? 2 3)) #t obj))
+       (loop indent (+ column (if delimited? 2 3)) #t context obj))
       (('ungexp-splicing lst)
        (unless delimited? (display " " port))
        (display "#$@" port)
-       (loop indent (+ column (if delimited? 3 4)) #t lst))
+       (loop indent (+ column (if delimited? 3 4)) #t context lst))
       (('ungexp-native-splicing lst)
        (unless delimited? (display " " port))
        (display "#+@" port)
-       (loop indent (+ column (if delimited? 3 4)) #t lst))
+       (loop indent (+ column (if delimited? 3 4)) #t context lst))
       (((? special-form? head) arguments ...)
        ;; Special-case 'let', 'lambda', 'modify-inputs', etc. so the second
        ;; and following arguments are less indented.
-       (let* ((lead  (- (cdr (vhash-assq head %special-forms)) 1))
-              (head  (symbol->string head))
-              (total (length arguments)))
+       (let* ((lead    (special-form-lead head context))
+              (context (cons head context))
+              (head    (symbol->string head))
+              (total   (length arguments)))
          (unless delimited? (display " " port))
          (display "(" port)
          (display head port)
@@ -327,14 +360,14 @@ (define new-column
                      (() column)
                      ((head . tail)
                       (inner (- n 1) tail
-                             (loop initial-indent
-                                   column
+                             (loop initial-indent column
                                    (= n lead)
+                                   context
                                    head)))))))
 
            ;; Print the remaining arguments.
            (let ((column (print-sequence
-                          indent new-column
+                          context indent new-column
                           (drop arguments (min lead total))
                           #t)))
              (display ")" port)
@@ -343,14 +376,15 @@ (define new-column
        (let* ((overflow? (>= column max-width))
               (column    (if overflow?
                              (+ indent 1)
-                             (+ column (if delimited? 1 2)))))
+                             (+ column (if delimited? 1 2))))
+              (context   (cons head context)))
          (if overflow?
              (begin
                (newline port)
                (display (make-string indent #\space) port))
              (unless delimited? (display " " port)))
          (display "(" port)
-         (let* ((new-column (loop column column #t head))
+         (let* ((new-column (loop column column #t context head))
                 (indent (if (or (>= new-column max-width)
                                 (not (symbol? head))
                                 (sequence-would-protrude?
@@ -358,7 +392,7 @@ (define new-column
                             column
                             (+ new-column 1))))
            (define column
-             (print-sequence indent new-column tail #f))
+             (print-sequence context indent new-column tail #f))
            (display ")" port)
            (+ column 1))))
       (_
diff --git a/tests/style.scm b/tests/style.scm
index d9e8d803f4..6c449cb72e 100644
--- a/tests/style.scm
+++ b/tests/style.scm
@@ -453,6 +453,18 @@ (define file
  \"abcdefghijklmnopqrstuvwxyz\")"
                    #:max-width 33)
 
+(test-pretty-print "\
+(modify-phases %standard-phases
+  (replace 'build
+    ;; Nicely indented in 'modify-phases' context.
+    (lambda _
+      #t)))")
+
+(test-pretty-print "\
+(modify-inputs inputs
+  ;; Regular indentation for 'replace' here.
+  (replace \"gmp\" gmp))")
+
 (test-end)
 
 ;; Local Variables:
-- 
2.33.0