diff options
Diffstat (limited to 'module/vcomponent/base.scm')
-rw-r--r-- | module/vcomponent/base.scm | 136 |
1 files changed, 95 insertions, 41 deletions
diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index fd8628f9..52bbe0c3 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -1,69 +1,123 @@ (define-module (vcomponent base) :use-module (util) :use-module (srfi srfi-1) + :use-module (srfi srfi-9) :use-module (srfi srfi-17) - :use-module (vcomponent primitive) - :use-module ((ice-9 optargs) :select (define*-public))) + :use-module (ice-9 hash-table) + :use-module ((ice-9 optargs) :select (define*-public)) + ) + + + +;; The <vline> type is a bit to many times refered to as a attr ptr. +(define-record-type <vline> + (make-vline% value parameters) + vline? + (value get-vline-value set-vline-value!) + (parameters get-vline-parameters)) + +(define*-public (make-vline value #:optional ht) + (make-vline% value (or ht (make-hash-table)))) + +(define-record-type <vcomponent> + (make-vcomponent% type children parent attributes) + vcomponent? + (type type) + (children children set-component-children!) + (parent get-component-parent set-component-parent!) + (attributes get-component-attributes)) +(export children type) + +;; TODO should this also update the parent +(define-public parent + (make-procedure-with-setter + get-component-parent set-component-parent!)) + +(define*-public (make-vcomponent #:optional (type 'VIRTUAL)) + (make-vcomponent% type '() #f (make-hash-table))) + +(define-public (add-child! parent child) + (set-component-children! parent (cons child (children parent))) + (set-component-parent! child parent)) -(define (get-attr component attr) - (%vcomponent-get-attribute - component - (as-string attr))) +(define* (get-attribute-value component key #:optional default) + (cond [(hashq-ref (get-component-attributes component) + key #f) + => get-vline-value] + [else default])) -(define (set-attr! component attr value) - (set! (car (get-attr component (as-string attr))) - value)) +(define (get-attribute component key) + (hashq-ref (get-component-attributes component) + key)) -(define-public value caar) +(define (set-attribute! component key value) + (let ((ht (get-component-attributes component))) + (cond [(hashq-ref ht key #f) + => (lambda (vline) (set-vline-value! vline value))] + [else (hashq-set! ht key (make-vline value))]))) -(define-public (values-left-count attr-list) - (length (take-while identity attr-list))) +(define-public (set-vline! component key vline) + (hashq-set! (get-component-attributes component) + key vline)) -(define-public (value-count attr-list) - (length (take-while identity (cdr (drop-while identity attr-list))))) + + +;; vline → value +(define-public value + (make-procedure-with-setter + get-vline-value set-vline-value!)) -(define-public attr* get-attr) +;; vcomponent x (or str symb) → vline +(define-public (attr* component attr) + (hashq-ref (get-component-attributes component) + (as-symb attr))) -(define (get-first c a) - (and=> (car (get-attr c a)) car)) +;; vcomponent x (or str symb) → value +(define (get-attr component key) + (get-attribute-value component (as-symb key) #f)) -(define (set-first! c a v) - (and=> (car (get-attr c a)) - (lambda (f) (set! (car f) v)))) +(define (set-attr! component key value) + (set-attribute! component (as-symb key) value)) (define-public attr (make-procedure-with-setter - get-first set-first!)) + get-attr + set-attr!)) (define-public prop (make-procedure-with-setter (lambda (attr-obj prop-key) - (hashq-ref (cdar attr-obj) prop-key)) + ;; TODO `list' is a hack since a bit to much code depends + ;; on prop always returning a list of values. + (and=> (hashq-ref (get-vline-parameters attr-obj) + (as-symb prop-key)) + list)) (lambda (attr-obj prop-key val) - (hashq-set! (cdar attr-obj) prop-key val)))) + (hashq-set! (get-vline-parameters attr-obj) + (as-symb prop-key) val)))) ;; Returns the properties of attribute as an assoc list. ;; @code{(map car <>)} leads to available properties. (define-public (properties attrptr) - (hash-map->list cons (cdar attrptr))) - -(define-public type (make-procedure-with-setter - %vcomponent-get-type - %vcomponent-set-type!)) -(define-public parent %vcomponent-parent) -(define-public push-child! %vcomponent-push-child!) -(define-public (attributes component) (map string->symbol (%vcomponent-attribute-list component))) - -(define*-public (children component #:optional only-type) - (let ((childs (%vcomponent-children component))) - (if only-type - (filter (lambda (e) (eq? only-type (type e))) childs) - childs))) - -(define-public copy-vcomponent %vcomponent-shallow-copy) - -(define-public filter-children! %vcomponent-filter-children!) + (hash-map->list cons (get-vline-parameters attrptr))) + +(define-public (attributes component) + (map car (hash-map->list cons (get-component-attributes component)))) + +(define (copy-vline vline) + (make-vline (get-vline-value vline) + ;; TODO deep-copy on properties? + (get-vline-parameters vline))) + +(define-public (copy-vcomponent component) + (make-vcomponent% (type component) + (children component) + (parent component) + ;; attributes + (alist->hashq-table + (hash-map->list (lambda (key value) (cons key (copy-vline value))) + (get-component-attributes component))))) (define-public (extract field) (lambda (e) (attr e field))) |