Locate bug with DTEND.

5 files changed, 100 insertions, 39 deletions

diff --git a/module/main.scm b/module/main.scm
index 4e75bbf9..2b0fde23 100755
--- a/module/main.scm
+++ b/module/main.scm
@@ -46,7 +46,9 @@ exec guile -e main -s $0 "$@"
 ;; Given as a sepparate function from main to ease debugging.
 (define* (init proc #:key (calendar-files (calendar-files)))
   (define calendars (map make-vcomponent calendar-files))
-  (define events (concatenate (map (cut children <> 'VEVENT) calendars)))
+  (define events (concatenate (map (lambda (cal) (filter (lambda (o) (eq? 'VEVENT (type o)))
+                                                    (children cal)))
+                                   calendars)))
 
   (let* ((repeating regular (partition repeating? events)))
 
diff --git a/module/util.scm b/module/util.scm
index 89f6dab6..6aadbc79 100644
--- a/module/util.scm
+++ b/module/util.scm
@@ -11,7 +11,7 @@
                 quote?
                 re-export-modules
                 use-modules*
-                -> set
+                -> set aif
                 tree-map let-lazy)
   #:replace (let* set! define-syntax
                   when unless if))
@@ -44,6 +44,13 @@
     ((@ (guile) if) p t
      (begin f ...))]))
 
+(define-syntax aif
+  (lambda (stx)
+    (syntax-case stx ()
+      [(_ condition true-clause false-clause)
+       (with-syntax ((it (datum->syntax stx 'it)))
+         #'(let ((it condition))
+             (if it true-clause false-clause)))])))
 
 
 (define-public upstring->symbol (compose string->symbol string-upcase))
diff --git a/module/vcomponent.scm b/module/vcomponent.scm
index 93449c4b..c2e65d19 100644
--- a/module/vcomponent.scm
+++ b/module/vcomponent.scm
@@ -1,5 +1,5 @@
 (define-module (vcomponent)
-  #:use-module ((vcomponent primitive) :select (parse-cal-path make-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)
@@ -26,7 +26,9 @@
 (define (parse-dates! cal)
   "Parse all start times into scheme date objects."
 
-  (for tz in (children cal 'VTIMEZONE)
+  (for tz in (filter (lambda (o) (eq? 'VTIMEZONE (type o))) (children cal))
+       (format #t "TZ = ~a~%" tz)
+
        (for-each (lambda (p) (mod! (attr p "DTSTART") string->time-utc))
                  (children tz))
 
@@ -40,15 +42,24 @@
                (cadr (children tz))))
              ))
 
-  (for ev in (children cal 'VEVENT)
+  (for ev in (filter (lambda (o) (eq? 'VEVENT (type o))) (children cal))
        (define dptr (attr* ev 'DTSTART))
        (define eptr (attr* ev 'DTEND))
 
-       (define date     (parse-datetime (value dptr)))
+       (define date (parse-datetime (value dptr)))
        (define end-date
-         (if (value eptr)
-             (parse-datetime (value eptr))
-             (set (date-hour date) = (+ 1))))
+         (begin (format #t "end-date, file = ~a~%" (attr ev 'X-HNH-FILENAME))
+                ;; It's here it crashes!
+                ;; (value eptr)
+                ;; /home/hugo/.local/var/cal/lithekod_styrelse/9cd19ed2ac0f68f68c405010e43bcf3a5fd6ca01e8f2e0ccf909a0f2fa96532f.ics
+                ;; An object apparently doesn't need to have a DTEND...
+          (aif (value eptr)
+               (parse-datetime it)
+               (set (date-hour date) = (+ 1)))))
+
+       (format #t "ev = ~a~%file = ~a~%" ev (attr ev 'X-HNH-FILENAME))
+
+       ;; (format #t "ev = ~a~%file = ~a~%" ev (attr ev 'X-HNH-FILENAME))
 
        (set! (value dptr) (date->time-utc date)
              (value eptr) (date->time-utc end-date))
@@ -78,10 +89,9 @@
 ;;   (make-procedure-with-setter car set-car!))
 
 
-
 (define* (make-vcomponent #:optional path)
   (if (not path)
-      (make-vcomponent)
+      (primitive-make-vcomponent)
       (let ((root (parse-cal-path path)))
         (format #t "root = ~a~%" root )
         (let* ((component
@@ -102,14 +112,16 @@
                         ;; TODO the other VCALENDAR components might not get thrown away,
                         ;; this since I protect them from the GC in the C code.
                         ((vdir)
-                         (let ((accum (make-vcomponent))
+                         (let ((accum (primitive-make-vcomponent 'VCALENDAR))
                                (ch (children root)))
-                           (set! (type accum) "VCALENDAR")
 
+                           ;; What does this even do?
                            (unless (null? ch)
+                             (format #t "Looping over attributes~%")
                              (for key in (attributes (car ch))
                                   (set! (attr accum key) (attr (car ch) key))))
 
+                           (format #t "Looping over children, again")
                            (for cal in ch
                                 (for component in (children cal)
                                      (case (type component)
@@ -117,7 +129,7 @@
                                         (unless (find (lambda (z)
                                                         (string=? (attr z "TZID")
                                                                   (attr component "TZID")))
-                                                      (children accum 'VTIMEZONE))
+                                                      (filter (lambda (o) (eq? 'VTIMEZONE (type o))) (children accum)))
                                           (push-child! accum component)))
                                        (else (push-child! accum component)))))
                            ;; return
@@ -127,6 +139,7 @@
 
                 (display "Here?\n")
                 (parse-dates! component)
+                (display "Theren")
 
                 (unless (attr component "NAME")
                   (set! (attr component "NAME")
diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm
index 395c2d9c..986037f5 100644
--- a/module/vcomponent/base.scm
+++ b/module/vcomponent/base.scm
@@ -5,22 +5,49 @@
   :use-module (vcomponent primitive)
   :use-module ((ice-9 optargs) :select (define*-public)))
 
+;; (define og-struct-ref struct-ref)
+;; (define (struct-ref struct field)
+;;   (format #t "struct = ~a, field = ~a~%" struct field)
+;;   (og-struct-ref struct field))
+
+(use-modules (system vm trap-state))
+
+(install-trap-handler! (lambda args (format #t "args = ~a~%" args)))
+
+(add-trace-at-procedure-call! struct-ref)
+(add-trap-at-procedure-call! struct-ref)
+
+;; vline → value
+(define-public value
+  (make-procedure-with-setter
+   (lambda (vline) (struct-ref vline 0))
+   (lambda (vline value) (struct-set! vline 0 value))))
+
+;; vcomponent x (or str symb) → vline
+(define-public (attr* component attr)
+  (hash-ref (struct-ref component 3)
+            (as-string attr)))
+
+;; vcomponent x (or str symb) → value
 (define (get-attr component attr)
-  (and=> (hash-ref (struct-ref component 3)
-                   (as-string attr))
-         (lambda (l) (struct-ref l 0)))
-  #;
-  (%vcomponent-get-attribute
-   component
-   (as-string attr)))
+  (and=> (attr* component attr)
+         value))
 
 (define (set-attr! component attr value)
-  'noop
-  #;
-  (set! (car (get-attr component (as-string attr)))
-        value))
+  (format #t "attr = ~a~%" attr)
+  (aif (attr* component attr)
+       (begin (format #t "Existed~%") (struct-set! it 0 value))
+       (begin (format #t "Creating, component = ~a, attr = ~a, value = ~a~%" component attr value)
+              (format #t "map = ~a~%" (struct-ref component 3))
+              (let ((return (hash-set! (struct-ref component 3)
+                                (as-string attr)
+                                value)))
+
+                (format #t "Return = ~a~%" return)
+                return
+                )
 
-;; (define-public value caar)
+              )))
 
 ;; (define-public (values-left-count attr-list)
 ;;   (length (take-while identity attr-list)))
@@ -28,8 +55,6 @@
 ;; (define-public (value-count attr-list)
 ;;   (length (take-while identity (cdr (drop-while identity attr-list)))))
 
-(define-public attr* get-attr)
-
 ;; (define (get-first c a)
 ;;   (and=> (car (get-attr c a)) car))
 
@@ -48,32 +73,36 @@
 (define-public prop
   (make-procedure-with-setter
    (lambda (attr-obj prop-key)
-     (hashq-ref (cdar attr-obj) prop-key))
+     (hashq-ref (struct-ref attr-obj 1) prop-key))
    (lambda (attr-obj prop-key val)
-     (hashq-set! (cdar attr-obj) prop-key val))))
+     (hashq-set! (struct-ref attr-obj 1) 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)))
+  (hash-map->list cons (struct-ref attrptr 1)))
 
 (define-public type (make-procedure-with-setter
                      (lambda (c) (struct-ref c 0))
                      (lambda (c v) struct-set! c 0 v)
                     ))
+
 (define-public (parent c) (struct-ref c 2))
 (define-public push-child! add-child!)
-(define-public (attributes component) '("noop")
+(define-public (attributes component)
+  (hash-map->list cons (struct-ref component 3))
   #; (map string->symbol (%vcomponent-attribute-list component))
   )
 
-(define*-public (children component #:optional only-type)
-  (let ((childs (struct-ref component 1)))
-    (if only-type
-        (filter (lambda (e) (eq? only-type (type e))) childs)
-        childs)))
+(define*-public (children component)
+  (struct-ref component 1))
 
-;; (define-public copy-vcomponent %vcomponent-shallow-copy)
+(define-public (copy-vcomponent component)
+  (make-struct/no-tail (struct-vtable component)
+                       (struct-ref component 0)
+                       (struct-ref component 1)
+                       (struct-ref component 2)
+                       (struct-ref component 3)))
 
 ;; (define-public filter-children! %vcomponent-filter-children!)
 
diff --git a/src/parse.c b/src/parse.c
index 06d8707c..48b58b95 100644
--- a/src/parse.c
+++ b/src/parse.c
@@ -94,6 +94,16 @@ int parse_file(char* filename, FILE* f, SCM root) {
 					INFO("Creating child");
 					SCM child = scm_make_vcomponent(scm_string_to_symbol(scm_from_strbuf(&str)));
 					scm_add_child_x (component, child);
+
+					/* TODO it should be possible to create this object once
+					   at the top of this function
+					 */
+					SCM templine = scm_make_vline();
+					scm_struct_set_x(templine, vline_value,
+					                 scm_from_utf8_stringn(filename, strlen(filename)));
+					scm_add_line_x(child, scm_from_utf8_string("X-HNH-FILENAME"),
+					               templine);
+
 					component = child;
 
 				} else if (string_eq(line_key, scm_from_utf8_string("END"))) {
@@ -195,7 +205,7 @@ int parse_file(char* filename, FILE* f, SCM root) {
 		 * end with CRLF. My files however does not, so we also parse
 		 * the end here.
 		 */
-		ERR("Not implemented");
+		ERR("Handling of missing trailing endline not reimplemented.");
 
 		// TRANSFER(CLINE_CUR_VAL(&cline), &ctx.str);
 		// TODO