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.

2 files changed, 89 insertions, 28 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'~%"
diff --git a/haunt/ui/serve.scm b/haunt/ui/serve.scm
index 078b013..6e58a31 100644
--- a/haunt/ui/serve.scm
+++ b/haunt/ui/serve.scm
@@ -23,29 +23,48 @@
 ;;; Code:
 
 (define-module (haunt ui serve)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
   #:use-module (haunt config)
   #:use-module (haunt ui)
   #:use-module (haunt serve web-server)
   #:export (haunt-serve))
 
-(define (show-serve-help)
+(define (show-help)
   (format #t "Usage: haunt serve [OPTION]
 Start an HTTP server for the current site.~%")
   (display "
+  -p, --port             port to listen on")
+  (newline)
+  (show-common-options-help)
+  (newline)
+  (display "
   -h, --help             display this help and exit")
+  (display "
+  -V, --version          display version and exit")
   (newline))
 
-(define haunt-serve
-  (match-lambda*
-   (() (serve (haunt-output-directory)))
-   ((or ("-h") ("--help"))
-    (show-serve-help))
-   (("--version")
-    (show-version-and-exit))
-   (((? option? opt) _ ...)
-    (haunt-error "invalid option: ~a" opt)
-    (exit 1))
-   ((arg _ ...)
-    (haunt-error "invalid argument: ~a" arg)
-    (exit 1))))
+(define %options
+  (cons* (option '(#\h "help") #f #f
+                 (lambda _
+                   (show-help)
+                   (exit 0)))
+         (option '(#\V "version") #f #f
+                 (lambda _
+                   (show-version-and-exit "haunt serve")))
+         (option '(#\p "port") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'port (string->number* arg) result)))
+         %common-options))
+
+(define %default-options
+  (cons '((port . 8080))
+        %default-common-options))
+
+(define (haunt-serve . args)
+  (let* ((opts (simple-args-fold args %options %default-options))
+         (port (assoc-ref opts 'port)))
+    (format #t "serving ~a on port ~d~%" (haunt-output-directory) port)
+    (serve (haunt-output-directory))))