73 lines
2.7 KiB
Scheme
73 lines
2.7 KiB
Scheme
; copyright by Paul Graunke June 2000 AD
|
|
(require (lib "pretty.ss")
|
|
(lib "date.ss")
|
|
(lib "list.ss")
|
|
(lib "etc.ss"))
|
|
|
|
; date-string : -> String
|
|
(define (date-string) (date->string (seconds->date (current-seconds)) 'seconds-please))
|
|
|
|
(define html-spec (call-with-input-file (build-path (collection-path "html") "html-spec") read))
|
|
|
|
(define (empty-name? x) (null? (cdr x)))
|
|
|
|
(define empty-names
|
|
(apply append (map car (filter empty-name? html-spec))))
|
|
|
|
(define non-empty-names
|
|
(apply append (map car (filter (compose not empty-name?) html-spec))))
|
|
|
|
; generate-structs : -> Void
|
|
(define (generate-structs)
|
|
(let ([file (build-path (collection-path "html") "html-structs.ss")])
|
|
(printf "building ~a~n" file)
|
|
(call-with-output-file file
|
|
(lambda (out)
|
|
(fprintf out "; This code was machine generated by generate-code.ss ~a~n" (date-string))
|
|
(for-each
|
|
(lambda (x) (pretty-print x out))
|
|
(append
|
|
(list
|
|
'(define-struct html-element (attributes))
|
|
`(define-struct (html-full html-element) (content)))
|
|
(map (lambda (x) `(define-struct (,x html-full) ()))
|
|
non-empty-names)
|
|
(map (lambda (x)
|
|
`(define-struct (,x html-element) ()))
|
|
empty-names))))
|
|
'text 'truncate)))
|
|
|
|
; generate-case : -> Void
|
|
(define (generate-case)
|
|
(let ([file (build-path (collection-path "html") "case.ss")])
|
|
(printf "building ~a~n" file)
|
|
(call-with-output-file file
|
|
(lambda (out)
|
|
(fprintf out ";This file was generated by genrate-code.ss on ~a~n" (date-string))
|
|
(fprintf out "~n; xml-single-content->html : Content (listof Html-content) -> (listof Html-content)~n")
|
|
(pretty-print
|
|
`(define (xml-single-content->html x acc)
|
|
(cond
|
|
[(element? x)
|
|
(case (element-name x)
|
|
,@(append
|
|
(map (lambda (name)
|
|
`[(,name) (cons (,(string->symbol (string-append "make-" (symbol->string name)))
|
|
(element-attributes x))
|
|
acc)])
|
|
empty-names)
|
|
(map (lambda (name)
|
|
`[(,name) (cons (,(string->symbol (string-append "make-" (symbol->string name)))
|
|
(element-attributes x)
|
|
(xml-contents->html (element-content x)))
|
|
acc)])
|
|
non-empty-names))
|
|
[else acc])]
|
|
[(or (pcdata? x) (entity? x)) (cons x acc)]
|
|
[else acc]))
|
|
out))
|
|
'truncate 'text)))
|
|
|
|
(generate-structs)
|
|
(generate-case)
|