scripts: Report ccwl syntax violations.

* ccwl/ui.scm: New file.
* scripts/ccwl: Import (rnrs exceptions), (srfi srfi-28), (ccwl
conditions) and (ccwl ui).
(main): Handle ccwl syntax violations by reporting them and exiting.

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