Changeset 18744 in project

Timestamp:

07/07/10 22:28:55 (11 years ago)

Author:

azul

Message:

Lots of updates.

Location:

release/3/svnwiki-scheme-library/trunk

Files:

• svnwiki-scheme-library.meta (modified) (1 diff)
• svnwiki-scheme-library.scm (modified) (7 diffs)

release/3/svnwiki-scheme-library/trunk/svnwiki-scheme-library.meta

@@ -6 +6 @@
  (synopsis "Support for generating Scheme library in wiki pages.")
  (category web)
- (needs svnwiki-extensions srfi-40 html-stream stream-ext embedded-test stream-wiki hostinfo format-modular)
+ (needs svnwiki-extensions srfi-40 html-stream stream-ext embedded-test stream-wiki hostinfo format-modular syntax-case simple-logging)
  (license "GPL-3"))

release/3/svnwiki-scheme-library/trunk/svnwiki-scheme-library.scm

@@ -3 +3 @@
 ; License: GPL-3
 
-(use syntax-case)
+(use syntax-case simple-logging svnwiki-extensions-support posix srfi-40 html-stream stream-ext embedded-test stream-wiki hostinfo format-modular)
 
 (define-syntax stream-if
@@ -9 +9 @@
     ((_ condition body) (if condition body stream-null))))
 
-(use svnwiki-extensions-support posix srfi-40 html-stream stream-ext embedded-test stream-wiki hostinfo format-modular)
-
 (define (html-prop name value)
-  (stream-if name
-    (html-prop-param
-      "; " name " : " value)))
+  (call-with-logging 'debug
+    (lambda ()
+      (stream-if value
+        (html-stream "; " name " : " value "\n")))
+    "Output HTML prop: ~A: ~A~%" name value))
 
 (define (html-prop-param name symbol params)
@@ -43 +43 @@
       (with-output-to-string
         (lambda ()
-          (let ((name (cdr (assoc 'name params))))
-            (output-autogenerated-header)
-            (format #t "(define *has-exports* (string>=? (chicken-version) \"2.310\"))~%~%")
+          (let ((name (stream->string (cdr (assoc 'name params))))
+                (require-at-runtime (assoc 'requireatruntime params)))
+            (output-autogenerated-header env)
+            (format #t "(define *has-exports*~%")
+            (format #t "  (and (string>=? (chicken-version) \"2.310\")~%")
+            (format #t "       (string<=? (chicken-version) \"4\")))~%~%")
+            (format #t "(define (dynld-name fn) (make-pathname #f fn ##sys#load-dynamic-extension))~%~%")
+            (call-with-logging 'debug
+              (lambda ()
+                (for-each
+                  (lambda (file)
+                    (format #t "(compile -O2 -d1 -c~%")
+                    (format #t "  ,@(if *has-exports* '(-check-imports -emit-exports ~A.exports) '())" file)
+                    (format #t "  ~A.scm -unit ~A)~%" file file)
+                    (format #t "(compile -O2 -d1 -s~%")
+                    (format #t "  ,@(if *has-exports* '(-check-imports -emit-exports ~A.exports) '())" file)
+                    (format #t "  ~A.scm -j ~A)~%" file file)
+                    (format #t "(compile -O2 -d0 -s~%")
+                    (format #t "  ,@(if *has-exports* '(-check-imports -emit-exports ~A.exports) '())" file)
+                    (format #t "  ~A.import.scm)~%" file file))
+                  (get-list-of-runtime-files env)))
+              "Generating compile statements.")
             (newline)
-            (format #t "(define (dynld-name fn) (make-pathname #f fn ##sys#load-dynamic-extension))~%~%")
-            (newline)
-            (for-each
-              (lambda (file)
-                (format #t "(compile -O2 -d0 -s~%")
-                (format #t "  ,@(if *has-exports* '(-check-imports -emit-exports ~A.exports) '())" file)
-                (format #t "  ~A.scm)" file))
-              (get-list-of-runtime-files env))
-            (format #t "(install-extension ~A~%" name)
+            (format #t "(install-extension '~A~%" name)
             (format #t "  ; Files to install:~%")
-            (format #t "  `(,@(if has-exports? '(\"~A.exports\") (list))~{~%  ,(dynld-name ~S)~})~%"
-                    name (get-list-of-runtime-files env))
+            (format #t "  `(,@(if *has-exports* '(\"~A.exports\") (list))~%    ,(dynld-name \"~A.import\")~{~%    ,(dynld-name ~S)~})~%"
+                    name name (get-list-of-runtime-files env))
             (format #t "  ; Extension properties:~%")
             (format #t "  `(")
-            ; TODO: Support syntax extensions
             (format #t "(documentation \"~A.html\")~%" name)
-            (format #t "  (version ,(if (file-exists? \"version\") (with-input-from-file \"version\" read) \"unknown\")))")))))))
+            (when require-at-runtime
+              (format #t "    (require-at-runtime ~A)~%" (stream->string (cdr require-at-runtime))))
+            (format #t "    (version ,(if (file-exists? \"version\") (with-input-from-file \"version\" read) \"unknown\"))))~%")))))))
 
 (test-group parse-list-of-tokens
@@ -82 +94 @@
            (stream-split str char-whitespace?)))))
 
+(test-group get-list-of-runtime-files
+  (test (get-list-of-runtime-files (environment ((params `((name . ,(string->stream "foo")))))))
+        '("foo")))
+
 (define (get-list-of-runtime-files env)
   (let-from-environment env (params)
-    (let ((runtime-files (assoc 'runtime-files params)))
-      (if runtime-files
-        (parse-list-of-tokens (cdr runtime-files))
-        (list (cdr (assoc 'name params)))))))
+    (call-with-logging 'debug
+      (lambda ()
+        (let ((runtime-files (assoc 'runtimefiles params)))
+          (if runtime-files
+            (parse-list-of-tokens (cdr runtime-files))
+            (list (stream->string (cdr (assoc 'name params)))))))
+      "get-list-of-runtime-files: ~A"
+      params)))
 
 (define (output-meta-prop symbol params)
-  (and-let* ((value (assoc symbol params)))
-    (format #t " (~A \"~A\")~%" symbol (stream->string (cdr value)))))
+  (call-with-logging 'debug
+    (lambda ()
+      (and-let* ((value (assoc symbol params))
+                 (value-drop (stream-drop-while char-whitespace? (cdr value)))
+                 ((positive? (stream-length value-drop))))
+        (format #t " (~A \"~A\")~%" symbol (stream->string value-drop))))
+    "output-meta-prop: ~A: ~A"
+    symbol
+    params))
 
 (define (generate-meta-contents env)
@@ -98 +125 @@
       (with-output-to-string
         (lambda ()
-          (let ((name (cdr (assoc 'name params)))
-                (author (assoc 'author params))
-                (synosys (assoc 'synosys params)))
+          (let ((name (stream->string (cdr (assoc 'name params)))))
             (output-autogenerated-header env)
             (format #t "(")
-            (format #t "(files \"~A.setup\" \"~A.html\" ~{\"~A.scm\"~})~%" name (get-list-of-runtime-files env))
+            (format #t "(files \"~A.setup\" \"~A.html\"~{ \"~A.scm\"~})~%" name name (get-list-of-runtime-files env))
             (output-meta-prop 'author params)
             (output-meta-prop 'synopsis params)
             (output-meta-prop 'category params)
+            (and-let* ((value (assoc 'uses params))
+                       (actual (stream-drop-while char-whitespace? (cdr value)))
+                       ((not (stream-null? actual))))
+              (format #t " (needs ~A)~%" (stream->string actual)))
             (output-meta-prop 'license params)
             (format #t " (egg \"~A.egg\"))~%" name)))))))
@@ -124 +153 @@
 
 (define (generate-header env)
-  (with-output-to-string (lambda () (output-autogenerated-header env))))
+  (call-with-logging 'debug
+    (lambda ()
+      (with-output-to-stream
+        (lambda ()
+          (output-autogenerated-header env)
+          (let-from-environment env (params)
+            (let ((data-exports (assoc 'exports params))
+                  (name (assoc 'name params))
+                  (data-uses (assoc 'uses params)))
+              (format #t "(module ~A ~A~%~%"
+                      (stream->string (cdr name))
+                      (if data-exports
+                        (format #f "(~{~A~^ ~})" (parse-list-of-tokens (cdr data-exports)))
+                        "*")))))))
+    "generate-header"))
+
+(define (generate-test-contents env)
+  (with-output-to-stream
+    (lambda ()
+      (output-autogenerated-header env)
+      (format #t "(setenv \"TESTS\" \"yes\")~%")
+      (format #t "(setenv \"TESTS_VERBOSE\" \"yes\")~%")
+      (format #t "(use ~A)~%" (cdr (assoc 'name params)))
+      (format #t "(run-tests)~%"))))
 
 (define (scheme-library-definition env)
   (let-from-environment env (output-format parse return params)
-    (format (current-error-port) "scheme-library-definition: ~A~%" params)
-    (let ((name (assoc 'name params)))
+    (logging 'info "Scheme-library-definition start: ~A" output-format)
+    (let ((name (assoc 'name params))
+          (uses (assoc 'uses params)))
       (cond
         ((not name)
+         (logging 'info "Call to scheme-library-definition with no name parameter.")
          (html-stream "[scheme-library error: name parameter missing"))
         ((eq? output-format 'enscript)
-         (return
-           (list (cdr name)
-                 "application/x-scheme-chicken-meta"
-                 (generate-meta-contents env)))
-         (return
-           (list (cdr name)
-                 "text/html"
-                 (generate-html-contents env)))
-         (return
-           (list (cdr name)
-                 "application/x-scheme-chicken-setup"
-                 (generate-setup-contents env)))
-         (for-each
-           (lambda (file)
-             (return file "application/x-scheme" (generate-header env)))
-           (get-list-of-runtime-files env)))
+         (call-with-logging 'debug
+           (lambda ()
+             (return
+               (cdr name)
+               "application/x-scheme-chicken-meta"
+               (call-with-logging 'debug
+                 (lambda () (generate-meta-contents env))
+                 "Generate meta contents"))
+             (return
+               (cdr name)
+               "text/html"
+               (call-with-logging 'debug
+                 (lambda () (generate-html-contents env))
+                 "Generate HTML contents"))
+             (return
+               (cdr name)
+               "application/x-scheme-chicken-setup"
+               (call-with-logging 'debug
+                 (lambda () (generate-setup-contents env))
+                 "Generate setup contents"))
+             (when (and uses (member "embedded-test" (parse-list-of-tokens (cdr uses))))
+               (return
+                 (format #f "tests-~A/run" (cdr name))
+                 "application/x-scheme"
+                 (call-with-logging 'debug
+                   (lambda () (generate-test-contents env))
+                   "Generate env contents")))
+             (for-each
+               (lambda (file)
+                 (return file "application/x-scheme" (generate-header env)))
+               (get-list-of-runtime-files env))
+             stream-null)
+           "Auto generating files for Scheme Library."))
         (else
           (parse
@@ -156 +227 @@
               (html-prop "Author"
                 (let ((author (assoc 'author params))
-                      (author-email (assoc 'author-email params)))
+                      (author-email (assoc 'authoremail params)))
                   (and author
-                       (stream-concatenate
+                       (stream-append
                          (cdr author)
-                         (stream-if author-email (html-stream "<" author-email ">"))))))
+                         (stream-if author-email
+                           (html-stream " <" (cdr author-email) ">"))))))
               (html-prop-param "Category" 'category params)
               (html-prop-param "Synopsis" 'synospis params)