From 785f70a3d16e549e36b8ef17f081829fe492a193 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 3 Oct 2019 22:02:03 +0200 Subject: Locate bug with DTEND. --- module/main.scm | 4 ++- module/util.scm | 9 +++++- module/vcomponent.scm | 37 ++++++++++++++-------- module/vcomponent/base.scm | 77 +++++++++++++++++++++++++++++++--------------- src/parse.c | 12 +++++++- 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 -- cgit v1.2.3