From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp10.migadu.com ([2001:41d0:2:bcc0::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms0.migadu.com with LMTPS id 4NsmIjfd0mGd+wAAgWs5BA (envelope-from ) for ; Mon, 03 Jan 2022 12:25:43 +0100 Received: from aspmx1.migadu.com ([2001:41d0:2:bcc0::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp10.migadu.com with LMTPS id eF7IGjfd0mEdZQEAG6o9tA (envelope-from ) for ; Mon, 03 Jan 2022 12:25:43 +0100 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id 6491D358FB for ; Mon, 3 Jan 2022 12:25:42 +0100 (CET) Received: from localhost ([::1]:46332 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1n4LTB-0005KH-GE for larch@yhetil.org; Mon, 03 Jan 2022 06:25:41 -0500 Received: from eggs.gnu.org ([209.51.188.92]:51412) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1n4LSs-0005Ii-I1 for guix-patches@gnu.org; Mon, 03 Jan 2022 06:25:22 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:50955) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1n4LSY-0001oL-M5 for guix-patches@gnu.org; Mon, 03 Jan 2022 06:25:15 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1n4LSY-0005vw-Fs for guix-patches@gnu.org; Mon, 03 Jan 2022 06:25:02 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#52974] [PATCH 1/5] style: Improve pretty printer and add tests. References: <20220103105335.13164-1-ludo@gnu.org> In-Reply-To: <20220103105335.13164-1-ludo@gnu.org> Resent-From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Mon, 03 Jan 2022 11:25:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 52974 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 52974@debbugs.gnu.org Cc: Ludovic =?UTF-8?Q?Court=C3=A8s?= Received: via spool by 52974-submit@debbugs.gnu.org id=B52974.164120909922767 (code B ref 52974); Mon, 03 Jan 2022 11:25:02 +0000 Received: (at 52974) by debbugs.gnu.org; 3 Jan 2022 11:24:59 +0000 Received: from localhost ([127.0.0.1]:34260 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1n4LSV-0005v5-0C for submit@debbugs.gnu.org; Mon, 03 Jan 2022 06:24:59 -0500 Received: from eggs.gnu.org ([209.51.188.92]:50512) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1n4LSR-0005uQ-Un for 52974@debbugs.gnu.org; Mon, 03 Jan 2022 06:24:57 -0500 Received: from [2001:470:142:3::e] (port=49186 helo=fencepost.gnu.org) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1n4LSM-0001k7-N0; Mon, 03 Jan 2022 06:24:50 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org; s=fencepost-gnu-org; h=MIME-Version:Date:Subject:To:From:in-reply-to: references; bh=qGhCoSYg+fRNutUC0RS+BjOXrc/ZoYETwOEEanQ6xD0=; b=FwTIWqDKl/DtOR 6je8g8RU8d3W9VfYziXiyMeOZlIyXI4Varrxk4X7Uk3RJTLUpFEN271pBlquSCChpUqWkXp8Tp4KZ Y5lb98nPCMj1E7BEOrHyAq6OaM3ryitwD1XWHCBm8auymHKUxZTzkNfEbnROcR/yRQK4qi2zMYOjL aTMu0TNaaUZVsTfkefaU6PK0OXeR4sJiUNKKV0u+sBidIJjpmaEoOvaK2wCW/nTDjrskBYhfBkmgQ FeOiH04UqRWDq/tzFV4z9BpsG8jJiU6BIrfVthJHZP7i1ekD+qGdPNNragbHwqzKhUPrpdsVECcJn wOoM+UrVwDC0qys3R9DA==; Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=42680 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1n4LSM-0005n0-Q3; Mon, 03 Jan 2022 06:24:51 -0500 From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Mon, 3 Jan 2022 12:24:35 +0100 Message-Id: <20220103112439.14377-1-ludo@gnu.org> X-Mailer: git-send-email 2.33.0 MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+larch=yhetil.org@gnu.org Sender: "Guix-patches" X-Migadu-Flow: FLOW_IN X-Migadu-Country: US ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=yhetil.org; s=key1; t=1641209142; h=from:from:sender:sender:reply-to:subject:subject:date:date: message-id:message-id:to:to:cc:cc:mime-version:mime-version: content-transfer-encoding:content-transfer-encoding:resent-cc: resent-from:resent-sender:resent-message-id:in-reply-to:in-reply-to: references:references:list-id:list-help:list-unsubscribe: list-subscribe:list-post:dkim-signature; bh=mLXf1Gp2gMee06N/fx01EHAKdZ2f5ulpkGZacvm0Loo=; b=gLngsiKn/OM4N8UDUJyYE7OCD7Im8xLQCGX/BA0M/kMrbBzUOaD203mbiaHh9vSo1v6KNE JpNOTLZp0UEApsgMvIdFDm5phEEZPkzLC6POd1RTBSM176yTY90HyRGleRqBctwSNXzDli qez9D9z6Du1OLOjcAQZv4uAXvw0OAzdU+pRT8hwhf9nY09zw66WqrGMwToZ7C/WcB4hiOV H8lGR4dxG7qoItx+Z4NESw1/NGcS6ieE8qWvWtBOQPYMjOEwy/CaKThLJEr67IGLMmhhPB hT1/z0DpBdj5QkjMub4xNR1XVMBxs0ngG5ckkx7HkUiY0OZvAwgZO2mvpjfgLQ== ARC-Seal: i=1; s=key1; d=yhetil.org; t=1641209142; a=rsa-sha256; cv=none; b=uMm8GCT57X8w0YNFwS1OHLmv587tNz9+NdqwVENLsspWF+TskCyNYbSAluM0Ly6/9YTlwI ofAzq6iXoZCsVRR4XgNYBv2bkB3DAD+vgm3wd9x3PqODgDqN7oh9DR6mY1xJSFsAkHonZn gr+MM8pLiJk8KJ3V+8y7UMcwH6NWPWa81kUx5xtSkt/dpRUa8UuK18tlg7PWjhpY45m77p eGkweOcvj8dXlF3Se+ui++70GHzEe4hZ4ZTXIzUfk1IAjYV+JgREBkszoBeXGywKekGrbe rk0jI5SmGwGPsB+X+19k/O5QSlB68Z8ypeLTwuRZSa8BORXL3eeAzotvgcz87A== ARC-Authentication-Results: i=1; aspmx1.migadu.com; dkim=fail ("body hash did not verify") header.d=gnu.org header.s=fencepost-gnu-org header.b=FwTIWqDK; dmarc=pass (policy=none) header.from=gnu.org; spf=pass (aspmx1.migadu.com: domain of "guix-patches-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="guix-patches-bounces+larch=yhetil.org@gnu.org" X-Migadu-Spam-Score: -3.09 Authentication-Results: aspmx1.migadu.com; dkim=fail ("body hash did not verify") header.d=gnu.org header.s=fencepost-gnu-org header.b=FwTIWqDK; dmarc=pass (policy=none) header.from=gnu.org; spf=pass (aspmx1.migadu.com: domain of "guix-patches-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="guix-patches-bounces+larch=yhetil.org@gnu.org" X-Migadu-Queue-Id: 6491D358FB X-Spam-Score: -3.09 X-Migadu-Scanner: scn0.migadu.com X-TUID: AuaGvMHPbrru * guix/scripts/style.scm (vhashq): New macro. (%special-forms): New variable. (special-form?): New procedure. (pretty-print-with-comments): Add many clauses and tweak existing rules. * tests/style.scm (test-pretty-print): New macro. : Add 'test-pretty-print' tests. --- guix/scripts/style.scm | 270 +++++++++++++++++++++++++++++++++-------- tests/style.scm | 95 +++++++++++++++ 2 files changed, 316 insertions(+), 49 deletions(-) diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm index 3b246e9c66..a5204d02ef 100644 --- a/guix/scripts/style.scm +++ b/guix/scripts/style.scm @@ -40,11 +40,15 @@ (define-module (guix scripts style) #:use-module (ice-9 control) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) + #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) - #:export (guix-style)) + #:export (pretty-print-with-comments + read-with-comments + + guix-style)) ;;; @@ -109,15 +113,136 @@ (define (read-with-comments port) ;;; Comment-preserving pretty-printer. ;;; +(define-syntax vhashq + (syntax-rules () + ((_) vlist-null) + ((_ (key value) 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. + (vhashq + ('begin 1) + ('lambda 2) + ('lambda* 2) + ('match-lambda 1) + ('match-lambda* 2) + ('define 2) + ('define* 2) + ('define-public 2) + ('define*-public 2) + ('define-syntax 2) + ('define-syntax-rule 2) + ('define-module 2) + ('define-gexp-compiler 2) + ('let 2) + ('let* 2) + ('letrec 2) + ('letrec* 2) + ('match 2) + ('when 2) + ('unless 2) + ('package 1) + ('origin 1) + ('operating-system 1) + ('modify-inputs 2) + ('modify-phases 2) + ('add-after 3) + ('add-before 3) + ;; ('replace 2) + ('substitute* 2) + ('substitute-keyword-arguments 2) + ('call-with-input-file 2) + ('call-with-output-file 2) + ('with-output-to-file 2) + ('with-input-from-file 2))) + +(define (special-form? symbol) + (vhash-assq symbol %special-forms)) + +(define (escaped-string str) + "Return STR with backslashes and double quotes escaped. Everything else, in +particular newlines, is left as is." + (list->string + `(#\" + ,@(string-fold-right (lambda (chr lst) + (match chr + (#\" (cons* #\\ #\" lst)) + (#\\ (cons* #\\ #\\ lst)) + (_ (cons chr lst)))) + '() + str) + #\"))) + +(define (string-width str) + "Return the \"width\" of STR--i.e., the width of the longest line of STR." + (apply max (map string-length (string-split str #\newline)))) + (define* (pretty-print-with-comments port obj #:key (indent 0) (max-width 78) (long-list 5)) + "Pretty-print OBJ to PORT, attempting to at most MAX-WIDTH character columns +and assuming the current column is INDENT. Comments present in OBJ are +included in the output. + +Lists longer than LONG-LIST are written as one element per line." (let loop ((indent indent) (column indent) (delimited? #t) ;true if comes after a delimiter (obj obj)) + (define (print-sequence indent column lst delimited?) + (define long? + (> (length lst) long-list)) + + (let print ((lst lst) + (first? #t) + (delimited? delimited?) + (column column)) + (match lst + (() + column) + ((item . tail) + (define newline? + ;; Insert a newline if ITEM is itself a list, or if TAIL is long, + ;; but only if ITEM is not the first item. Also insert a newline + ;; before a keyword. + (and (or (pair? item) long? + (and (keyword? item) + (not (eq? item #:allow-other-keys)))) + (not first?) (not delimited?) + (not (comment? item)))) + + (when newline? + (newline port) + (display (make-string indent #\space) port)) + (let ((column (if newline? indent column))) + (print tail #f + (comment? item) + (loop indent column + (or newline? delimited?) + item))))))) + + (define (sequence-would-protrude? indent lst) + ;; Return true if elements of LST written at INDENT would protrude + ;; beyond MAX-WIDTH. This is implemented as a cheap test with false + ;; negatives to avoid actually rendering all of LST. + (find (match-lambda + ((? string? str) + (>= (+ (string-width str) 2 indent) max-width)) + ((? symbol? symbol) + (>= (+ (string-width (symbol->string symbol)) indent) + max-width)) + ((? boolean?) + (>= (+ 2 indent) max-width)) + (() + (>= (+ 2 indent) max-width)) + (_ ;don't know + #f)) + lst)) + (match obj ((? comment? comment) (if (comment-margin? comment) @@ -145,57 +270,104 @@ (define* (pretty-print-with-comments port obj (unless delimited? (display " " port)) (display "," port) (loop indent (+ column (if delimited? 1 2)) #t lst)) - (('modify-inputs inputs clauses ...) - ;; Special-case 'modify-inputs' to have one clause per line and custom - ;; indentation. - (let ((head "(modify-inputs ")) + (('unquote-splicing lst) + (unless delimited? (display " " port)) + (display ",@" port) + (loop indent (+ column (if delimited? 2 3)) #t lst)) + (('gexp lst) + (unless delimited? (display " " port)) + (display "#~" port) + (loop indent (+ column (if delimited? 2 3)) #t lst)) + (('ungexp obj) + (unless delimited? (display " " port)) + (display "#$" port) + (loop indent (+ column (if delimited? 2 3)) #t obj)) + (('ungexp-native obj) + (unless delimited? (display " " port)) + (display "#+" port) + (loop indent (+ column (if delimited? 2 3)) #t obj)) + (('ungexp-splicing lst) + (unless delimited? (display " " port)) + (display "#$@" port) + (loop indent (+ column (if delimited? 3 4)) #t lst)) + (('ungexp-native-splicing lst) + (unless delimited? (display " " port)) + (display "#+@" port) + (loop indent (+ column (if delimited? 3 4)) #t 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))) + (unless delimited? (display " " port)) + (display "(" port) (display head port) - (loop (+ indent 4) - (+ column (string-length head)) - #t - inputs) - (let* ((indent (+ indent 2)) - (column (fold (lambda (clause column) - (newline port) - (display (make-string indent #\space) - port) - (loop indent indent #t clause)) - indent - clauses))) + (unless (zero? lead) + (display " " port)) + + ;; Print the first LEAD arguments. + (let* ((indent (+ column 2 + (if delimited? 0 1))) + (column (+ column 1 + (if (zero? lead) 0 1) + (if delimited? 0 1) + (string-length head))) + (initial-indent column)) + (define new-column + (let inner ((n lead) + (arguments (take arguments (min lead total))) + (column column)) + (if (zero? n) + (begin + (newline port) + (display (make-string indent #\space) port) + indent) + (match arguments + (() column) + ((head . tail) + (inner (- n 1) tail + (loop initial-indent + column + (= n lead) + head))))))) + + ;; Print the remaining arguments. + (let ((column (print-sequence + indent new-column + (drop arguments (min lead total)) + #t))) + (display ")" port) + (+ column 1))))) + ((head tail ...) + (let* ((overflow? (>= column max-width)) + (column (if overflow? + (+ indent 1) + (+ column (if delimited? 1 2))))) + (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)) + (indent (if (or (>= new-column max-width) + (not (symbol? head)) + (sequence-would-protrude? + (+ new-column 1) tail)) + column + (+ new-column 1)))) + (define column + (print-sequence indent new-column tail #f)) (display ")" port) (+ column 1)))) - ((head tail ...) - (unless delimited? (display " " port)) - (display "(" port) - (let* ((new-column (loop indent (+ 1 column) #t head)) - (indent (+ indent (- new-column column))) - (long? (> (length tail) long-list))) - (define column - (fold2 (lambda (item column first?) - (define newline? - ;; Insert a newline if ITEM is itself a list, or if TAIL - ;; is long, but only if ITEM is not the first item. - (and (or (pair? item) long?) - (not first?) (not (comment? item)))) - - (when newline? - (newline port) - (display (make-string indent #\space) port)) - (let ((column (if newline? indent column))) - (values (loop indent - column - (= column indent) - item) - (comment? item)))) - (+ 1 new-column) - #t ;first - tail)) - (display ")" port) - (+ column 1))) (_ - (let* ((str (object->string obj)) - (len (string-length str))) - (if (> (+ column 1 len) max-width) + (let* ((str (if (string? obj) + (escaped-string obj) + (object->string obj))) + (len (string-width str))) + (if (and (> (+ column 1 len) max-width) + (not delimited?)) (begin (newline port) (display (make-string indent #\space) port) @@ -204,7 +376,7 @@ (define newline? (begin (unless delimited? (display " " port)) (display str port) - (+ column (if delimited? 1 2) len)))))))) + (+ column (if delimited? 0 1) len)))))))) (define (object->string* obj indent) (call-with-output-string diff --git a/tests/style.scm b/tests/style.scm index ada9197fc1..d9e8d803f4 100644 --- a/tests/style.scm +++ b/tests/style.scm @@ -21,6 +21,7 @@ (define-module (tests-style) #:use-module (guix scripts style) #:use-module ((guix utils) #:select (call-with-temporary-directory)) #:use-module ((guix build utils) #:select (substitute*)) + #:use-module (guix gexp) ;for the reader extension #:use-module (guix diagnostics) #:use-module (gnu packages acl) #:use-module (gnu packages multiprecision) @@ -111,6 +112,17 @@ (define* (read-package-field package field #:optional (count 1)) (lambda (port) (read-lines port line count))))) +(define-syntax-rule (test-pretty-print str args ...) + "Test equality after a round-trip where STR is passed to +'read-with-comments' and the resulting sexp is then passed to +'pretty-print-with-comments'." + (test-equal str + (call-with-output-string + (lambda (port) + (let ((exp (call-with-input-string str + read-with-comments))) + (pretty-print-with-comments port exp args ...)))))) + (test-begin "style") @@ -358,6 +370,89 @@ (define file (list (package-inputs (@ (my-packages) my-coreutils)) (read-package-field (@ (my-packages) my-coreutils) 'inputs 4))))) +(test-pretty-print "(list 1 2 3 4)") +(test-pretty-print "(list 1 + 2 + 3 + 4)" + #:long-list 3 + #:indent 20) +(test-pretty-print "\ +(list abc + def)" + #:max-width 11) +(test-pretty-print "\ +(#:foo + #:bar)" + #:max-width 10) + +(test-pretty-print "\ +(#:first 1 + #:second 2 + #:third 3)") + +(test-pretty-print "\ +((x + 1) + (y + 2) + (z + 3))" + #:max-width 3) + +(test-pretty-print "\ +(let ((x 1) + (y 2) + (z 3) + (p 4)) + (+ x y))" + #:max-width 11) + +(test-pretty-print "\ +(lambda (x y) + ;; This is a procedure. + (let ((z (+ x y))) + (* z z)))") + +(test-pretty-print "\ +#~(string-append #$coreutils \"/bin/uname\")") + +(test-pretty-print "\ +(package + (inherit coreutils) + (version \"42\"))") + +(test-pretty-print "\ +(modify-phases %standard-phases + (add-after 'unpack 'post-unpack + (lambda _ + #t)) + (add-before 'check 'pre-check + (lambda* (#:key inputs #:allow-other-keys) + do things ...)))") + +(test-pretty-print "\ +(#:phases (modify-phases sdfsdf + (add-before 'x 'y + (lambda _ + xyz))))") + +(test-pretty-print "\ +(description \"abcdefghijkl +mnopqrstuvwxyz.\")" + #:max-width 30) + +(test-pretty-print "\ +(description + \"abcdefghijkl +mnopqrstuvwxyz.\")" + #:max-width 12) + +(test-pretty-print "\ +(description + \"abcdefghijklmnopqrstuvwxyz\")" + #:max-width 33) + (test-end) ;; Local Variables: -- 2.33.0