Localized and neat error reports

examples/9999error.txt

@@ -0,0 +1,1 b''
+error

src/l10n.lisp

@@ -1,19 +1,23 b''
 
 (in-package txt2web)
 
 (defparameter *languages* (list "en" "ru"))
 
 (defparameter *l10n-strings*
   (mapcan (lambda (lang)
             (cons (intern (string-upcase lang) :keyword)
-                  (read-code-from-string
-                   (load-src
-                    (concatenate 'string "strings/" lang ".sexp")))))
+                  (list (apply #'append
+                               (read-code-from-string
+                                (load-src
+                                 (concatenate 'string "strings/" lang ".sexp")))))))
           *languages*))
 
 (defun lformat (target key &rest args)
   (let* ((lang (intern (string-upcase (first (system-locale:languages)))
                       :keyword))
          (strings (or (getf *l10n-strings* lang)
-                      (getf *l10n-strings* :en))))
-    (apply #'format target (getf strings key) args)))
+                      (getf *l10n-strings* :en)))
+         (string (getf strings key)))
+    (if string
+        (apply #'format target string args)
+        (error "Unknown localization string ~S for language ~S" key lang))))

src/main.lisp

@@ -1,153 +1,158 b''
 
 (in-package txt2web)
 
 (defvar *app-name* "")
 
 (defun entry-point-no-args ()
+  (setf *delivered* t)
   (entry-point uiop:*command-line-arguments*))
 
 (defun entry-point (args)
   (setf *app-name* (uiop:argv0))
   (let ((*package* (find-package :txt2web)))
     (catch :terminate
       (let ((compiler (apply #'make-instance 'compiler (parse-opts args))))
         (write-compiled-file compiler))))
   (values))
 
 (defun parse-opts (args)
   (let ((mode :sources)
         (data (list :sources nil :target nil :js nil :css nil :body nil :compile nil :beautify nil)))
     (loop :for arg :in args
        :do (alexandria:switch (arg :test #'string=)
              ("-o" (setf mode :target))
              ("--js" (setf mode :js))
              ("--css" (setf mode :css))
              ("--body" (setf mode :body))
              ("-c" (setf (getf data :compile) t))
              ("--beautify" (setf (getf data :beautify) t))
              (t (push arg (getf data mode)))))
     (unless (< 0 (length (getf data :sources)))
       (report-error "There should be at least one source"))
     (unless (> 1 (length (getf data :target)))
       (report-error "There should be no more than one target"))
     (unless (> 1 (length (getf data :body)))
       (report-error "There should be no more than one body"))
     (unless (getf data :target)
       (setf (getf data :target)
             (let* ((sources (first (getf data :sources)))
                    (tokens (uiop:split-string sources :separator "."))
                    (target (format nil "~{~A~^.~}.html"
                                    (butlast tokens))))
               (list target))))
     (list :sources (getf data :sources)
           :target (first (getf data :target))
           :js (getf data :js)
           :css (getf data :css)
           :body (first (getf data :body))
           :compile (getf data :compile)
           :beautify (getf data :beautify))))
 
 (defun print-usage ()
   (lformat t :usage *app-name*))
 
 (defun parse-file (filename)
-  (p:parse 'txt2web-grammar
-           (alexandria:read-file-into-string filename)))
+  (handler-case
+      (p:parse 'txt2web-grammar
+               (alexandria:read-file-into-string filename))
+    (p:esrap-parse-error (e)
+      (format t "~A~%" e)
+      (uiop:quit 1))))
 
 (defun report-error (fmt &rest args)
   (format t "ERROR: ~A~%" (apply #'format nil fmt args))
   (print-usage)
   (throw :terminate nil))
 
 ;;; JS
 
 (defun minify-package (package-designator minify prefix)
   (setf (ps:ps-package-prefix package-designator) prefix)
   (if minify
       (ps:obfuscate-package package-designator)
       (ps:unobfuscate-package package-designator)))
 
 (defmethod js-sources ((compiler compiler))
   (let ((ps:*ps-print-pretty* (beautify compiler)))
     (cond ((beautify compiler)
            (minify-package "TXT2WEB.MAIN" nil "qsp_")
            (minify-package "TXT2WEB.API"  nil "qsp_api_")
            (minify-package "TXT2WEB.LIB"  nil "qsp_lib_"))
           (t
            (minify-package "TXT2WEB.MAIN" t   "_")
            (minify-package "TXT2WEB.API"  t   "a_")
            (minify-package "TXT2WEB.LIB"  t   "l_")))
     (format nil "~{~A~^~%~%~}" (mapcar #'ps:ps* (reverse (js compiler))))))
 
 ;;; CSS
 
 (defmethod css-sources ((compiler compiler))
   (format nil "~{~A~^~%~%~}" (css compiler)))
 
 ;;; HTML
 
 (defmethod html-sources ((compiler compiler))
   (let ((flute:*escape-html* nil)
         (body-template (body compiler))
         (js (js-sources compiler))
         (css (css-sources compiler)))
     (with-output-to-string (out)
       (write
        (flute:h
          (html
           (head
            (title "txt2web"))
           (body
            body-template
            (style css)
            (script js))))
        :stream out
        :pretty nil))))
 
 (defun filename-game (filename)
   (let ((filename (alexandria:lastcar (uiop:split-string filename :separator "/"))))
     (format nil "~{~A~^.~}" (butlast (uiop:split-string filename :separator ".")))))
 
 (defmethod initialize-instance ((compiler compiler) &key sources ((:js js-files)) ((:css css-files)) ((:body body-file)) compile &allow-other-keys)
   (call-next-method)
   (with-slots (body css js)
       compiler
     ;; Compile the game's JS
     (dolist (source sources)
       (let ((ps (parse-file source))
             (game-name (filename-game source)))
         (destructuring-bind (kw &rest locations)
             ps
           (unless (eq kw 'lib:game)
             (report-error "Internal error!"))
           (push 
            `(lib:game (,game-name) ,@locations)
            js))))
     ;; Does the user need us to do anything else
     (unless compile
       ;; Read in body
       (when body-file
         (setf body
               (alexandria:read-file-into-string body-file)))
       ;; Include js files
       (dolist (js-file js-files)
         (push (format nil "////// Included file ~A~%~A" js-file
                       (alexandria:read-file-into-string js-file))
               js))
       ;; Include css files
       (when css-files
         ;; User option overrides the default css
         (setf css nil)
         (dolist (css-file css-files)
           (push (format nil "////// Included file ~A~%~A" css-file
                         (alexandria:read-file-into-string css-file))
                 css))))))
 
 (defmethod write-compiled-file ((compiler compiler))
   (alexandria:write-string-into-file
    (if (compile-only compiler)
        ;; Just the JS
        (js-sources compiler)
        ;; All of it
        (html-sources compiler))
    (target compiler) :if-exists :supersede))

src/patches.lisp

@@ -1,74 +1,131 b''
 
 (in-package parenscript)
 
 ;;; async/await
 
 (defprinter ps-js::await (x)
   (psw (string-downcase "await "))
   (print-op-argument 'ps-js::await x))
 
 (define-trivial-special-ops await ps-js::await)
 
 (define-statement-operator async-defun (name lambda-list &rest body)
   (multiple-value-bind (effective-args body-block docstring)
       (compile-named-function-body name lambda-list body)
     (list 'ps-js::async-defun name effective-args docstring body-block)))
 
 (defprinter ps-js::async-defun (name args docstring body-block)
   (when docstring (print-comment docstring))
   (psw "async ")
   (print-fun-def name args body-block))
 
 (define-expression-operator async-lambda (lambda-list &rest body)
   (multiple-value-bind (effective-args effective-body)
       (parse-extended-function lambda-list body)
     `(ps-js::async-lambda
       ,effective-args
       ,(let ((*function-block-names* ()))
          (compile-function-body effective-args effective-body)))))
 
 (defprinter ps-js::async-lambda (args body-block)
   (psw "async ")
   (print-fun-def nil args body-block))
 
 (cl:export 'await)
 (cl:export 'async-defun)
 (cl:export 'async-lambda)
 
 ;;; ES6
 
 (define-expression-operator => (lambda-list &rest body)
   (unless (listp lambda-list)
     (setf lambda-list (list lambda-list)))
   (multiple-value-bind (effective-args effective-body)
       (parse-extended-function lambda-list body)
     `(ps-js::=>
       ,effective-args
       ,(let ((*function-block-names* ()))
          (compile-function-body effective-args effective-body)))))
 
 (defprinter ps-js::=> (args body)
   (unless (= 1 (length args))
     (psw "("))
   (loop for (arg . remaining) on args do
        (psw (symbol-to-js-string arg)) (when remaining (psw ", ")))
   (unless (= 1 (length args))
     (psw ")"))
   (psw " => ")
   (ps-print body))
 
 (cl:export '=>)
 
 ;;; Actually return nothing (with no empty return)
 (defvar *old-return-result-of* (function return-result-of))
 
 (defun return-result-of (tag form)
   (if (equal form '(void))
       nil
       (funcall *old-return-result-of* tag form)))
 (cl:export 'void)
 
 ;;; Bitwise stuff
 ;; No idea why these are not exported
 (export '<<)
 (export '>>)
+
+(in-package esrap)
+(defmethod print-object :around ((condition esrap-error) stream)
+  (when (not txt2web::*delivered*)
+    (return-from print-object
+      (call-next-method)))
+  (when (or *print-escape*
+            *print-readably*
+            (and *print-lines* (<= *print-lines* 5)))
+    (return-from print-object))
+
+  ;; FIXME: this looks like it won't do the right thing when used as
+  ;; part of a logical block.
+  (if-let ((text (esrap-error-text condition))
+           (position (esrap-error-position condition)))
+    (labels ((safe-index (index)
+               (min (max index 0) (length text)))
+             (find-newline (&key (start 0) (end (length text)) (from-end t))
+               (let ((start (safe-index start))
+                     (end   (safe-index end)))
+                 (cond
+                   ((when-let ((position (position #\Newline text
+                                                   :start start :end end
+                                                   :from-end from-end)))
+                      (1+ position)))
+                   ((and from-end (zerop start))
+                    start)
+                   ((and (not from-end) (= end (length text)))
+                    end)))))
+      ;; FIXME: magic numbers
+      (let* ((line       (count #\Newline text :end position))
+             (column     (- position (or (find-newline :end position) 0) 1))
+             (min-start  (- position 160))
+             (max-end    (+ position 24))
+             (line-start (or (find-newline :start min-start
+                                           :end   position)
+                             (safe-index min-start)))
+             (start      (cond
+                           ((= (safe-index min-start) line-start)
+                            line-start)
+                           ((find-newline :start min-start
+                                          :end   (1- line-start)))
+                           (t
+
+                            line-start)))
+             (end        (or (find-newline :start    position
+                                           :end      max-end
+                                           :from-end nil)
+                             (safe-index max-end)))
+             (*print-circle* nil))
+        (txt2web::lformat stream :error
+                (= position (length text))
+                (list (subseq text start end))
+                (- position line-start)
+                (1+ line) (1+ column) position)))
+
+    (format stream "~2&<text and position not available>~2%")))

src/utils.lisp

@@ -1,24 +1,26 b''
 
 (in-package txt2web)
 
+(defvar *delivered* nil)
+
 (defun src-file (filename)
   (uiop/pathname:merge-pathnames*
    filename
    (asdf:system-source-directory :txt2web)))
 
 (defun read-progn-from-string (string)
   `(progn
      ,@(read-code-from-string string)))
 
 (defun read-code-from-string (string)
   (with-input-from-string (in string)
     (let ((*package* *package*))
       (loop :for form := (read in nil :eof)
          :until (eq form :eof)
          :when (eq (first form) 'cl:in-package)
          :do (setf *package* (find-package (second form)))
          :else
          :collect form))))
 
 (defun load-src (filename)
   (alexandria:read-file-into-string (src-file filename)))

strings/en.sexp

@@ -1,12 +1,15 b''
 (:usage "Usage: ~A <source> [options]
 Options:
   -o <filename>         - Output filename
   --js <filenames...>   - List of extra .js files to include in the game
   --css <filenames...>  - List of .css files to include in the game. Default is in extras/default.css
   --body <filename>     - Alternative page body. Default is in extras/body.html
 
   -c                    - Just compile the game to a .js file without making it a full web page
   --beautify            - Make the JS content pretty. By default it gets minified.
 
 Note that the files in extras/ are not actually used. They're just there for the reference~%")
 
+(:error "Error at~:[~; end of input~]~2%~
+                        ~2@T~<~@;~A~:>~%~
+                        ~2@T~V@T^ (Line ~D, Column ~D, Position ~D)~2%")
  No newline at end of file

strings/ru.sexp

@@ -1,12 +1,15 b''
 (:usage "Использование: ~A <source> [options]
 Опции:
   -o <имя файла>          - Имя .html файла для записи скомпилированной игры
   --js <имена файлов...>  - Список дополнительных .js файлов
   --css <имена файлов...> - Список .css файлов. Стиль по-умолчанию - в файле extras/default.css
   --body <имя файла>      - Альтернативное тело страницы. Тело по-умолчанию - в файле extras/body.html
 
   -c                      - Просто скомпилировать игру в .js файл, не компонуя полную .html страницу
   --beautify              - Не минифицировать .js скрипты
 
 Файлы в extras на самом деле компилятором не используются. Используйте только как образец.~%")
 
+(:error "Ошибка в~:[~; конце файла~]~2%~
+                        ~2@T~<~@;~A~:>~%~
+                        ~2@T~V@T^ (Строка ~D, Столбец ~D, Символ ~D)~2%")
  No newline at end of file