;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; WAFFLE - Widgets and Forms For Lisp Enthusiasts ;;; ;;; WAFFLE is a toolkit for building HTML and other XML based pages through ;;; composition of discrete, user definable, widgets. ;;; Widgets comprise markup specified in SXML as well as a set of attributes ;;; which are rendered into the widget. ;;; ;;; WAFFLE handles the composition of multiple widgets of the same type ;;; containing HTML Form elements. ;;; If a widget is given a 'name' attribute then the value of this attribute ;;; propagates to child widgets and HTML Form elements. The values does not ;;; propagate to any other type of element. Name attributes in other types of ;;; element are ignored. ;;; ;;; The value propagates by being prepended to the name attribute of the ;;; child widgets or form elements. ;;; ;;; This allows multiple widgets containing form elements to be composed on the ;;; same page without their names clashing. ;;; ;;; ;;; WAFFLE is based on ideas in the following papers and essays: ;;; ;;; http://www.snell-pym.org.uk/archives/2006/12/17/the-implementation-of-web-applications ;;; http://www.snell-pym.org.uk/archives/2007/05/18/a-design-for-a-scheme-web-application-framework/ ;;; http://www.snell-pym.org.uk/archives/2007/06/17/another-thing-i-hate-about-web-application-frameworks/ ;;; http://pagesperso-systeme.lip6.fr/Christian.Queinnec/PDF/www.pdf ;;; ;;; ;;; Andy Bennett , 2012/06 ;;; Simon Worthington , 2012/07 ;;; Arthur Maciel , 2015/06 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (module waffle (waffle-sxml->html sxml->html widget-rules add-widget load-widget load-widgets-from-directory widget? get-widget ; for the widget debugger get-widget-attribute ; for the widget debugger get-from-all-widgets combine-javascript combine-dependencies generate-scripts-widget propagate-query-string widgets ; for the widget debugger ) (import chicken scheme) (use srfi-1 data-structures extras irregex posix ports) ; Units - http://api.call-cc.org/doc/chicken/language (use sxml-transforms matchable uri-common) ; Eggs - http://wiki.call-cc.org/chicken-projects/egg-index-4.html (import-for-syntax chicken) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; WIDGETS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define widgets (make-parameter '())) ; The markup / definition of each widget. (define widget-rules (make-parameter '())) ; The SXML rule that will render each widget. (define (widget? widget-name) (if (assq widget-name (widgets)) #t #f)) (define (get-widget widget-name #!optional (param 'markup)) (and-let* ((widget (assq widget-name (widgets))) (value (assq param (cdr widget)))) (cdr value))) (define (get-widget-attribute widget-name attr) (and-let* ((attrs (get-widget widget-name 'attributes)) (attr (assq attr attrs))) (second attr))) (define (get-from-all-widgets param) (filter identity (map (lambda (m) (get-widget (car m) param)) (widgets)))) (define (make-render-proc definition) (let* ((default-bindings (map (lambda (binding) `(,(car binding) ',(second binding))) (alist-ref 'attributes definition))) (markup (alist-ref 'markup definition)) (default-contents (alist-ref 'contents default-bindings)) (proc (eval `(lambda (#!key ,@(if default-contents '() '((contents '()))) ,@default-bindings (++ string-append)) ,markup) (module-environment 'scheme)))) (lambda (bindings contents) (apply proc contents: contents (fold (lambda (binding plist) (if (>= (length binding) 2) (cons* (string->keyword (symbol->string (car binding))) (second binding) plist ) (cons* (string->keyword (symbol->string (car binding))) '() plist ))) '() bindings))))) (define (convert proc default-bindings) (lambda (t b) (and-let* ((bindings (if (and (pair? b) (pair? (car b)) (eq? '@ (caar b))) (cdar b) '())) (contents (if (and (pair? b) (pair? (car b)) (eq? '@ (caar b))) (cdr b) b))) (let* ((sxml (proc bindings contents)) (sxml (walk-rendering sxml (append bindings default-bindings)))) sxml)))) (define (add-widget widgetname definition) (widgets (cons `(,widgetname . ,definition) (widgets))) (widget-rules (cons `(,widgetname *macro* . ,(convert (make-render-proc definition) (alist-ref 'attributes definition))) (widget-rules))) ; Just call convert for each widget. ) (define (load-widget widgetname filename) (add-widget widgetname (read-file filename))) (define (load-widgets-from-directory dir extension #!optional (prefix "")) (for-each (lambda (match) (load-widget (string->symbol (string-append prefix (irregex-match-substring match 1))) (string-append dir (irregex-match-substring match)))) (filter irregex-match-data? (map (lambda (path) (irregex-match (irregex `(: ($ (* any)) ,extension)) path)) (directory dir))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; JAVASCRIPT ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Concatenate all the javascript sections into one library (define (combine-javascript directory filename) (with-output-to-file (string-append directory filename) (lambda () (for-each print (flatten (get-from-all-widgets 'javascript-combine)))))) ; Concatenate all the javascript from dependencies files into one library ; directory = root directory for your widget deps ; filename = name of combined file (define (combine-dependencies directory filename) (with-output-to-file (string-append directory filename) (lambda () (for-each print (map (lambda (js) (string-append "(function(){" (with-input-from-file (string-append directory js) read-string) "})();")) (flatten-dependencies (apply append (get-from-all-widgets 'javascript-require)))))))) ; Merges a list of sublists whose cars are the given identifier into one list ; eg (merge-with-car 'A '((A B C) (A C Z) (B C D))) ; -> (A B C C Z) (define (merge-with-car identifier input) (cons identifier (flatten (map cdr (filter (lambda (m) (equal? (car m) identifier)) input))))) ; Converts a list of lists of dependencies into a single list using a topological sort (define (flatten-dependencies input) (topological-sort (map (lambda (head) (merge-with-car head input)) (delete-duplicates (map car input))) equal?)) ; Generate a widget that has all the required javascript includes (define (generate-scripts-widget directory . files) (add-widget 'scripts `((markup . '(*TOP* ,@(map (lambda (include) `(script (@ (language "javascript") (type "text/javascript") (src ,directory ,include)))) (append (flatten-dependencies (apply append (get-from-all-widgets 'javascript-require))) files)))) (attributes . ())))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; FORMS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define form-elements '(input button select textarea xmlarea isindex)) ; does isindex have a name? (define (form-element? element-name) (any (lambda (p) p) (map (cut eq? element-name <>) form-elements))) (define (render-forms-fup parent-path parent-seed lk-path lk-seed node element-name) ; TODO: there are three cases here ; 1) parent-path (@ ignore !ignore): coming up from a name attribute: here we prepend the correct thing. ; 2) parent-path (ignore !ignore) : coming up from an attribute list: here we need to add a name attribute. ; 3) parent-path (!ignore) : coming up from an ignored / interesting subtree: here we need to add an attribute list containing a name. (if element-name (match `(,parent-path ,(reverse lk-seed)) (((element ...) ('@ attribs ...)) (if (interesting? (car element)) (if (not (any (lambda (a) (if (pair? a) (eq? (car a) 'name) #f)) attribs)) ; add name attributes to those who don't have it. (cons `(name ,element-name) lk-seed) lk-seed) lk-seed)) ((_ (element content ...)) (if (and (eqv? (car lk-path) element) (interesting? element)) (if (not (any (lambda (a) (if (pair? a) (eq? (car a) '@) #f)) content)) ; add an attributes list containing just a name to those without any attribute lists at all. (let* ( (lk-seed (reverse lk-seed)) (element (car lk-seed)) (body (cdr lk-seed))) (reverse `(,element (@ (name ,element-name)) ,@body))) lk-seed) lk-seed)) (else lk-seed)) lk-seed)) (define (render-forms-fhere path seed atom element-name) (if element-name (match `(,path ,seed) ((('name '@ element ...) ('name)) (if (interesting? (car element)) ; modify the name attributes of those that already have some kind of name. (cons (conc element-name "/" atom) seed) (cons atom seed))) (else (cons atom seed))) (cons atom seed))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ANCHOR DECORATION ;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define propagate-query-string (make-parameter #f)) (define (string->uri-path s) (let ((p (string-split s "/" #t))) (cond ((null? p) p) ((equal? '("") p) '()) ((string=? "" (car p)) (cons '/ (cdr p))) (else p)))) (define sre `(or ,(string->sre "^//.*") ,(string->sre "^[a-zA-Z][a-zA-Z+.-]*:.*") ,(string->sre "^#.*"))) (define (propagate-query-string-fup parent-path parent-seed lk-path lk-seed node query-string) ;(fprintf (current-error-port) "Now: <~A> <~A>\n" parent-path lk-seed) ;(fprintf (current-error-port) " : <~A>\n" `(,parent-path ,(reverse lk-seed))) (if (and query-string (not (any interesting? parent-path))) (let ((seed (reverse lk-seed))) (match `(,parent-path ,seed) ((('@ 'a _ ...) ('href path ...)) ;(fprintf (current-error-port) " Got: ~A ~A\n" parent-path lk-seed) ;(fprintf (current-error-port) " x: ~A\n" x) ;(fprintf (current-error-port) " y: ~A\n" y) ; grab the seed. reverse it. pop off href. ; concatenate the rest together into a string. turn it into a uri. ;(let ((uri (uri-reference (apply conc path))) ; ) ; (if (or #t (uri-scheme uri) ; (uri-host uri) (uri-port uri) ; (uri-username uri) (uri-password uri)) ; lk-seed ; (begin ; (assert (null? (uri-query uri))) ; (for-each (cut fprintf (current-error-port) "~A\n" <>) (list uri (update-uri uri query: `((,query-string))) ; (uri->string (update-uri uri query: `((,query-string)))) ; )) ; (reverse (list 'href (uri->string (update-uri uri query: `((,query-string)))))) ; ))) ; if it's relative then assert that it doesn't have a query string. add our query string. convert it back to a string. cons it onto href. return it as the new seed. (let ((uri (apply conc path))) (if (irregex-match sre uri) lk-seed (reverse (list 'href path (conc "?" query-string)))))) (else lk-seed))) lk-seed) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; SXML ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; A handy macro for debugging foldts ; (dbg-lambda ) #;(define-syntax dbg-lambda (ir-macro-transformer (lambda (expr inject compare) (assert (>= (length expr) 4)) (let ((proc-name (second expr)) (variables (third expr)) (expr (cdddr expr)) (r (gensym))) `(lambda ,variables (fprintf (current-error-port) ,(conc "{{{\n" (inject proc-name) ": " (string-intersperse (map (lambda (v) (conc (inject v) ": ~A")) variables) "\n ") "\n") ,@(map (lambda (v) `(with-output-to-string (lambda () (pp ,v)))) variables)) (let ((,r (begin ,@expr))) (fprintf (current-error-port) " -> ~A\n}}}\n\n" (with-output-to-string (lambda () (pp ,r)))) ,r)))))) (define-syntax dbg-lambda (ir-macro-transformer (lambda (expr inject compare) (assert (>= (length expr) 4)) `(lambda ,(third expr) ,@(cdddr expr))))) (define make-seed cons) (define path car) ; maintains a path of element names back up to the root of the tree (define data cdr) ; the actual seed (define ignore (gensym)) ; we put this value in the path to ensure that we don't mutate anything inside "interesting" elements. (define (interesting? element) (or (form-element? element) (widget? element))) (define (walk-rendering sxml bindings) (let* ((has-name (alist-ref 'name bindings)) ; Propagate the name to the children widgets (element-name (if has-name (car has-name) #f)) (propagate-query-string (propagate-query-string))) (if (or #t has-name propagate-query-string) ; don't do the work if there's nothing to do (data (foldts (dbg-lambda "fdown" (seed node) (define (path-proc seed node) (if (and (interesting? (car node)) (any interesting? seed)) ; if we're already in an interesting element then we don't want to mutate anything. (cons ignore seed) (cons (car node) seed))) (define (data-proc path seed node) (list (car node))) (make-seed (path-proc (path seed) node) (data-proc (path seed) (data seed) node))) (dbg-lambda "fup" (parent-seed lk-seed node) (define (path-proc parent-seed lk-seed node) parent-seed) (define (data-proc parent-path parent-seed lk-path lk-seed node) (if (any (lambda (p) (eqv? ignore p)) parent-path) ; don't mutate anything if we're in a subtree we want to ignore (cons node parent-seed) (let* ((lk-seed (render-forms-fup parent-path parent-seed lk-path lk-seed node element-name)) (lk-seed (propagate-query-string-fup parent-path parent-seed lk-path lk-seed node propagate-query-string))) (if (null? parent-seed) (reverse lk-seed) (cons (reverse lk-seed) parent-seed))))) (make-seed (path-proc (path parent-seed) (path lk-seed) node) (data-proc (path parent-seed) (data parent-seed) (path lk-seed) (data lk-seed) node))) (dbg-lambda "fhere" (seed atom) (define (path-proc seed atom) seed) (define (data-proc path seed atom) (if (any (lambda (p) (eqv? ignore p)) path) ; don't mutate anything if we're in a subtree we want to ignore ;'() (cons atom seed) ; if we have '() here then it causes string-only content of interesting elements to vanish. (render-forms-fhere path seed atom element-name))) (make-seed (path-proc (path seed) atom) (data-proc (path seed) (data seed) atom))) (make-seed '() '()) sxml)) sxml))) ; Takes an sxml subtree and encodes it as a string suitable for embedding in an ; area that is constained to PCDATA. For example, the body of a