From 873241a396e37378d56d014aa8cb00fcd614273b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 12 Apr 2022 13:25:13 +0200 Subject: Use module-introspection more. --- scripts/all-modules.scm | 7 ++- scripts/generate-test-data.scm | 119 +++++++++++++++++++++++++++++++++++++++++ scripts/module-imports.scm | 28 +++++----- 3 files changed, 138 insertions(+), 16 deletions(-) create mode 100755 scripts/generate-test-data.scm (limited to 'scripts') 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)) -- cgit v1.2.3