Normalize errors.

11 files changed, 58 insertions, 26 deletions

diff --git a/module/c/cpp.scm b/module/c/cpp.scm
index 8710fdd2..3f50fb87 100644
--- a/module/c/cpp.scm
+++ b/module/c/cpp.scm
@@ -5,7 +5,6 @@
   :use-module (ice-9 match)
   :use-module (ice-9 regex)
   :use-module ((rnrs io ports) :select (call-with-port))
-  :use-module (ice-9 pretty-print) ; used by one error handler
   :use-module (ice-9 format)
   :use-module ((hnh util io) :select (read-lines))
   :use-module (hnh util graph)
@@ -26,7 +25,10 @@
   (aif (regexp-exec define-re header-line)
     (cons (match:substring it 1)
           (match:substring it 4))
-    (error "Line dosen't match" header-line)))
+    (scm-error 'c-parse-error
+               "tokenize-define-line"
+               "Line dosen't match: ~s"
+               (list header-line) #f)))
 
 
 (define-public (do-funcall function arguments)
@@ -100,7 +102,7 @@
   (map (lambda (line)
          (catch #t
            (lambda () (parse-cpp-define line))
-           (lambda (err caller fmt args . _)
+           (lambda (err caller fmt args data)
              (format #t "~a ~?~%" fmt args)
              #f)))
        lines))
diff --git a/module/c/parse.scm b/module/c/parse.scm
index 3e3d8024..8030da77 100644
--- a/module/c/parse.scm
+++ b/module/c/parse.scm
@@ -34,7 +34,9 @@
          [(LL) '(long-long)]
          [(L) '(long)]
          [(U) '(unsigned)])
-       (error "Invalid integer suffix")))
+       (scm-error 'c-parse-error "parse-integer-suffix"
+                  "Invalid integer suffix ~s"
+                  (list str) #f)))
 
 (define (parse-lexeme-tree tree)
   (match tree
@@ -113,11 +115,11 @@
      `(funcall ,(parse-lexeme-tree function)
                ,(parse-lexeme-tree arguments))]
 
-    [bare (throw 'parse-error
-                 'parse-lexeme-tree
-                 "Naked literal in lex-tree. How did that get there?"
-                 '()
-                 bare)]))
+    [bare (scm-error 'c-parse-error
+                     "parse-lexeme-tree"
+                     "Naked literal in lex-tree: ~s"
+                     (list bare)
+                     #f)]))
 
 ;; https://en.wikipedia.org/wiki/Operators_in_C_and_C%2B%2B
 
@@ -175,7 +177,11 @@
            (parse-lexeme-tree op)
            (mark-other (parse-lexeme-tree right)))]
 
-    [other (error "Not an infix tree ~a" other)]))
+    [other (scm-error 'c-parse-error
+                      "flatten-infix"
+                      "Not an infix tree ~a"
+                      (list other)
+                      #f)]))
 
 
 
diff --git a/module/calp/entry-points/convert.scm b/module/calp/entry-points/convert.scm
index 3f602b07..1ce33d9c 100644
--- a/module/calp/entry-points/convert.scm
+++ b/module/calp/entry-points/convert.scm
@@ -68,7 +68,7 @@
          (@ (vcomponent formats xcal parse) sxcal->vcomponent)
          ;; TODO strip *TOP*
          xml->sxml)]
-       [else (error "")]
+       [else (scm-error 'misc-error "convert-main" "Unexpected parser type: ~a" (list from) #f)]
        ))
 
    (define writer
@@ -85,7 +85,7 @@
           (sxml->xml ((@ (vcomponent formats xcal output) vcomponent->sxcal)
                       component)
                      port))]
-       [else (error "")]))
+       [else (scm-error 'misc-error "convert-main" "Unexpected writer type: ~a" (list to) #f)]))
 
 
    (call-with-output-file outfile
diff --git a/module/calp/entry-points/html.scm b/module/calp/entry-points/html.scm
index 61489a85..37b0285b 100644
--- a/module/calp/entry-points/html.scm
+++ b/module/calp/entry-points/html.scm
@@ -173,7 +173,7 @@
              pre-start: (start-of-week start)
              post-end: (end-of-week (end-of-month start)))]
     [else
-     (error "Unknown html style: ~a" style)])
+     (scm-error 'misc-error "html-main" "Unknown html style: ~a" (list style) #f)])
 
   ((@ (calp util time) report-time!) "all done")
   )
diff --git a/module/calp/html/components.scm b/module/calp/html/components.scm
index 2f8c85ec..37d50697 100644
--- a/module/calp/html/components.scm
+++ b/module/calp/html/components.scm
@@ -57,7 +57,10 @@
               allow-other-keys:
               rest: args)
   (when (and onclick href)
-    (error "Only give one of onclick, href and submit."))
+    (scm-error 'wrong-type-arg "btn"
+               "href, onclick, and submit mutually exclusive. href = ~s, onclick = ~s, submit = ~s."
+               (list href onclick submit)
+               #f))
 
   (let ((body #f))
     `(,(cond [href 'a]
diff --git a/module/calp/html/util.scm b/module/calp/html/util.scm
index 75137d4e..54c92e92 100644
--- a/module/calp/html/util.scm
+++ b/module/calp/html/util.scm
@@ -17,6 +17,7 @@
 ;; Returns a color with good contrast to the given background color.
 ;; https://stackoverflow.com/questions/1855884/determine-font-color-based-on-background-color/1855903#1855903
 (define-public (calculate-fg-color c)
+  ;; TODO what errors can actually appear here?
   (catch #t
     (lambda ()
       (define (str->num c n) (string->number (substring/shared c n (+ n 2)) 16))
diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm
index 670ad9b6..5a8e977e 100644
--- a/module/calp/html/view/calendar.scm
+++ b/module/calp/html/view/calendar.scm
@@ -74,10 +74,10 @@
              ,display)))
 
   (unless next-start
-    (error 'html-generate "Next-start needs to be a procedure"))
+    (scm-error 'misc-error "html-generate" "Next-start needs to be a procedure" #f #f))
 
   (unless prev-start
-    (error 'html-generate "Prev-start needs to be a procedure"))
+    (scm-error 'misc-error "html-generate" "Prev-start needs to be a procedure" #f #f))
 
   (xhtml-doc
    (@ (lang sv))
diff --git a/module/calp/main.scm b/module/calp/main.scm
index 18b8b731..607b9f1b 100644
--- a/module/calp/main.scm
+++ b/module/calp/main.scm
@@ -120,8 +120,11 @@
     (cond [altconfig
            (if (file-exists? altconfig)
                altconfig
-               (throw 'option-error
-                      "Configuration file ~a missing" altconfig))]
+               (scm-error 'misc-error
+                          "wrapped-main"
+                          "Configuration file ~a missing"
+                          (list altconfig)
+                          #f))]
          ;; altconfig could be placed in the list below. But I want to raise an error
          ;; if an explicitly given config is missing.
          [(find file-exists?
@@ -213,7 +216,10 @@
   (when (option-ref opts 'update-zoneinfo #f)
     (let* ((locations (list "/usr/libexec/calp/tzget" (path-append (xdg-data-home) "tzget")))
            (filename (or (find file-exists? locations)
-                         (error "tzget not installed, please put it in one of ~a" locations)))
+                         (scm-error 'missing-helper "wrapped-main"
+                                    "tzget not installed, please put it in one of ~a"
+                                    (list locations)
+                                    (list "tzget" locations))))
            (pipe (open-input-pipe filename)))
 
       ;; (define path (read-line pipe))
diff --git a/module/calp/repl.scm b/module/calp/repl.scm
index e25c2649..47c35a40 100644
--- a/module/calp/repl.scm
+++ b/module/calp/repl.scm
@@ -21,8 +21,9 @@
                [else 'UNIX])
      [(UNIX)
       (add-hook! shutdown-hook (lambda () (catch 'system-error (lambda () (delete-file address))
-                                       (lambda (err proc fmt . args)
-                                         (warning "Failed to unlink ~a" address args)
+                                       (lambda (err proc fmt args data)
+                                         (warning (format #f "Failed to unlink ~a: ~?"
+                                                          address fmt args))
                                          err))))
       (make-unix-domain-server-socket path: address)]
      [(IPv4) (apply (case-lambda
diff --git a/module/calp/util/config.scm b/module/calp/util/config.scm
index e1417d86..4862bbda 100644
--- a/module/calp/util/config.scm
+++ b/module/calp/util/config.scm
@@ -39,7 +39,11 @@
   (for (key value) in (group kwargs 2)
        (aif (hashq-ref config-properties key)
             (set! (it name) value)
-            (error "Missing config protperty slot " key)))
+            (scm-error 'configuration-error
+                       "define-config"
+                       "No configuration slot named ~s, when defining ~s"
+                       (list key name)
+                       #f)))
   (set-config! name (get-config name default-value)))
 
 (define-syntax define-config
@@ -52,7 +56,12 @@
 (define-public (set-config! name value)
   (hashq-set! config-values name
               (aif (pre name)
-                   (or (it value) (error "Pre crashed for" name))
+                   (or (it value)
+                       (scm-error 'configuration-error
+                                  "set-config!"
+                                  "Pre-property failed when setting ~s to ~s"
+                                  (list name value)
+                                  #f))
                    value))
 
   (awhen (post name) (it value)))
@@ -63,8 +72,10 @@
   (if (eq? default %uniq)
       (let ((v (hashq-ref config-values key %uniq)))
         (when (eq? v %uniq)
-          ;; TODO throw descript error
-          (error "Missing config" key))
+          (scm-error 'configuration-error
+                     "get-config"
+                     "No configuration item named ~s"
+                     (list key) #f))
         v)
       (hashq-ref config-values key default)))
 
diff --git a/module/crypto.scm b/module/crypto.scm
index 79eaaf89..477014e9 100644
--- a/module/crypto.scm
+++ b/module/crypto.scm
@@ -22,7 +22,9 @@
   (define bv
     (cond ((bytevector? msg) msg)
           ((string? msg) (string->utf8 msg))
-          (else (throw 'value-error "Invalid type"))))
+          (else (scm-error 'wrong-type-arg "sha256"
+                           "Wrong type argument. Expected string or bytevector, got ~s"
+                           (list msg) (list msg)))))
   (SHA256 ((@ (system foreign) bytevector->pointer) bv)
           (bytevector-length bv)
           ((@ (system foreign) bytevector->pointer) md))