(define (wiki-title title)
#<#EOF
== #{title}
EOF
)
(define (wiki-subtitle title)
#<#EOF
=== #{title}
EOF
)
(define (wiki-subsubtitle title)
#<#EOF
==== #{title}
EOF
)
(define (wiki-subsubsubtitle title)
#<#EOF
===== #{title}
EOF
)
(define (wiki-source source)
#<#EOF
#{source}
EOF
)
(define (wiki-procedure signature to)
#<#EOF
#{signature} → #{to}
EOF
)
(define (wiki-syntax signature to)
#<#EOF
#{signature} → #{to}
EOF
)
(define (wiki-read signature to)
#<#EOF
#{signature} → #{to}
EOF
)
(define (wiki-record type)
#<#EOF
#{type}
EOF
)
(define (wiki-record type)
#<#EOF
#{type}
EOF
)
(define (wiki-module name)
#<#EOF
'''[module]''' {{#{name}}}
EOF
)
(define (wiki-export export)
#<#EOF
* [[###{export}]]
EOF
)
;;; What happens with colons in the definition?
(define (wiki-parameter parameter definition)
#<#EOF
; #{parameter} : #{definition}
EOF
)
(define (wiki-monospace text)
#<#EOF
{{#{text}}}
EOF
)
;; Made these into a strings, because the brackets throw off paredit.
(define (wiki-preamble title description)
#<#EOF
#(wiki-title title)
#{description}
[[toc:]]
EOF
)
(define (wiki-postamble author username)
#<#EOF
#(wiki-subtitle "About this egg")
#(wiki-subsubtitle "Author")
[[/users/#{username}#(integer->char 124)#{author}]]
#(wiki-subsubtitle "Colophon")
Documented by [[/egg/cock#(integer->char 124)cock]].
EOF
)
(define (wiki-parameter-object name init)
#<#EOF
#{name} → #{init}
EOF
)
(define (wiki-scalar name definition)
#<#EOF
#{name} → #{definition}
EOF
)
;;; Needs to be generalized.
(define (wiki-parse-directive doc expr data document)
(let ((directive (car doc))
(arguments (cdr doc))
(data (document-data document)))
(case directive
((email)
(hash-table-set! data 'email (car arguments))
void)
((username)
(hash-table-set! data 'username (car arguments))
void)
((author)
(hash-table-set! data 'author (car arguments))
void)
((title)
(hash-table-set! data 'title (car arguments))
void)
((egg)
(hash-table-set! data 'egg (car arguments))
void)
((description)
(hash-table-set! data 'description (car arguments))
void)
((example)
(lambda () (write-example data (car arguments) (cdr arguments))))
((source)
(lambda () (write-wiki-source (car arguments))))
((heading)
(let ((title (car arguments)))
(lambda ()
(hash-table-set! data 'heading-level 1)
(display (wiki-subtitle title)))))
((subheading)
(let ((title (car arguments)))
(lambda ()
(hash-table-set! data 'heading-level 2)
(display (wiki-subsubtitle title)))))
;; Shit: we're supporting a different language than LaTeX; TODO:
;; intermediate S-expressions over pre-post-order!
((subsubheading)
(let ((title (car arguments)))
(lambda ()
(hash-table-set! data 'heading-level 3)
(display (wiki-subsubsubtitle title)))))
;; This is where me might to some fancy-schmancy
;; markdown-to-wiki bullshit; maybe we can support a subset? I
;; really just want monospace and links.
((text)
(let ((text (string-join arguments "\n\n" 'suffix)))
(lambda ()
(display text)
(newline))))
(else
(lambda () (warning "Unknown directive" directive))))))
(define (wiki-make-heading heading-level)
(match heading-level
(0 wiki-subtitle)
(1 wiki-subsubtitle)
(_ wiki-subsubsubtitle)))
(define wiki-make-current-heading
(case-lambda
((data)
(wiki-make-current-heading data 0))
((data offset)
(wiki-make-heading
(+ (hash-table-ref/default data 'heading-level 0) offset)))))
(define (wiki-make-description descriptions)
(string-join descriptions "\n\n"))
(define (write-example data description expressions)
(display description)
(newline)
(let ((env (environment-copy (interaction-environment) #t))
(egg (hash-table-ref/default data 'egg #f)))
;; We can't seem to use `use' with env.
(when egg (eval `(require-extension ,(string->symbol egg))))
(do ((i 1 (+ i 1))
(expressions expressions (cdr expressions)))
((null? expressions))
(let ((expression (car expressions)))
(fmt #t (columnar " " (pretty expression)))
(fmt #t (columnar " => " (pretty (eval expression))) " " nl)))))
(define (write-wiki-source expression)
(display (wiki-source (with-output-to-string (lambda () (pp expression))))))
(define (write-wiki-block doc
expr
data
name
item
. rest-items)
(receive (normal-parameters special-parameters)
(doc-normal-and-special-parameters doc)
(unless (internal? special-parameters)
(let ((heading (wiki-make-current-heading data))
(description (wiki-make-description (doc-descriptions doc))))
(display (heading (wiki-monospace name)))
(display (string-join (cons item (cons description rest-items)) "\n" 'suffix))
(when (write-source?)
(write-wiki-source expr))
(let ((examples (examples special-parameters)))
(unless (null? examples)
(let ((heading (wiki-make-current-heading data 1)))
(display (heading "Examples"))
(for-each (lambda (example)
(write-example
data
(example-description example)
(example-expressions example)))
examples))))))))
;;; Generalize this.
(define (make-wiki-procedure template name formals to)
(template (cons name formals) (string-join to ", ")))
(define (purge-newlines string)
(irregex-replace/all "\n" string " "))
(define (make-wiki-parameters parameters)
(let ((parameters
(map
(match-lambda ((parameter definition)
(wiki-parameter parameter (purge-newlines definition))))
parameters)))
(string-join parameters "\n")))
(define (wiki-parse-procedure doc expr data name formals)
(receive (normal-parameters special-parameters)
(doc-normal-and-special-parameters doc)
(let ((to (procedure-to special-parameters)))
(let ((procedure
(make-wiki-procedure wiki-procedure name formals to))
(parameters
(make-wiki-parameters normal-parameters)))
(lambda ()
(write-wiki-block doc
expr
data
name
procedure
parameters))))))
(define (wiki-parse-case-lambda doc expr data name formals+)
(receive (normal-parameters special-parameters)
(doc-normal-and-special-parameters doc)
(let ((to (procedure-to special-parameters)))
(let ((procedures
(string-join
(map (lambda (formals)
(make-wiki-procedure
wiki-procedure
name
formals
to))
formals+)
"\n"))
(parameters
(make-wiki-parameters normal-parameters)))
(lambda ()
(write-wiki-block
doc
expr
data
name
procedures
parameters))))))
(define (wiki-parse-parameter doc expr data name init)
(let ((parameter (wiki-parameter-object name init)))
(thunk (write-wiki-block
doc
expr
data
name
parameter))))
(define (wiki-parse-scalar doc expr data name)
(receive (normal-parameters special-parameters)
(doc-normal-and-special-parameters doc)
(if (scalar-procedure? normal-parameters special-parameters)
(wiki-parse-procedure doc
expr
data
name
(map car normal-parameters))
(let* ((definition (last expr))
(scalar (wiki-scalar name definition)))
(thunk (write-wiki-block doc
expr
data
name
scalar))))))
(define (wiki-parse-syntax doc expr data name)
(receive (normal-parameters special-parameters)
(doc-normal-and-special-parameters doc)
(let ((to (procedure-to special-parameters)))
(let ((syntax (make-wiki-procedure wiki-syntax
name
(formals normal-parameters)
to))
(parameters (make-wiki-parameters normal-parameters)))
(thunk (write-wiki-block doc
expr
data
name
syntax
parameters))))))
(define (wiki-parse-read doc expr data char)
(receive (normal-parameters special-parameters)
(doc-normal-and-special-parameters doc)
(let* ((to (procedure-to special-parameters))
(read (wiki-read char (string-join to ", "))))
(let ((parameters (make-wiki-parameters normal-parameters)))
(thunk (write-wiki-block doc
expr
data
char
read
parameters))))))
(define (wiki-parse-record doc expr data type)
(receive (normal-parameters special-parameters)
(doc-normal-and-special-parameters doc)
(let ((record (wiki-record type))
(fields (make-wiki-parameters normal-parameters)))
(thunk (write-wiki-block doc
expr
data
type
record
fields)))))
(define (make-wiki-exports exports)
(string-join (map wiki-export exports) "\n"))
(define (wiki-parse-module doc expr data name exports)
(let ((module (wiki-module name))
(exports (make-wiki-exports exports)))
(thunk (parameterize ((write-source? #f))
(write-wiki-block doc
expr
data
name
module
exports)))))
(define (wiki-parse-docexpr document docexpr)
(parameterize ((parse-directive wiki-parse-directive)
(parse-procedure wiki-parse-procedure)
(parse-case-lambda wiki-parse-case-lambda)
(parse-parameter wiki-parse-parameter)
(parse-scalar wiki-parse-scalar)
(parse-syntax wiki-parse-syntax)
(parse-read wiki-parse-read)
(parse-record wiki-parse-record)
(parse-module wiki-parse-module))
(parse-docexpr document docexpr)))
;;; Needs to be generalized.
(define (wiki-parse-docexprs document docexprs)
(let ((parsed-docexprs (make-stack)))
(stack-for-each
docexprs
(lambda (docexpr)
(stack-push! parsed-docexprs
(wiki-parse-docexpr document docexpr))))
parsed-docexprs))
;;; Needs to be generalized.
(define (wiki-write-docexprs docexprs)
@("Write the source-derived docexprs as svnwiki."
(docexprs "The parsed docexprs"))
(let* ((document (make-document (make-hash-table) (make-stack)))
(parsed-docexprs (wiki-parse-docexprs document docexprs)))
(let ((data (document-data document)))
(let ((author
(hash-table-ref/default data 'author "Anonymous"))
(username
(hash-table-ref/default data 'username "anonymous"))
(email
(hash-table-ref/default data 'email "anonymous@example.com"))
(title
(let ((title (hash-table-ref/default data 'egg #f))
(egg (hash-table-ref/default data 'egg #f)))
(cond (title title)
(egg egg)
(else "title"))))
(description
(hash-table-ref/default data 'description "Description")))
(display (wiki-preamble title description))
(stack-for-each parsed-docexprs (lambda (docexpr) (docexpr)))
(display (wiki-postamble author username))))))