diff options
| -rw-r--r-- | ccwl/ui.scm | 172 | ||||
| -rwxr-xr-x | scripts/ccwl | 17 |
2 files changed, 185 insertions, 4 deletions
diff --git a/ccwl/ui.scm b/ccwl/ui.scm new file mode 100644 index 0000000..97e5d09 --- /dev/null +++ b/ccwl/ui.scm @@ -0,0 +1,172 @@ +;;; ccwl --- Concise Common Workflow Language +;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net> +;;; +;;; This file is part of ccwl. +;;; +;;; ccwl 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. +;;; +;;; ccwl 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 ccwl. If not, see <https://www.gnu.org/licenses/>. + +(define-module (ccwl ui) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-28) + #:use-module (ccwl conditions) + #:export (report-ccwl-violation)) + +(define (repeat thunk n) + "Call THUNK N times." + (unless (zero? n) + (thunk) + (repeat thunk (1- n)))) + +(define (save-excursion thunk port) + "Call THUNK and restore PORT position to what it was before THUNK +was executed. For the curious, this function is named after the +save-excursion function in elisp." + (let ((original-position #f)) + (dynamic-wind (lambda () + (set! original-position (port-position port))) + thunk + (lambda () + (set-port-position! port original-position))))) + +(define (read-end port) + "Return the position in PORT corresponding to the end of the +S-expression starting at the current port position. This function does +not affect the current port position." + (save-excursion (lambda () + (read port) + (port-position port)) + port)) + +(define (read-sexp-string port) + "Read an S-expression from PORT and return it as a string with +whitespace intact." + (get-string-n port (- (read-end port) + (port-position port)))) + +(define (color code str) + "Wrap STR in ANSI escape CODE, thus rendering it in color in a +terminal." + (format "~a[~am~a~a[0m" #\esc code str #\esc)) + +(define bold (cut color 1 <>)) +(define red (cut color 31 <>)) +(define magenta (cut color 35 <>)) + +(define (count-lines str) + "Count the number of lines in STR." + (call-with-input-string str + (lambda (port) + (let loop () + (if (eof-object? (get-line port)) + 0 + (1+ (loop))))))) + +(define (number-of-digits n) + "Return the number of decimal digits in positive integer N." + (if (< n 10) + 1 + (1+ (number-of-digits (quotient n 10))))) + +(define (display-integer n minimum-width port) + "Display integer N to PORT using at least MINIMUM-WIDTH +characters. If N is not large enough, it is padded with spaces." + (display (make-string (max 0 (- minimum-width + (number-of-digits n))) + #\space) + port) + (display n port)) + +(define (display-with-line-numbers str out starting-line-number) + "Display STR to port OUT with each line prefixed with a line +number. Line numbers start from STARTING-LINE-NUMBER." + (call-with-input-string str + (lambda (in) + (let ((last-line-number (+ starting-line-number + (count-lines str)))) + (let loop ((line-number starting-line-number)) + (let ((line (get-line in))) + (unless (eof-object? line) + (display (make-string 4 #\space) out) + (display-integer line-number + (number-of-digits last-line-number) + out) + (display (format " | ~a~%" line) out) + (loop (1+ line-number))))))))) + +(define (put-line line port) + "Display LINE to PORT followed by a newline character." + (display line port) + (newline port)) + +(define (string-blank? str) + "Return non-#f if STR contains only whitespace characters, else +return #t." + (string-every char-set:whitespace str)) + +(define (source-in-context file line-number column-number) + "Return source from FILE at LINE-NUMBER, COLUMN-NUMBER in context +with S-expression at LINE-NUMBER, COLUMN-NUMBER highlit in +red. LINE-NUMBER and COLUMN-NUMBER are zero-based." + (call-with-output-string + (lambda (out) + (call-with-input-file file + (lambda (in) + ;; Get to line preceding syntax x. + (repeat (cut get-line in) + (max 0 (1- line-number))) + ;; Display line preceding syntax x unless blank. + (let ((line (get-line in))) + (unless (or (zero? line-number) + (string-blank? line)) + (put-line line out))) + ;; Display part of line before syntax x. + (display (get-string-n in column-number) + out) + ;; Display syntax x in red. Color each line separately to + ;; help line oriented functions like + ;; `display-with-line-numbers'. + (display (string-join (map (compose bold red) + (string-split (read-sexp-string in) + #\newline)) + "\n") + out) + ;; (display (bold (red (read-sexp-string in))) + ;; out) + ;; Display part of line after syntax x. + (put-line (get-line in) out) + ;; Display line following syntax x unless blank. + (let ((line (get-line in))) + (unless (or (eof-object? line) + (string-blank? line)) + (put-line line out)))))))) + +(define (report-ccwl-violation exception) + (let ((file (ccwl-violation-file exception)) + (line (ccwl-violation-line exception)) + (column (ccwl-violation-column exception))) + (display (bold (format "~a:~a:~a: " file (1+ line) column)) + (current-error-port)) + (display (bold (red "error:")) + (current-error-port)) + (display " " (current-error-port)) + (display (apply format + (formatted-message-format exception) + (map (compose bold magenta) + (formatted-message-arguments exception))) + (current-error-port)) + (newline (current-error-port)) + (display-with-line-numbers (source-in-context file line column) + (current-error-port) + (max 1 line)))) diff --git a/scripts/ccwl b/scripts/ccwl index 63a929a..1215486 100755 --- a/scripts/ccwl +++ b/scripts/ccwl @@ -24,12 +24,15 @@ ;;; Code: -(use-modules (srfi srfi-28) +(use-modules (rnrs exceptions) + (srfi srfi-28) (srfi srfi-37) (ice-9 match) (ccwl ccwl) + (ccwl conditions) (ccwl cwl) - (ccwl graphviz)) + (ccwl graphviz) + (ccwl ui)) (define (invalid-option opt name arg result) (error "Invalid option" name)) @@ -84,8 +87,14 @@ Compile SOURCE-FILE. ((cond ((string=? to "cwl") workflow->cwl) ((string=? to "dot") workflow->dot)) - (load (canonicalize-path (assq-ref args 'source-file)) - read-syntax) + (guard (exception + ;; Handle syntax violation exceptions by reporting + ;; them and exiting. + ((ccwl-violation? exception) + (report-ccwl-violation exception) + (exit #f))) + (load (canonicalize-path (assq-ref args 'source-file)) + read-syntax)) (current-output-port))))) ((program args ...) (let ((args (args-fold args |