diff options
Diffstat (limited to 'module/vcomponent/create.scm')
| -rw-r--r-- | module/vcomponent/create.scm | 81 |
1 files changed, 59 insertions, 22 deletions
diff --git a/module/vcomponent/create.scm b/module/vcomponent/create.scm index ebf845fe..d332a2c2 100644 --- a/module/vcomponent/create.scm +++ b/module/vcomponent/create.scm @@ -6,9 +6,10 @@ :use-module (srfi srfi-17) :use-module (srfi srfi-71) :use-module (srfi srfi-88) - :use-module ((hnh util table) :select (alist->table)) + :use-module ((hnh util table) :select (alist->table table?)) :use-module ((hnh util) :select (swap init+last kvlist->assq ->)) :use-module (hnh util object) + :use-module (hnh util type) :export (with-parameters as-list vcomponent @@ -16,8 +17,6 @@ vtimezone standard daylight )) -;; TODO allow parameters and list values at same time - ;; Convert a scheme keyword to a symbol suitable for us @@ -41,22 +40,34 @@ -(define (with-parameters . args) - (define-values (parameters value) - (init+last args)) - (vline - key: 'PLACEHOLDER - vline-value: value - vline-parameters: - (-> parameters - kvlist->assq - upcase-keys - alist->table))) +(define (kvlist->parameter-table kvs) + (-> kvs kvlist->assq upcase-keys alist->table)) + +(define-type (parameterized) + parameterized:value + (parameterized:parameters type: table?)) + +;;; This is implemented as a macro, with an external typecheck, due to +;;; how *when* Guile interprets different things. The check for list-value? +;;; fails since Guile thinks it's a syntax deffinition at this point. +;;; This setup waits with actually looking up list-value?, meaning that the +;;; symbol is a procedure when the code is actually ran. +(define-syntax with-parameters + (syntax-rules () + ((_ kvs ... value) + (begin + (typecheck value (not (or list-value? + parameterized? + vline?))) + (parameterized + parameterized:value: value + parameterized:parameters: (kvlist->parameter-table (list kvs ...))))))) + (define-type (list-value) - (list-value-value)) + (list-value-value type: (list-of (not list-value?)))) (define (as-list arg) (list-value list-value-value: arg)) @@ -64,20 +75,46 @@ (define (vcomponent type . attrs*) + ;; Split the subforms into attributes and children (define-values (attrs children) (cond ((null? attrs*) (values '() '())) ((even? (length attrs*)) (values attrs* '())) (else (init+last attrs*)))) + (define (value->vline key value) + (cond + ((vline? value) + (scm-error 'misc-error "vcomponent" + "Explicit VLines should never appear when creating components: ~s" + (list value) #f)) + + ((list-value? value) + (scm-error 'misc-error "vcomponent" + "As-list can only be used at top level. key: ~s, value: ~s" + (list key value) #f)) + + ((parameterized? value) + (vline key: key + vline-value: (parameterized:value value) + vline-parameters: (parameterized:parameters value))) + + ;; A raw value was given, embed it into a vline + (else (vline key: key vline-value: value)))) + + ;; For a given (symbol, value) pair, attach it to the given component (define (attach-property pair component) (let ((k value (car+cdr pair))) - (prop* component k - (cond ((vline? value) - (key value k)) - ((list-value? value) - (map (lambda (value) (vline key: k vline-value: value)) - (list-value-value value))) - (else (vline key: k vline-value: value)))))) + (cond + ((and (list-value? value) (null? (list-value-value value))) + component) + + ((list-value? value) + (prop* component k + (map (lambda (v) (value->vline k v)) + (list-value-value value)))) + + (else + (prop* component k (value->vline k value)))))) ;; TODO add-child requires a UID on the child ;; Possibly just genenerate one here if missing |