Move stuff between vcomponent/{base,parse}.

2 files changed, 116 insertions, 115 deletions

diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm
index 60a27f94..52bbe0c3 100644
--- a/module/vcomponent/base.scm
+++ b/module/vcomponent/base.scm
@@ -1,23 +1,66 @@
 (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 parse)
   :use-module (ice-9 hash-table)
   :use-module ((ice-9 optargs) :select (define*-public))
-  :re-export (add-child! make-vcomponent))
-
-(define-public (parse-cal-path path)
-  (let ((parent (make-vcomponent)))
-    (for-each (lambda (child) (add-child! parent child))
-              (read-vcalendar path))
-    (set-attribute!
-     parent 'X-HNH-SOURCETYPE
-     (if (null? (get-component-children parent))
-         "vdir"
-         (get-attribute-value (car (get-component-children parent))
-                              'X-HNH-SOURCETYPE "vdir")))
-    parent))
+  )
+
+
+
+;; 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-attribute-value component key #:optional default)
+  (cond [(hashq-ref (get-component-attributes component)
+                    key #f)
+         => get-vline-value]
+        [else default]))
+
+(define (get-attribute component key)
+  (hashq-ref (get-component-attributes component)
+             key))
+
+(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 (set-vline! component key vline)
+  (hashq-set! (get-component-attributes component)
+              key vline))
+
+
 
 ;; vline → value
 (define-public value
@@ -57,30 +100,20 @@
 ;; Returns the properties of attribute as an assoc list.
 ;; @code{(map car <>)} leads to available properties.
 (define-public (properties attrptr)
-  (hash-map->list cons (get-attribute-parameters attrptr)))
-
-(define-public type (make-procedure-with-setter
-                     (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 get-component-parent)
+  (hash-map->list cons (get-vline-parameters attrptr)))
 
 (define-public (attributes component)
   (map car (hash-map->list cons (get-component-attributes component))))
 
-(define*-public children get-component-children)
-
 (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% (component-type component)
-                    (get-component-children component)
-                    (get-component-parent component)
+  (make-vcomponent% (type component)
+                    (children component)
+                    (parent component)
                     ;; attributes
                     (alist->hashq-table
                      (hash-map->list (lambda (key value) (cons key (copy-vline value)))
diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm
index 46a256a1..40e5a141 100644
--- a/module/vcomponent/parse.scm
+++ b/module/vcomponent/parse.scm
@@ -1,83 +1,16 @@
-
 (define-module (vcomponent parse)
   :use-module (rnrs io ports)
   :use-module (rnrs bytevectors)
   :use-module (srfi srfi-9)
   :use-module ((ice-9 rdelim) :select (read-line))
   :use-module ((ice-9 textual-ports) :select (unget-char))
-  :use-module ((ice-9 ftw) :select (scandir ftw)))
-
-
+  :use-module ((ice-9 ftw) :select (scandir ftw))
 
-(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?
-  (type component-type)
-  (children get-component-children set-component-children!)
-  (parent get-component-parent set-component-parent!)
-  (attributes get-component-attributes))
-
-(define* (make-vcomponent #:optional (type 'VIRTUAL))
-  (make-vcomponent% type '() #f (make-hash-table #x10)))
-
-(define (add-child! parent child)
-  (set-component-children! parent (cons child (get-component-children parent)))
-  (set-component-parent! child parent))
-
-(define* (get-attribute-value component key #:optional default)
-  (cond [(hashq-ref (get-component-attributes component)
-                    key #f)
-         => get-vline-value]
-        [else default]))
-
-(define (get-attribute component key)
-  (hashq-ref (get-component-attributes component)
-             key))
-
-(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 (set-vline! component key vline)
-  (hashq-set! (get-component-attributes component)
-              key vline))
+  :use-module (util)
+  :use-module (vcomponent base)
 
-
-
-(define-record-type <parse-ctx>
-  (make-parse-ctx% filename row col ctx line-key param-key param-table)
-  parse-ctx?
-  (filename get-filename)               ; string
-  (row get-row set-row!)                ; [0, ]
-  (col get-col set-col!)                ; [1, )
-  (ctx get-ctx set-ctx!)                ; '(key value param-name param-value escape)
-  (line-key get-line-key set-line-key!) ; string
-  (param-key get-param-key set-param-key!)       ; string
-  (param-table get-param-table set-param-table!) ; hash-map
   )
 
-(define (make-parse-ctx filename)
-  (make-parse-ctx% filename 1 0 'key
-                   #f #f (make-hash-table)))
-
-(define (increment-column! ctx)
-  (set-col! ctx (1+ (get-col ctx))))
-
-(define (increment-row! ctx)
-  (set-col! ctx 0)
-  (set-row! ctx (1+ (get-row ctx))))
-
 
 
 (define-record-type <strbuf>
@@ -119,6 +52,31 @@
 
 
 
+(define-record-type <parse-ctx>
+  (make-parse-ctx% filename row col ctx line-key param-key param-table)
+  parse-ctx?
+  (filename get-filename)               ; string
+  (row get-row set-row!)                ; [0, ]
+  (col get-col set-col!)                ; [1, )
+  (ctx get-ctx set-ctx!)                ; '(key value param-name param-value escape)
+  (line-key get-line-key set-line-key!) ; string
+  (param-key get-param-key set-param-key!)       ; string
+  (param-table get-param-table set-param-table!) ; hash-map
+  )
+
+(define (make-parse-ctx filename)
+  (make-parse-ctx% filename 1 0 'key
+                   #f #f (make-hash-table)))
+
+(define (increment-column! ctx)
+  (set-col! ctx (1+ (get-col ctx))))
+
+(define (increment-row! ctx)
+  (set-col! ctx 0)
+  (set-row! ctx (1+ (get-row ctx))))
+
+
+
 (define (fold-proc ctx c)
   ;; First extra character optionall read is to get the \n if our line
   ;; ended with \r\n. Secound read is to get the first character of the
@@ -160,8 +118,8 @@
         (with-throw-handler #t
           (lambda ()
 
-            (set-attribute! component 'X-HNH-FILENAME
-                            (get-filename ctx))
+            (set! (attr component 'X-HNH-FILENAME)
+              (get-filename ctx))
 
             (while #t
               (let ((c (get-u8 (current-input-port))))
@@ -175,12 +133,11 @@
                   ;; the setup at creation this shouldn't be a problem.
                   (break (case (get-ctx ctx)
                            [(key)             ; line ended
-                            (let ((root-component
-                                   (car (get-component-children component))))
-                              (set-component-parent! root-component #f)
+                            (let ((root-component (car (children component))))
+                              (set! (parent root-component) #f)
                               root-component)]
                            [(value)           ; still ending line
-                            (set-component-parent! component #f)
+                            (set! (parent component) #f)
                             component]
                            [else => (lambda (a)
                                       (scm-error 'wrong-type-arg "parse-break"
@@ -198,16 +155,17 @@
                               (let ((child (make-vcomponent (string->symbol str))))
                                 ;; TOOD remove this copying of attributes!!!
                                 (for-each (lambda (pair)
-                                            (set-attribute! child
-                                                            (car pair)
-                                                            (cdr pair)))
+                                            (set! (attr child (car pair))
+                                              (cdr pair)))
                                           (hash-map->list
-                                           cons (get-component-attributes component)))
+                                           cons ((@@ (vcomponent base)
+                                                     get-component-attributes)
+                                                 component)))
                                 (add-child! component child)
                                 (set! component child))]
 
                              [(eq? (get-line-key ctx) 'END)
-                              (set! component (get-component-parent component))]
+                              (set! component (parent component))]
 
                              [else
                               ;; TODO repeated keys
@@ -287,7 +245,7 @@ row ~a	column ~a	ctx = ~a
   (define st (stat path))
   (case (stat:type st)
     [(regular) (let ((comp (call-with-input-file path parse-calendar)))
-                 (set-attribute! comp 'X-HNH-SOURCETYPE "file")
+                 (set! (attribute comp 'X-HNH-SOURCETYPE) "file")
                  (list comp))]
     [(directory)
 
@@ -305,8 +263,8 @@ row ~a	column ~a	ctx = ~a
                 (let ((fullname (/ path fname)))
                   (let ((cal (call-with-input-file fullname
                                parse-calendar)))
-                    (set-attribute! cal 'COLOR color)
-                    (set-attribute! cal 'NAME name)
+                    (set! (attr cal 'COLOR) color
+                          (attr cal 'NAME) name)
                     cal)))
               (scandir path (lambda (s) (and (not (string= "." (string-take s 1)))
                                         (string= "ics" (string-take-right s 3))))))))]
@@ -314,6 +272,19 @@ row ~a	column ~a	ctx = ~a
      => (lambda (t) (error "Can't parse file of type " t))]))
 
 
+(define-public (parse-cal-path path)
+  (let ((parent (make-vcomponent)))
+    (for-each (lambda (child) (add-child! parent child))
+              (read-vcalendar path))
+    (set! (attr parent 'X-HNH-SOURCETYPE)
+      (if (null? (children parent))
+          "vdir"
+          (or (attr (car (children parent))
+                    'X-HNH-SOURCETYPE)
+              "vdir")))
+    parent))
+
+
 (define-public (read-tree path)
   (define list '())
   (ftw path
@@ -332,6 +303,3 @@ 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)