From e8e3f701c5625b157b96916281512a1102355a94 Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Sun, 15 Jun 2014 23:49:26 +0900
Subject: [PATCH] Supporting scribble extraction.

---
 lib/chibi/snow/commands.scm | 30 ++++++++++++++++++++++++------
 lib/chibi/snow/commands.sld |  1 +
 tools/snow-chibi            |  1 +
 3 files changed, 26 insertions(+), 6 deletions(-)

diff --git a/lib/chibi/snow/commands.scm b/lib/chibi/snow/commands.scm
index 00d87515..c12f3038 100644
--- a/lib/chibi/snow/commands.scm
+++ b/lib/chibi/snow/commands.scm
@@ -275,9 +275,21 @@
               (dep-file (make-path dir (library-name->path dep))))
          (and (file-exists? dep-file) dep-file))))
 
-(define (package-doc cfg)
-  ;; TODO: Add scribble extraction.
-  (conf-get cfg '(command package doc)))
+(define (package-docs cfg spec libs)
+  (cond
+   ((conf-get cfg '(command package doc)) => list)
+   ((conf-get cfg '(command package doc-from-scribble))
+    (map
+     (lambda (lib)
+       (let* ((lib+files (extract-library cfg lib))
+              (lib-name (library-name (car lib+files))))
+         `(inline
+           ,(string-append (library-name->path lib-name) ".html")
+           ,(call-with-output-string
+              (lambda (out)
+                (print-module-docs lib-name out sxml-display-as-html))))))
+     libs))
+   (else '())))
 
 (define (package-test cfg)
   (conf-get cfg '(command package test)))
@@ -300,16 +312,22 @@
 
 (define (package-spec+files cfg spec libs)
   (let ((recursive? (conf-get cfg '(command package recursive?)))
-        (doc (package-doc cfg))
+        (docs (package-docs cfg spec libs))
         (test (package-test cfg))
         (version (package-output-version cfg)))
     (let lp ((ls (map (lambda (x) (cons x #f)) libs))
              (res
-              `(,@(if doc `((doc ,(path-strip-leading-parents doc))) '())
+              `(,@(if (pair? docs)
+                      `((doc ,@(map
+                                (lambda (x)
+                                  (path-strip-leading-parents
+                                   (if (pair? x) (cadr x) x)))
+                                docs)))
+                      '())
                 ,@(if test `((test ,(path-strip-leading-parents test))) '())
                 ,@(if version `((version ,version)) '())))
              (files
-              `(,@(if doc (list doc) '())
+              `(,@docs
                 ,@(if test (list test) '()))))
       (cond
        ((and (null? ls) (null? res))
diff --git a/lib/chibi/snow/commands.sld b/lib/chibi/snow/commands.sld
index a7c97520..7037b3d1 100644
--- a/lib/chibi/snow/commands.sld
+++ b/lib/chibi/snow/commands.sld
@@ -32,6 +32,7 @@
           (chibi crypto md5)
           (chibi crypto rsa)
           (chibi crypto sha2)
+          (chibi doc)
           (chibi filesystem)
           (chibi io)
           (chibi match)
diff --git a/tools/snow-chibi b/tools/snow-chibi
index 4b63db04..8183f100 100755
--- a/tools/snow-chibi
+++ b/tools/snow-chibi
@@ -124,6 +124,7 @@
     (version string)
     (version-file existing-filename)
     (doc existing-filename)
+    (doc-from-scribble boolean)
     (test existing-filename)
     (sig-file existing-filename)
     ))