ui: Improve option processing and help output.

* haunt/ui.scm (%common-options, %default-common-options): New
  variables.
  (simple-args-fols, show-common-options-help, leave, string->number*,
  load-config): New procedures.
  (haunt-error): Remove.
  (show-version-and-exit): Actually exit.  Add 'name' argument.
  (haunt-main): Use new 'show-version-and-exit'.
* haunt/ui/serve.scm (show-server-help): Remove.
  (show-help): New procedure.
  (%options, %default-options): New variables.
  (haunt-serve): Use SRFI-37 option processing.

1 files changed, 56 insertions, 14 deletions

diff --git a/haunt/ui.scm b/haunt/ui.scm
index 910adf9..e53adb8 100644
--- a/haunt/ui.scm
+++ b/haunt/ui.scm
@@ -26,24 +26,28 @@
   #:use-module (ice-9 format)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-37)
   #:use-module (haunt config)
+  #:use-module (haunt site)
   #:export (program-name
-            haunt-error
             show-version-and-exit
+            simple-args-fold
+            %common-options
+            %default-common-options
+            show-common-options-help
+            leave
+            string->number*
+            load-config
             option?
             haunt-main))
 
 (define commands
-  '(serve))
+  '("serve"))
 
 (define program-name (make-parameter 'haunt))
 
-(define (haunt-error str . args)
-  (format (current-error-port) "~a: " (program-name))
-  (apply format (current-error-port) str args)
-  (newline))
-
 (define (show-haunt-help)
   (format #t "Usage: haunt COMMAND ARGS...
 Run COMMAND with ARGS.~%~%")
@@ -54,20 +58,58 @@ Run COMMAND with ARGS.~%~%")
   (format #t "Try `haunt --help' for more information.~%")
   (exit 1))
 
-(define (show-version-and-exit)
-  (let ((name (if (eq? (program-name) 'haunt)
-                  "haunt"
-                  (format #f "haunt ~a" (program-name)))))
-    (format #t "~a ~a
+(define (show-version-and-exit name)
+  (format #t "~a ~a
 Copyright (C) 2015 the Haunt authors
 License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
 This is free software: you are free to change and redistribute it.
 There is NO WARRANTY, to the extent permitted by law.~%"
-            name %haunt-version)))
+          name %haunt-version)
+  (exit 0))
+
+(define (leave format-string . args)
+  "Display error message and exist."
+  (apply format (current-error-port) format-string args)
+  (newline)
+  (exit 1))
+
+(define (string->number* str)
+  "Like `string->number', but error out with an error message on failure."
+  (or (string->number str)
+      (leave "~a: invalid number" str)))
+
+(define (simple-args-fold args options default-options)
+  (args-fold args options
+             (lambda (opt name arg result)
+               (leave "~A: unrecognized option" name))
+             (lambda (arg result)
+               (leave "~A: extraneuous argument" arg))
+             default-options))
+
+(define %common-options
+  (list (option '(#\c "config") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'config arg result)))))
+
+(define %default-common-options
+  '((config . "haunt.scm")))
+
+(define (show-common-options-help)
+  (display "
+  -c, --config           configuration file to load"))
 
 (define (option? str)
   (string-prefix? "-" str))
 
+(define* (load-config file-name)
+  "Load configuration from FILE-NAME."
+  (if (file-exists? file-name)
+      (let ((obj (load file-name)))
+        (if (site? obj)
+            obj
+            (leave "configuration object must be a site, got: ~a" obj)))
+      (leave "configuration file found: ~a" file-name)))
+
 (define (run-haunt-command command . args)
   (let* ((module
           (catch 'misc-error
@@ -87,7 +129,7 @@ There is NO WARRANTY, to the extent permitted by law.~%"
     ((or ("-h") ("--help"))
      (show-haunt-help))
     (("--version")
-     (show-version-and-exit))
+     (show-version-and-exit "haunt"))
     (((? option? opt) _ ...)
      (format (current-error-port)
              "haunt: unrecognized option '~a'~%"