Changeset 18744 in project


Ignore:
Timestamp:
07/07/10 22:28:55 (11 years ago)
Author:
azul
Message:

Lots of updates.

Location:
release/3/svnwiki-scheme-library/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/3/svnwiki-scheme-library/trunk/svnwiki-scheme-library.meta

    r18250 r18744  
    66 (synopsis "Support for generating Scheme library in wiki pages.")
    77 (category web)
    8  (needs svnwiki-extensions srfi-40 html-stream stream-ext embedded-test stream-wiki hostinfo format-modular)
     8 (needs svnwiki-extensions srfi-40 html-stream stream-ext embedded-test stream-wiki hostinfo format-modular syntax-case simple-logging)
    99 (license "GPL-3"))
  • release/3/svnwiki-scheme-library/trunk/svnwiki-scheme-library.scm

    r18250 r18744  
    33; License: GPL-3
    44
    5 (use syntax-case)
     5(use syntax-case simple-logging svnwiki-extensions-support posix srfi-40 html-stream stream-ext embedded-test stream-wiki hostinfo format-modular)
    66
    77(define-syntax stream-if
     
    99    ((_ condition body) (if condition body stream-null))))
    1010
    11 (use svnwiki-extensions-support posix srfi-40 html-stream stream-ext embedded-test stream-wiki hostinfo format-modular)
    12 
    1311(define (html-prop name value)
    14   (stream-if name
    15     (html-prop-param
    16       "; " name " : " value)))
     12  (call-with-logging 'debug
     13    (lambda ()
     14      (stream-if value
     15        (html-stream "; " name " : " value "\n")))
     16    "Output HTML prop: ~A: ~A~%" name value))
    1717
    1818(define (html-prop-param name symbol params)
     
    4343      (with-output-to-string
    4444        (lambda ()
    45           (let ((name (cdr (assoc 'name params))))
    46             (output-autogenerated-header)
    47             (format #t "(define *has-exports* (string>=? (chicken-version) \"2.310\"))~%~%")
     45          (let ((name (stream->string (cdr (assoc 'name params))))
     46                (require-at-runtime (assoc 'requireatruntime params)))
     47            (output-autogenerated-header env)
     48            (format #t "(define *has-exports*~%")
     49            (format #t "  (and (string>=? (chicken-version) \"2.310\")~%")
     50            (format #t "       (string<=? (chicken-version) \"4\")))~%~%")
     51            (format #t "(define (dynld-name fn) (make-pathname #f fn ##sys#load-dynamic-extension))~%~%")
     52            (call-with-logging 'debug
     53              (lambda ()
     54                (for-each
     55                  (lambda (file)
     56                    (format #t "(compile -O2 -d1 -c~%")
     57                    (format #t "  ,@(if *has-exports* '(-check-imports -emit-exports ~A.exports) '())" file)
     58                    (format #t "  ~A.scm -unit ~A)~%" file file)
     59                    (format #t "(compile -O2 -d1 -s~%")
     60                    (format #t "  ,@(if *has-exports* '(-check-imports -emit-exports ~A.exports) '())" file)
     61                    (format #t "  ~A.scm -j ~A)~%" file file)
     62                    (format #t "(compile -O2 -d0 -s~%")
     63                    (format #t "  ,@(if *has-exports* '(-check-imports -emit-exports ~A.exports) '())" file)
     64                    (format #t "  ~A.import.scm)~%" file file))
     65                  (get-list-of-runtime-files env)))
     66              "Generating compile statements.")
    4867            (newline)
    49             (format #t "(define (dynld-name fn) (make-pathname #f fn ##sys#load-dynamic-extension))~%~%")
    50             (newline)
    51             (for-each
    52               (lambda (file)
    53                 (format #t "(compile -O2 -d0 -s~%")
    54                 (format #t "  ,@(if *has-exports* '(-check-imports -emit-exports ~A.exports) '())" file)
    55                 (format #t "  ~A.scm)" file))
    56               (get-list-of-runtime-files env))
    57             (format #t "(install-extension ~A~%" name)
     68            (format #t "(install-extension '~A~%" name)
    5869            (format #t "  ; Files to install:~%")
    59             (format #t "  `(,@(if has-exports? '(\"~A.exports\") (list))~{~%  ,(dynld-name ~S)~})~%"
    60                     name (get-list-of-runtime-files env))
     70            (format #t "  `(,@(if *has-exports* '(\"~A.exports\") (list))~%    ,(dynld-name \"~A.import\")~{~%    ,(dynld-name ~S)~})~%"
     71                    name name (get-list-of-runtime-files env))
    6172            (format #t "  ; Extension properties:~%")
    6273            (format #t "  `(")
    63             ; TODO: Support syntax extensions
    6474            (format #t "(documentation \"~A.html\")~%" name)
    65             (format #t "  (version ,(if (file-exists? \"version\") (with-input-from-file \"version\" read) \"unknown\")))")))))))
     75            (when require-at-runtime
     76              (format #t "    (require-at-runtime ~A)~%" (stream->string (cdr require-at-runtime))))
     77            (format #t "    (version ,(if (file-exists? \"version\") (with-input-from-file \"version\" read) \"unknown\"))))~%")))))))
    6678
    6779(test-group parse-list-of-tokens
     
    8294           (stream-split str char-whitespace?)))))
    8395
     96(test-group get-list-of-runtime-files
     97  (test (get-list-of-runtime-files (environment ((params `((name . ,(string->stream "foo")))))))
     98        '("foo")))
     99
    84100(define (get-list-of-runtime-files env)
    85101  (let-from-environment env (params)
    86     (let ((runtime-files (assoc 'runtime-files params)))
    87       (if runtime-files
    88         (parse-list-of-tokens (cdr runtime-files))
    89         (list (cdr (assoc 'name params)))))))
     102    (call-with-logging 'debug
     103      (lambda ()
     104        (let ((runtime-files (assoc 'runtimefiles params)))
     105          (if runtime-files
     106            (parse-list-of-tokens (cdr runtime-files))
     107            (list (stream->string (cdr (assoc 'name params)))))))
     108      "get-list-of-runtime-files: ~A"
     109      params)))
    90110
    91111(define (output-meta-prop symbol params)
    92   (and-let* ((value (assoc symbol params)))
    93     (format #t " (~A \"~A\")~%" symbol (stream->string (cdr value)))))
     112  (call-with-logging 'debug
     113    (lambda ()
     114      (and-let* ((value (assoc symbol params))
     115                 (value-drop (stream-drop-while char-whitespace? (cdr value)))
     116                 ((positive? (stream-length value-drop))))
     117        (format #t " (~A \"~A\")~%" symbol (stream->string value-drop))))
     118    "output-meta-prop: ~A: ~A"
     119    symbol
     120    params))
    94121
    95122(define (generate-meta-contents env)
     
    98125      (with-output-to-string
    99126        (lambda ()
    100           (let ((name (cdr (assoc 'name params)))
    101                 (author (assoc 'author params))
    102                 (synosys (assoc 'synosys params)))
     127          (let ((name (stream->string (cdr (assoc 'name params)))))
    103128            (output-autogenerated-header env)
    104129            (format #t "(")
    105             (format #t "(files \"~A.setup\" \"~A.html\" ~{\"~A.scm\"~})~%" name (get-list-of-runtime-files env))
     130            (format #t "(files \"~A.setup\" \"~A.html\"~{ \"~A.scm\"~})~%" name name (get-list-of-runtime-files env))
    106131            (output-meta-prop 'author params)
    107132            (output-meta-prop 'synopsis params)
    108133            (output-meta-prop 'category params)
     134            (and-let* ((value (assoc 'uses params))
     135                       (actual (stream-drop-while char-whitespace? (cdr value)))
     136                       ((not (stream-null? actual))))
     137              (format #t " (needs ~A)~%" (stream->string actual)))
    109138            (output-meta-prop 'license params)
    110139            (format #t " (egg \"~A.egg\"))~%" name)))))))
     
    124153
    125154(define (generate-header env)
    126   (with-output-to-string (lambda () (output-autogenerated-header env))))
     155  (call-with-logging 'debug
     156    (lambda ()
     157      (with-output-to-stream
     158        (lambda ()
     159          (output-autogenerated-header env)
     160          (let-from-environment env (params)
     161            (let ((data-exports (assoc 'exports params))
     162                  (name (assoc 'name params))
     163                  (data-uses (assoc 'uses params)))
     164              (format #t "(module ~A ~A~%~%"
     165                      (stream->string (cdr name))
     166                      (if data-exports
     167                        (format #f "(~{~A~^ ~})" (parse-list-of-tokens (cdr data-exports)))
     168                        "*")))))))
     169    "generate-header"))
     170
     171(define (generate-test-contents env)
     172  (with-output-to-stream
     173    (lambda ()
     174      (output-autogenerated-header env)
     175      (format #t "(setenv \"TESTS\" \"yes\")~%")
     176      (format #t "(setenv \"TESTS_VERBOSE\" \"yes\")~%")
     177      (format #t "(use ~A)~%" (cdr (assoc 'name params)))
     178      (format #t "(run-tests)~%"))))
    127179
    128180(define (scheme-library-definition env)
    129181  (let-from-environment env (output-format parse return params)
    130     (format (current-error-port) "scheme-library-definition: ~A~%" params)
    131     (let ((name (assoc 'name params)))
     182    (logging 'info "Scheme-library-definition start: ~A" output-format)
     183    (let ((name (assoc 'name params))
     184          (uses (assoc 'uses params)))
    132185      (cond
    133186        ((not name)
     187         (logging 'info "Call to scheme-library-definition with no name parameter.")
    134188         (html-stream "[scheme-library error: name parameter missing"))
    135189        ((eq? output-format 'enscript)
    136          (return
    137            (list (cdr name)
    138                  "application/x-scheme-chicken-meta"
    139                  (generate-meta-contents env)))
    140          (return
    141            (list (cdr name)
    142                  "text/html"
    143                  (generate-html-contents env)))
    144          (return
    145            (list (cdr name)
    146                  "application/x-scheme-chicken-setup"
    147                  (generate-setup-contents env)))
    148          (for-each
    149            (lambda (file)
    150              (return file "application/x-scheme" (generate-header env)))
    151            (get-list-of-runtime-files env)))
     190         (call-with-logging 'debug
     191           (lambda ()
     192             (return
     193               (cdr name)
     194               "application/x-scheme-chicken-meta"
     195               (call-with-logging 'debug
     196                 (lambda () (generate-meta-contents env))
     197                 "Generate meta contents"))
     198             (return
     199               (cdr name)
     200               "text/html"
     201               (call-with-logging 'debug
     202                 (lambda () (generate-html-contents env))
     203                 "Generate HTML contents"))
     204             (return
     205               (cdr name)
     206               "application/x-scheme-chicken-setup"
     207               (call-with-logging 'debug
     208                 (lambda () (generate-setup-contents env))
     209                 "Generate setup contents"))
     210             (when (and uses (member "embedded-test" (parse-list-of-tokens (cdr uses))))
     211               (return
     212                 (format #f "tests-~A/run" (cdr name))
     213                 "application/x-scheme"
     214                 (call-with-logging 'debug
     215                   (lambda () (generate-test-contents env))
     216                   "Generate env contents")))
     217             (for-each
     218               (lambda (file)
     219                 (return file "application/x-scheme" (generate-header env)))
     220               (get-list-of-runtime-files env))
     221             stream-null)
     222           "Auto generating files for Scheme Library."))
    152223        (else
    153224          (parse
     
    156227              (html-prop "Author"
    157228                (let ((author (assoc 'author params))
    158                       (author-email (assoc 'author-email params)))
     229                      (author-email (assoc 'authoremail params)))
    159230                  (and author
    160                        (stream-concatenate
     231                       (stream-append
    161232                         (cdr author)
    162                          (stream-if author-email (html-stream "<" author-email ">"))))))
     233                         (stream-if author-email
     234                           (html-stream " <" (cdr author-email) ">"))))))
    163235              (html-prop-param "Category" 'category params)
    164236              (html-prop-param "Synopsis" 'synospis params)
Note: See TracChangeset for help on using the changeset viewer.