Remove (@ (global) basedir).

3 files changed, 24 insertions, 22 deletions

diff --git a/module/calp/entry-points/html.scm b/module/calp/entry-points/html.scm
index 7f7dc8a5..4f672109 100644
--- a/module/calp/entry-points/html.scm
+++ b/module/calp/entry-points/html.scm
@@ -19,6 +19,7 @@
 
   :use-module ((sxml simple) :select (sxml->xml))
   :use-module ((sxml transformations) :select (href-transformer))
+  :use-module (directories)
 
   :autoload (vcomponent instance) (global-event-object)
   )
@@ -36,6 +37,9 @@
                         "Defaults to 12 to give a whole year when --style=" (b "month") "."
                         ))
 
+    (target (single-char #\t) (value #t)
+            (description "Directory where html files should end up. Default to " (b "./html")))
+
     (style (value #t) (predicate ,(lambda (v) (memv (string->symbol v)
                                             '(wide week table))))
            (description "How the body of the HTML page should be layed out. "
@@ -55,20 +59,18 @@
 
 
 ;; file existing but is of wrong type,
-(define (create-files)
-  (let* ((dir (dirname (or (@ (global) basedir) ".")))
-         (html (string-append dir "/html"))
-         (link (string-append html "/static")))
-    (unless (file-exists? html)
-      (mkdir html))
-    (unless (file-exists? link)
-      (symlink "../static" link))))
+(define (create-files output-directory)
+
+  (let* ((link (path-append output-directory "/static")))
 
+    (unless (file-exists? output-directory)
+      (mkdir output-directory))
+
+    ;; TODO nicer way to resolve static
+    (let ((link (path-append output-directory "/static")))
+     (unless (file-exists? link)
+       (symlink (path-append data-directory "www/static") link)))))
 
-(define (get-filename start-date)
-  (format #f "~a/html/~a.xml"
-          (dirname (or (@ (global) basedir) "."))
-          (date->string start-date "~1")))
 
 (define (re-root-static tree)
   (href-transformer
@@ -78,7 +80,7 @@
           (regexp-substitute #f it 'pre "static" 'post)
           str))))
 
-(define (common count start-date chunk-length
+(define (common target-directory count start-date chunk-length
                 render-calendar . extra-args)
 
   (define calendars (get-calendars global-event-object))
@@ -86,11 +88,11 @@
 
   ((@ (util time) report-time!) "html start")
 
-  (create-files)
+  (create-files target-directory)
 
   (stream-for-each
    (lambda (start-date)
-     (define fname (get-filename start-date))
+     (define fname (path-append target-directory (date->string start-date "~1.xml")))
      (format (current-error-port) "Writing to [~a]~%" fname)
      (with-output-to-file fname
        (lambda () (sxml->xml (re-root-static
@@ -117,6 +119,8 @@
 
   (define style (string->symbol (option-ref opts 'style "wide")))
 
+  (define target-directory (option-ref opts 'target "./html"))
+
   (when (option-ref opts 'help #f)
     (print-arg-help opt-spec)
     (throw 'return)
@@ -127,19 +131,20 @@
 
   (case style
     [(wide)
-     (common count start (date month: 1) render-calendar-wide)]
+     (common target-directory count start (date month: 1) render-calendar-wide)]
 
     [(week)
 
      ;; TODO The small calendar is always centered on months, it might
      ;; be a good idea to instead center it on the current week, meaning
      ;; that the active row is always in the center
-     (common count (start-of-week start)
+     (common target-directory count (start-of-week start)
              (date day: 7)
              render-calendar-wide)]
     [(table)
 
-     (common count (start-of-month start) (date month: 1)
+     (common target-directory
+             count (start-of-month start) (date month: 1)
              render-calendar-table
              pre-start: (start-of-week start)
              post-end: (end-of-week (end-of-month start)))]
diff --git a/module/directories.scm b/module/directories.scm
index 7348f6c3..fe86bdf6 100644
--- a/module/directories.scm
+++ b/module/directories.scm
@@ -21,7 +21,7 @@
                (lambda (s) (path-append s "/.config"))))
     "/calp"))
 
-(define (libexec%) 
+(define (libexec%)
   (path-append (get-config 'path-prefix)
                "/lib/calp"))
 
diff --git a/module/global.scm b/module/global.scm
index 89b5511a..a38a5d21 100644
--- a/module/global.scm
+++ b/module/global.scm
@@ -1,8 +1,5 @@
 (define-module (global))
 
-(define-once basedir #f)
-(export basedir)
-
 (define-once *prodid* "-//hugo//Calparse 0.9//EN")
 (export *prodid*)