Outdated egg!

This is an egg for CHICKEN 3, the unsupported old release. You're almost certainly looking for the CHICKEN 4 version of this egg, if it exists.

If it does not exist, there may be equivalent functionality provided by another egg; have a look at the egg index. Otherwise, please consider porting this egg to the current version of CHICKEN.

svnwiki-chicken

Outdated egg!
svnwiki-chicken

Introduction

The svnwiki-chicken egg extends Svnwiki to provide functionality useful for repositories of Scheme code and documentation about Scheme code such as The Chicken Wiki.

Preamble

; $id$
;
; Copyright 2008 Alejandro Forero Cuervo <azul@freaks-unidos.net>
; All Rights Reserved
;
; This code is available under the GPLv3 license.
;
; The authoritative source for this program, where new versions may be
; available, is:
;
;   http://wiki.call-cc.org/egg/svnwiki-chicken

This egg does not export any symbols:

(declare (export))

Dependencies

(use svnwiki-extensions-support svn-post-commit-hooks orders format-modular srfi-40 html-stream stream-ext embedded-test sqlite3 stream-wiki)

We define a chickenegg tag, used by the eggs post-commit functionality when building the Eggs Unlimited wiki pages. The chickenegg tag expects a set of parameters describing an egg and expands to an HTML row presenting it.

(define *url-eggs*
  "http://www.call-with-current-continuation.org/eggs/")

(define (chickenegg-html env)
  (let-from-environment env (params parse path-in output-format)
    (or
      (and-let* ((eq? output-format 'html)
                 (name-stream (assoc 'name params))
                 (name (stream->string (cdr name-stream)))
                 (description (assoc 'description params))
                 (license (assoc 'license params))
                 (author (assoc 'author params))
		 (major (assoc 'major params)))
        (parse
          (html-stream
            (tr (td (if (file-exists? (svnwiki-repository-path env name)))
                      (format #f "[[~A]]" name)
		      (if major
			  (format #f "[[~A~A/~A.html|~A]]" *url-eggs* (stream->string (cdr major)) name name)
			  (format #f "[[~A~A.html|~A]]" *url-eggs* name name))))
                (td (cdr description))
                (td (cdr license))
                (td "[[" (cdr author) "]]")
                (td "[[http://wiki.call-cc.org/dep-graphs/" name ".png|Dependencies]]")))))
      stream-null)))

(svnwiki-extension-define 'code-break 'chickenegg chickenegg-html)

It should be noted that the Eggs Unlimited pages should not be commited to the wiki (they are automatically generated), but that's what we have right now.

Definitions

We define some markup for definitions documented in a wiki page. The basic usage would be this:

<nowiki><procedure>(string-append a b ...)</procedure></nowiki>

First we define a function that, given the text inside a definition (eg. “(string-append a b ...)”), evaluates whether it is a proper list:

(define (definition-list? text)
  (and (not (stream-null? text))
       (char=? (stream-car text) #\()
       (char=? (stream-last text) #\))
       (not (char=? #\) (stream-car
                          (stream-drop-while
                            char-whitespace?
                            (stream-cdr text)))))))


(definition-list? (string->stream "(foo)"))
 => #t

(definition-list? (string->stream "(foo bar)"))
 => #t

(definition-list? (string->stream "foo"))
 => #f

(definition-list? (string->stream "(  )"))
 => #f

(definition-list? (string->stream ""))
 => #f

Based on that, we define a function that, given the text inside a definition, returns the symbol being defined:

(define (get-definition-name text)
  (stream-take-while
    (disjoin (complement char-whitespace?)
             (cut char=? <> #\))
    (if (definition-list? text)
      (stream-cdr (stream-butlast text))
      text)))


(stream->string (get-definition-name (string->stream "foo")))
 => "foo"

(stream->string (get-definition-name (string->stream "(foo)")))
 => "foo"

(stream->string (get-definition-name (string->stream "(foo bar)")))
 => "foo"

(stream->string (get-definition-name (string->stream "(stream= proc str str ...)")))
 => "stream="

With all that in place, we create a procedure to handle the definitions. It will be instantiated several types with type set to the type of definition (eg. “procedure”).

If the output format is the scheme-definitions, it returns the name and type of the definition. Otherwise, it returns a nice view of the definition.

(define (chicken-def type env)
  (let-from-environment env (path text parse output-format)
    ; Remove whitespace at beginning or end
    (let ((text (stream-reverse
                  (stream-drop-while
                    char-whitespace?
                    (stream-reverse
                      (stream-drop-while
                        char-whitespace?
                        text))))))
      (case output-format
        ((scheme-definitions)
          (let-from-environment env (return)
            (return (list type (get-definition-name text))))
          stream-null)
        (else
          (parse
            (html-stream
              ((a name (format #f "xsvnwiki-scheme-~A" (stream->string (get-definition-name text))))
               "["
               type
               "] {{"
               (if (definition-list? text)
                 (receive (name rest)
                          (stream-break char-whitespace?
                                        (stream-cdr (stream-butlast text)))
                   (html-stream
                     "('''" name "'''" rest ")"))
                 text)
               "}}\n\n"))))))))

Now the actual instantiations, for all the types of definitions we support:

(for-each
  (lambda (type)
    (svnwiki-extension-define
      'code-span
      type
      (cut chicken-def (symbol->string type) <>)))
  '(procedure macro read parameter record string class method integer constant))

Database

Definition

We will keep a database as a cache for interesting information found in the wiki.

The definitions table will be used for a list of symbols documented in wiki pages. It has the following attributes:

name: The name of a symbol.
type: The type of definition, such as “procedure”, “string”, etc.. The actual list of types will be defined elsewhere.
page: The path to the page on which it is defined.

The tests table has a list of tests found in the wiki, with the following attributes:

expr: The Scheme expression that should be evaluated (eg. “(string-append "foo" "bar")”).
expect: Another Scheme expression which should evaluate to the expected value (eg. “"foobar"”).
cmp: If provided, a Scheme expresion that should evaluate to a procedure of 2 arguments that is used to compare the values that expr and expect evaluated to. If empty, equal? should be used.
page: The page in the wiki in which the test was found.
blessed: This will be set to false (the empty string) by default. Once the admin approves a test, he should set it to true (the string "true").

The tests_results table contains results for the tests.

(define (scheme-definitions-db-create env)
  (db-run env "CREATE TABLE definitions ( name varchar, type varchar, page varchar );")
  (db-run env "CREATE TABLE tests ( expr varchar, expect varchar, cmp varchar, page varchar, blessed boolean );")
  (db-run env "CREATE TABLE tests_results ( version varchar, received varchar, pass boolean, date integer );"))

Usage

Now some support functions for using the database:

(define *db* #f)
(define *max-retries* 8)

(define (db-run env query . params)
  (let-from-environment env (data)
    (unless *db*
      (let* ((db-path (svnwiki-make-pathname data "scheme-definitions" "db"))
             (existed (file-exists? db-path)))
        (format (current-error-port) "Opening DB: ~A~%" db-path)
        (set! *db* (sqlite3:open db-path))
        (unless existed
          (format (current-error-port) "Creating initial tables in DB: ~A~%" db-path)
          (scheme-definitions-db-create env))))
    (let loop ((attempt 0))
      (condition-case
        (let ((result
                (iterator->stream
                  (lambda (capture stop)
                    (receive (stmt rest)
                             (sqlite3:prepare *db* query)
                      (apply (stream-wrap-proc-string sqlite3:for-each-row) (compose capture vector) stmt params)
                      (sqlite3:finalize! stmt))))))
          (stream-length result) ; force execution
          result)
        (e (exn sqlite3)
           (format (current-error-port) "SQLite error: ~A, attempt ~A~%"
                   ((condition-property-accessor 'sqlite3 'status) e)
                   attempt)
           (cond
             ((and (member ((condition-property-accessor 'sqlite3 'status) e) '(locked busy))
                   (< attempt *max-retries*))
              (let ((seconds-wait (expt 2 attempt)))
                (format (current-error-port) (svnwiki-translate #f "scheme-definitions database locked, attempt #~A, retry in ~A seconds~%") attempt seconds-wait)
                (sleep seconds-wait))
              (loop (+ attempt 1)))
             (else
              (signal e))))))))

Examples and tests

TODO: Document.

(define (chicken-examples env)
  (let-from-environment env (params parse text output-format)
    (let ((filename (assoc 'filename params))
          (testgroup (assoc 'testgroup params)))
      (format (current-error-port) "Tests: [filename:~A][testgroup:~A]~%"
              (and filename (stream->string (cdr filename)))
              (and testgroup (stream->string (cdr testgroup))))
      (if (or (not (eq? output-format 'enscript))
              (and filename testgroup))
        (parse
          (html-stream
            "Examples:\n\n"
            "<enscript highlight=scheme"
            (if (and filename testgroup)
              (format #f " filename='~A'"
                      (stream->string
                        (stream-remove (cut char=? <> #\')
                                       (cdr filename))))
              "")
            ">"
            (if (and filename testgroup (eq? output-format 'enscript))
              (format #f "\n(test-group ~A" (stream->string (cdr testgroup)))
              "")
            (parse text)
            (if (and filename testgroup (eq? output-format 'enscript))
              ")\n"
              "")
            "

"))

       stream-null))))

(define (chicken-example env)

 (let-from-environment env (text output-format parse)
   (html-stream
     (if (eq? output-format 'enscript)
       "\n  (test"
       "")
     (parse text)
     (if (eq? output-format 'enscript)
       ")"
       ""))))

(define (chicken-expr env)

 (let-from-environment env (text output-format)
   (if (eq? output-format 'enscript)
     (html-stream " " text)
     (html-stream text "\n"))))

(define (chicken-result include prefix env)

 (let-from-environment env (text output-format)
   (if (eq? output-format 'enscript)
     (html-stream " " text)
     (html-stream prefix " " text "\n"))))

(define (chicken-result-cmp env)

 (let-from-environment env (text output-format)
   (if (eq? output-format 'enscript)
     (html-stream " " text)
     stream-null)))

(define (redirect-scheme env)

 (let-from-environment env (path return)
   (unless (file-exists? (svnwiki-repository-path env))
     (let ((targets (db-run env "SELECT page FROM definitions WHERE name = ?;" path)))
       (unless (stream-null? targets)
         (return
           (format #f "~A#xsvnwiki-scheme-~A"
                   (vector-ref (stream-car targets) 0)
                   path)))))))

(svnwiki-extension-define 'redirect 'scheme-definitions redirect-scheme)

(svnwiki-extension-define 'code-span 'examples chicken-examples) (svnwiki-extension-define 'code-span 'example chicken-example)

For the time being, we just ignore these

(svnwiki-extension-define 'code-span 'init (lambda (env) stream-null)) (svnwiki-extension-define 'code-span 'expr chicken-expr) (svnwiki-extension-define 'code-span 'result (cut chicken-result #t "=>" <>)) (svnwiki-extension-define 'code-span 'resultcmp chicken-result-cmp) (svnwiki-extension-define 'code-span 'input (cut chicken-result #f "[input]" <>)) (svnwiki-extension-define 'code-span 'output (cut chicken-result #f "[output]" <>)) </enscript>

Update notify

TODO: Get the list of tests and store it in the database.

(define (update-notify-scheme env)
  (let-from-environment env (path-in path)
    (format (current-error-port) "Start scheme update: ~A~%" path)
    (db-run env "DELETE FROM definitions WHERE page = ?;" path)
    (stream-for-each
      (lambda (data)
        (db-run env "INSERT INTO definitions VALUES ( ?, ?, ? );" (cadr data) (car data) path))
      (iterator->stream
        (lambda (return stop)
          (wiki-extension
            'scheme-definitions
            (wiki-open path-in path)
            stream-null
            path
            (constantly stream-null)
            (lambda (name tail) tail)
            (make-hash-table)
            (environment-capture env (return))))))))

(svnwiki-extension-define 'update-notify-recursive 'scheme-definitions update-notify-scheme)

Version history

1.0: First public release.