Use module-introspection more.

3 files changed, 138 insertions, 16 deletions

diff --git a/scripts/all-modules.scm b/scripts/all-modules.scm
index ad6d3b72..b83644e5 100644
--- a/scripts/all-modules.scm
+++ b/scripts/all-modules.scm
@@ -4,6 +4,7 @@
   :use-module (ice-9 ftw)
   :use-module (ice-9 match)
   :use-module (hnh util path)
+  :use-module (module-introspection)
   :export (all-files-and-modules-under-directory
            all-modules-under-directory
            fs-find-base fs-find))
@@ -29,10 +30,8 @@
 
   (map (lambda (file)
          (list file
-               (match (call-with-input-file file read)
-                 (('define-module (module ...) _ ...)
-                  module)
-                 (_ #f))))
+               (call-with-input-file file
+                 (compose find-module-declaration get-forms))))
        files))
 
 (define (all-modules-under-directory dir)
diff --git a/scripts/generate-test-data.scm b/scripts/generate-test-data.scm
new file mode 100755
index 00000000..076558e4
--- /dev/null
+++ b/scripts/generate-test-data.scm
@@ -0,0 +1,119 @@
+#!/usr/bin/guile \
+-e main -s
+!#
+(add-to-load-path (string-append (dirname (dirname (current-filename))) "/module"))
+
+(use-modules (vcomponent)
+             ((vcomponent recurrence parse) :select (parse-recurrence-rule))
+             ((vcomponent formats xcal output) :select (vcomponent->sxcal ns-wrap))
+             ((vcomponent formats ical output) :select (component->ical-string))
+             (vcomponent datetime)
+             (datetime)
+             ((datetime instance) :select (zoneinfo))
+             (hnh util)
+             (hnh util uuid)
+             (ice-9 format)
+             (ice-9 popen)
+             (ice-9 threads)
+             ((srfi srfi-88) :select (keyword->string))
+             (sxml simple)
+             )
+
+(define (vevent . rest)
+  (define v (make-vcomponent 'VEVENT))
+
+  (let loop ((rem rest))
+    (unless (null? rem)
+      (let ((symb (-> (car rem)
+                      keyword->string
+                      string-upcase
+                      string->symbol)))
+        (set! (prop v symb)
+          (case symb
+            ;; [(DTSTART EXDATE) (parse-ics-datetime (cadr rem))]
+            [(RRULE) (parse-recurrence-rule (cadr rem))]
+            [else (cadr rem)]))
+        ;; hack for multi valued fields
+        (when (eq? symb 'EXDATE)
+          (set! (prop* v symb) = list)))
+      (loop (cddr rem))))
+
+  v)
+
+(define ev
+  (vevent
+    summary: "Test Event #1"
+    uid: (uuid)
+    dtstart: #2021-12-21T10:30:00
+    dtend: #2021-12-21T11:45:00
+    dtstamp: (current-datetime)
+    ))
+
+(set!
+  (param (prop* ev 'DTSTART) 'TZID) "Europe/Stockholm"
+  (param (prop* ev 'DTEND)   'TZID) "Europe/Stockholm")
+
+(define zoneinfo
+  (zoneinfo->vtimezone (zoneinfo '("tzdata/europe"))
+                       "Europe/Stockholm" ev))
+
+(define cal (make-vcomponent 'VCALENDAR))
+
+(set!
+  (prop cal 'PRODID) "-//hugo//calp TEST//EN"
+  (prop cal 'VERSION) "2.0")
+
+(add-child! cal zoneinfo)
+(add-child! cal ev)
+
+(define sxcal
+  `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"")
+          ,(ns-wrap (vcomponent->sxcal cal))))
+
+(define (main args)
+  (for-each (lambda (fmt)
+              (define parts (map string->symbol (string-split fmt #\:)))
+              (case (car parts)
+                ((sxcal)
+                 (if (memv 'pretty (cdr parts))
+                   (format #t "~y" sxcal)
+                   (begin (write sxcal) (newline))))
+                ((ical) (component->ical-string cal))
+                ((xml)
+                 (let ((pipe (open-output-pipe
+                               (string-join
+                                 (append '("cat")
+                                         (if (memv 'pretty (cdr parts)) '("xmllint --format -") '())
+                                         (if (memv 'color (cdr parts))  '("highlight -Oansi --syntax=xml") '()))
+                                 "|"))))
+                 (sxml->xml sxcal pipe)
+                 (close-pipe pipe)
+                 (newline)))
+                ((newline) (newline))
+                (else (format #t "Unknown mode [~a]~%" (car parts)))))
+              (cdr args)))
+
+;; (write sxcal)
+;;
+;; (newline)
+;; (newline)
+;;
+;; (format #t "~y" sxcal)
+;;
+;; (newline)
+;;
+;; (let ((pipe (open-pipe* OPEN_WRITE "highlight" "-Oansi" "--syntax=xml")))
+;;   ((@ (sxml simple) sxml->xml) sxcal pipe)
+;;   (close-pipe pipe))
+;; (newline)
+;;
+;; (let ((pipe (open-pipe "xmllint --format - | highlight -Oansi --syntax=xml"
+;;                        OPEN_WRITE
+;;                        )))
+;;   (sxml->xml sxcal pipe)
+;;   (close-pipe pipe))
+;; (newline)
+;;
+;;
+;; (newline)
+;; (component->ical-string cal)
diff --git a/scripts/module-imports.scm b/scripts/module-imports.scm
index 19598172..6a0a5beb 100755
--- a/scripts/module-imports.scm
+++ b/scripts/module-imports.scm
@@ -15,7 +15,8 @@
 (add-to-load-path (dirname (current-filename)))
 
 (use-modules (hnh util)
-             (srfi srfi-1)
+             ((srfi srfi-1) :select (lset-difference))
+             (rnrs lists)
              (module-introspection))
 
 
@@ -24,8 +25,12 @@
 
 (define (main args)
   (define filename (cadr args))
-  (define forms (reverse (call-with-input-file filename get-forms)))
-  ;; All symbols in source file
+  (define-values (module-declaration-lst forms)
+    (partition module-declaration?
+               (reverse (call-with-input-file filename get-forms))))
+  ;; All symbols in source file, which are not in module declaration.
+  ;; Otherwise all explicitly imported symbols would be marked as
+  ;; used.
   (define symbs (unique-symbols forms))
   ;; (format #t "~y" (find-module-declaration forms))
   ;; (format #t "~a~%" symbs)
@@ -49,13 +54,12 @@
                       used-symbols
                       (lset-difference eq? all-symbols used-symbols)))
 
-            (remove (lambda (mod)
-                      (member (module-name mod)
-                              '((guile)
-                                (guile-user)
-                                (srfi srfi-1)
-                                )))
-                    (module-uses (resolve-module
-                                   (find-module-declaration
-                                     forms)))))
+            (remp (lambda (mod)
+                    (member (module-name mod)
+                            '((guile)
+                              (guile-user)
+                              (srfi srfi-1)
+                              )))
+                  (module-uses (resolve-module
+                                 (cadr (car module-declaration-lst))))))
   (newline))