diff options
| -rw-r--r-- | module/vcomponent.scm | 5 | ||||
| -rw-r--r-- | module/vcomponent/base.scm | 86 | ||||
| -rw-r--r-- | module/vcomponent/parse.scm (renamed from src/parse.scm) | 63 | ||||
| -rw-r--r-- | module/vcomponent/primitive.scm | 9 |
4 files changed, 97 insertions, 66 deletions
diff --git a/module/vcomponent.scm b/module/vcomponent.scm index 8751440d..d3e574b5 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -1,7 +1,4 @@ (define-module (vcomponent) - #:use-module ((vcomponent primitive) - :select (parse-cal-path - (make-vcomponent . primitive-make-vcomponent))) #:use-module (vcomponent datetime) #:use-module (vcomponent recurrence) #:use-module (vcomponent timezone) @@ -124,7 +121,7 @@ ;; return accum)) - ((no-type) (throw 'no-type))))) + ((no-type) (error 'no-type))))) (parse-dates! component) diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index 98b2aa89..f43f532e 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -2,33 +2,43 @@ :use-module (util) :use-module (srfi srfi-1) :use-module (srfi srfi-17) - :use-module (vcomponent primitive) + :use-module ((vcomponent parse) + :renamer (lambda (symb) + (case symb + ;; [(set-attribute!) 'get-attribute] + [(make-vcomponent) 'primitive-make-vcomponent] + [else symb]))) :use-module (ice-9 hash-table) :use-module ((ice-9 optargs) :select (define*-public)) - :re-export (add-child!)) + :re-export (add-child! primitive-make-vcomponent)) + +(define-public (parse-cal-path path) + (let ((parent (primitive-make-vcomponent))) + (for-each (lambda (child) (add-child! parent child)) + (read-vcalendar path)) + (if (null? (get-component-children parent)) + (set-attribute! parent 'X-HNH-SOURCETYPE "vdir") + (set-attribute! parent 'X-HNH-SOURCETYPE + (get-attribute-value (car (get-component-children parent)) + 'X-HNH-SOURCETYPE "vdir"))) + parent)) ;; vline → value (define-public value (make-procedure-with-setter - (lambda (vline) (struct-ref vline 0)) - (lambda (vline value) (struct-set! vline 0 value)))) + get-vline-value set-vline-value!)) ;; vcomponent x (or str symb) → vline (define-public (attr* component attr) - (hash-ref (struct-ref component 3) - (as-string attr))) + (hashq-ref (get-component-attributes component) + (as-symb attr))) ;; vcomponent x (or str symb) → value -(define (get-attr component attr) - (and=> (attr* component attr) - value)) +(define (get-attr component key) + (get-attribute-value component (as-symb key) #f)) -(define (set-attr! component attr value) - (aif (attr* component attr) - (struct-set! it 0 value) - (hash-set! (struct-ref component 3) - (as-string attr) - (make-vline value)))) +(define (set-attr! component key value) + (set-attribute! component (as-symb key) value)) (define-public attr (make-procedure-with-setter @@ -39,42 +49,46 @@ (define-public prop (make-procedure-with-setter (lambda (attr-obj prop-key) - (hash-ref (struct-ref attr-obj 1) (as-string 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) - (hash-set! (struct-ref attr-obj 1) (as-string 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 (struct-ref attrptr 1))) + (hash-map->list cons (get-attribute-parameters attrptr))) (define-public type (make-procedure-with-setter - (lambda (c) (struct-ref c 0)) - (lambda (c v) struct-set! c 0 v) - )) + (lambda (c) (component-type c)) + (lambda (c v) ; struct-set! c 0 v + (format (current-error-port) + "This method is a deprecated NOOP")))) -(define-public (parent c) (struct-ref c 2)) +(define-public parent get-component-parent) (define-public (attributes component) - (hash-map->list cons (struct-ref component 3))) + (hash-map->list cons (get-component-attributes component))) -(define*-public (children component) - (struct-ref component 1)) +(define*-public children get-component-children) (define (copy-vline vline) - (make-struct/no-tail (struct-vtable vline) - (struct-ref vline 0) - ;; TODO deep-copy on properties? - (struct-ref vline 1))) + (make-vline (get-vline-value vline) + ;; TODO deep-copy on properties? + (get-vline-parameters vline))) (define-public (copy-vcomponent component) - (make-struct/no-tail (struct-vtable component) - (struct-ref component 0) - (struct-ref component 1) - (struct-ref component 2) - (alist->hash-table - (hash-map->list (lambda (key value) (cons key (copy-vline value))) - (struct-ref component 3))))) + (make-vcomponent% (component-type component) + (get-component-children component) + (get-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))) diff --git a/src/parse.scm b/module/vcomponent/parse.scm index b11240df..9eabacb3 100644 --- a/src/parse.scm +++ b/module/vcomponent/parse.scm @@ -1,5 +1,5 @@ -(define-module (parse) +(define-module (vcomponent parse) :use-module (rnrs io ports) :use-module (rnrs bytevectors) :use-module (srfi srfi-9) @@ -8,6 +8,15 @@ +(define-record-type <vline> + (make-vline% value parameters) + vline? + (value get-vline-value set-vline-value!) + (parameters get-vline-parameters)) + +(define* (make-vline value #:optional ht) + (make-vline% value (or ht (make-hash-table)))) + (define-record-type <vcomponent> (make-vcomponent% type children parent attributes) vcomponent? @@ -26,7 +35,7 @@ (define* (get-attribute-value component key #:optional default) (cond [(hashq-ref (get-component-attributes component) key #f) - => cdr] + => get-vline-value] [else default])) (define (get-attribute component key) @@ -36,8 +45,12 @@ (define (set-attribute! component key value) (let ((ht (get-component-attributes component))) (cond [(hashq-ref ht key #f) - => (lambda (pair) (set-cdr! pair value))] - [else (hashq-set! ht key (cons (make-hash-table) value))]))) + => (lambda (vline) (set-vline-value! vline value))] + [else (hashq-set! ht key (make-vline value))]))) + +(define (set-vline! component key vline) + (hashq-set! (get-component-attributes component) + key vline)) @@ -145,6 +158,10 @@ (strbuf (make-strbuf))) (with-throw-handler #t (lambda () + + (set-attribute! component 'X-HNH-FILENAME + (get-filename ctx)) + (while #t (let ((c (get-u8 (current-input-port)))) (cond @@ -176,21 +193,26 @@ (case (fold-proc ctx c) [(end-of-line) (let ((str (strbuf->string strbuf))) - (cond [(string=? (get-line-key ctx) "BEGIN") + (cond [(eq? (get-line-key ctx) 'BEGIN) (let ((child (make-vcomponent (string->symbol str)))) + ;; TOOD remove this copying of attributes!!! + (for-each (lambda (pair) + (set-attribute! child + (car pair) + (cdr pair))) + (hash-map->list + cons (get-component-attributes component))) (add-child! component child) (set! component child))] - [(string=? (get-line-key ctx) "END") + [(eq? (get-line-key ctx) 'END) (set! component (get-component-parent component))] [else - (let ((ht (get-component-attributes component))) - ;; TODO repeated keys - (hashq-set! ht (string->symbol (get-line-key ctx)) - (cons (get-param-table ctx) - str)) - (set-param-table! ctx (make-hash-table)))]) + ;; TODO repeated keys + (set-vline! component (get-line-key ctx) + (make-vline str (get-param-table ctx))) + (set-param-table! ctx (make-hash-table))]) (strbuf-reset! strbuf) (set-ctx! ctx 'key))] @@ -219,14 +241,16 @@ (increment-column! ctx)] ;; Delimiter between param key and param value - [(and (eq? (get-ctx ctx) 'panam-name) (char=? #\= (integer->char c))) - (set-param-key! ctx (strbuf->string strbuf)) + [(and (eq? (get-ctx ctx) 'param-name) + (char=? #\= (integer->char c))) + (set-param-key! ctx (string->symbol (strbuf->string strbuf))) (strbuf-reset! strbuf) (set-ctx! ctx 'param-value)] ;; Delimiter between parameters (;), or between ;; "something" and attribute value (:) - [(memv (integer->char c) '(#\: #\;)) + [(and (memv (integer->char c) '(#\: #\;)) + (memv (get-ctx ctx) '(param-value key))) (case (get-ctx ctx) [(param-value) (hashq-set! (get-param-table ctx) @@ -234,7 +258,7 @@ (strbuf->string strbuf)) (strbuf-reset! strbuf)] [(key) - (set-line-key! ctx (strbuf->string strbuf)) + (set-line-key! ctx (string->symbol (strbuf->string strbuf))) (strbuf-reset! strbuf)]) (set-ctx! ctx (case (integer->char c) @@ -261,7 +285,9 @@ row ~a column ~a ctx = ~a (define-public (read-vcalendar path) (define st (stat path)) (case (stat:type st) - [(regular) (list (call-with-input-file path parse-calendar))] + [(regular) (let ((comp (call-with-input-file path parse-calendar))) + (set-attribute! comp 'X-HNH-SOURCETYPE "file") + (list comp))] [(directory) (map (lambda (fname) (call-with-input-file @@ -291,3 +317,6 @@ row ~a column ~a ctx = ~a ((@ (ice-9 threads) n-par-map) 12 (lambda (fname) (call-with-input-file fname parse-calendar)) list)) + + +(export add-child! make-vcomponent get-vline-value set-vline-value! get-component-parent get-component-children get-attribute-value set-attribute! get-component-attributes component-type make-vcomponent% make-vline get-vline-parameters) diff --git a/module/vcomponent/primitive.scm b/module/vcomponent/primitive.scm deleted file mode 100644 index 5fef08cc..00000000 --- a/module/vcomponent/primitive.scm +++ /dev/null @@ -1,9 +0,0 @@ -;;; Primitive export of symbols linked from C binary. - -(define-module (vcomponent primitive) - #:export (make-vcomponent - add-line! add-child! - make-vline add-attribute! - parse-cal-path)) - -(load-extension "libguile-calendar" "init_lib") |