blob: 7a0d2dd27f1916f79d2dc32ad39643aedafb66f3 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
|
;;; Haunt --- Static site generator for GNU Guile
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;;
;;; This file is part of Haunt.
;;;
;;; Haunt 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.
;;;
;;; Haunt is distributed in the hope that it will be useful, but
;;; WITnnnHOUT 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 Haunt. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; Haunt user interface.
;;
;;; Code:
;; Hack to mark this module as non-declarative on Guile 3+ (which
;; would otherwise print a warning) but not break when compiling on
;; earlier versions of Guile.
(define-syntax-rule (define-module* name args ...)
(cond-expand
(guile-3
(define-module name
#:declarative? #f
args ...))
(guile
(define-module name args ...))))
(define-module* (haunt ui)
#: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)
#:use-module (haunt utils)
#:export (program-name
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
'("build" "publish" "serve"))
(define program-name (make-parameter 'haunt))
(define (show-haunt-help)
(format #t "Usage: haunt COMMAND ARGS...
Run COMMAND with ARGS.~%~%")
(format #t "COMMAND must be one of the sub-commands listed below:~%~%")
(format #t "~{ ~a~%~}" (sort commands string<?)))
(define (show-haunt-usage)
(format #t "Try `haunt --help' for more information.~%")
(exit 1))
(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)
(exit 0))
(define (leave format-string . args)
"Display error message and exit."
(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 (absolute-file-name file-name))))
(if (site? obj)
obj
(leave "configuration object must be a site, got: ~a" obj)))
(leave "configuration file not found: ~a" file-name)))
(define (run-haunt-command command . args)
(let* ((module
(catch 'misc-error
(lambda ()
(resolve-interface `(haunt ui ,command)))
(lambda -
(format (current-error-port) "~a: invalid subcommand~%" command)
(show-haunt-usage))))
(command-main (module-ref module (symbol-append 'haunt- command))))
(parameterize ((program-name command))
(apply command-main args))))
(define* (haunt-main arg0 . args)
;; Add haunt site directory to Guile's load path so that user's can
;; easily import their own modules.
(add-to-load-path (getcwd))
(setlocale LC_ALL "")
(match args
(()
(show-haunt-usage))
((or ("-h") ("--help"))
(show-haunt-help))
((or ("-V") ("--version"))
(show-version-and-exit "haunt"))
(((? option? opt) _ ...)
(format (current-error-port)
"haunt: unrecognized option '~a'~%"
opt)
(show-haunt-usage))
((command args ...)
(apply run-haunt-command (string->symbol command) args))))
|
