diff options
Diffstat (limited to 'module')
| -rw-r--r-- | module/calp/load-config.scm | 9 | ||||
| -rw-r--r-- | module/glob.scm | 15 | ||||
| -rw-r--r-- | module/hnh/module-introspection/all-modules.scm | 25 | ||||
| -rw-r--r-- | module/hnh/util.scm | 53 | ||||
| -rw-r--r-- | module/hnh/util/env.scm | 6 | ||||
| -rw-r--r-- | module/hnh/util/exceptions.scm | 3 | ||||
| -rw-r--r-- | module/hnh/util/path.scm | 11 | ||||
| -rw-r--r-- | module/scripts/find-undocumented.scm | 177 | ||||
| -rw-r--r-- | module/srfi/srfi-41/util.scm | 16 | ||||
| -rw-r--r-- | module/text/markup.scm | 1 | ||||
| -rw-r--r-- | module/text/numbers.scm | 8 | ||||
| -rw-r--r-- | module/vcomponent/control.scm | 37 | ||||
| -rw-r--r-- | module/vcomponent/util/control.scm | 2 | ||||
| -rw-r--r-- | module/vcomponent/util/search.scm | 3 | ||||
| -rw-r--r-- | module/vulgar/color.scm | 1 | ||||
| -rw-r--r-- | module/xdg/basedir.scm | 43 |
16 files changed, 312 insertions, 98 deletions
diff --git a/module/calp/load-config.scm b/module/calp/load-config.scm index 5844c1b6..0ce1f131 100644 --- a/module/calp/load-config.scm +++ b/module/calp/load-config.scm @@ -43,8 +43,11 @@ ;; altconfig could be placed in the list below. But I want to raise an error ;; if an explicitly given config is missing. [(find file-exists? - (list - (path-append (xdg-config-home) "calp" "config.scm") - (path-append (xdg-sysconfdir) "calp" "config.scm"))) + (let ((end '("calp" "config.scm"))) + `(,(apply path-append (xdg-config-home) end) + ,@(map (lambda (sysconfdir) + (apply path-append sysconfdir end)) + (xdg-config-dirs)) + ,(apply path-append "/etc" end)))) => identity]) ) diff --git a/module/glob.scm b/module/glob.scm index 64f97690..20cb4b1c 100644 --- a/module/glob.scm +++ b/module/glob.scm @@ -16,11 +16,14 @@ (define << ash) (include# "/usr/include/glob.h" define-public) -(define-values (glob% globfree%) - (let ((this (dynamic-link))) - (values - (pointer->procedure int (dynamic-func "glob" this) `(* ,int * *)) - (pointer->procedure void (dynamic-func "globfree" this) '(*))))) +(define lib (dynamic-link)) + +(define glob% + (pointer->procedure int (dynamic-func "glob" lib) + `(* ,int * *))) +(define globfree + (pointer->procedure void (dynamic-func "globfree" lib) + '(*))) (define glob-flags (logior GLOB_MARK GLOB_BRACE GLOB_TILDE_CHECK)) @@ -41,5 +44,5 @@ (ret (map (compose pointer->string make-pointer) (bytevector->uint-list strvec (native-endianness) (sizeof '*))))) - (globfree% (bytevector->pointer bv)) + (globfree (bytevector->pointer bv)) ret)))) diff --git a/module/hnh/module-introspection/all-modules.scm b/module/hnh/module-introspection/all-modules.scm index 1bf39e1e..4b224d2f 100644 --- a/module/hnh/module-introspection/all-modules.scm +++ b/module/hnh/module-introspection/all-modules.scm @@ -7,8 +7,9 @@ :use-module (hnh module-introspection) :use-module ((hnh module-introspection static-util) :select (get-forms)) :export (all-files-and-modules-under-directory + all-files-under-directory all-modules-under-directory - fs-find-base fs-find + fs-find module-file-mapping )) @@ -20,22 +21,24 @@ ;; (define (fs-find proc dir) ;; (filter proc (fs-find-base dir))) -(define (all-files-and-modules-under-directory dir) - (define re (make-regexp "\\.scm$")) +(define* (all-files-under-directory dir extension) + (define extension-rx ((@ (texinfo string-utils) escape-special-chars) + extension "[](){}+*?.^$" #\\)) + (define re (make-regexp (string-append extension-rx "$"))) - (define files - (map car - (filter (match-lambda ((filename _ 'regular) - (and (regexp-exec re filename) - (not (file-hidden? filename)))) - (_ #f)) - (fs-find dir)))) + (map car + (filter (match-lambda ((filename _ 'regular) + (and (regexp-exec re filename) + (not (file-hidden? filename)))) + (_ #f)) + (fs-find dir)))) +(define (all-files-and-modules-under-directory dir) (map (lambda (file) (list file (call-with-input-file file (compose find-module-declaration get-forms)))) - files)) + (all-files-under-directory dir ".scm"))) (define (all-modules-under-directory dir) "Returns two values, all scm files in dir, and all top diff --git a/module/hnh/util.scm b/module/hnh/util.scm index c88a029e..9f71c1ec 100644 --- a/module/hnh/util.scm +++ b/module/hnh/util.scm @@ -4,7 +4,8 @@ :use-module (srfi srfi-88) ; postfix keywords :use-module ((sxml fold) :select (fold-values)) :use-module ((srfi srfi-9 gnu) :select (set-fields)) - :re-export (fold-values) + :use-module ((ice-9 copy-tree) :select (copy-tree)) + :use-module ((ice-9 control) :select (call/ec)) :export (aif awhen for @@ -59,7 +60,6 @@ uniqx uniq univ - uniqv unique vector-last @@ -118,17 +118,50 @@ -(define-syntax for - (syntax-rules (in) +(define-syntax (for stx) + (syntax-case stx (in) ((for (<var> <vars> ...) in <collection> b1 body ...) - (map ((@ (ice-9 match) match-lambda) [(<var> <vars> ...) b1 body ...]) - <collection>)) + (with-syntax ((break (datum->syntax stx 'break)) + (continue (datum->syntax stx 'continue))) + #'(call/ec + (lambda (break) + (map ((@ (ice-9 match) match-lambda) + [(<var> <vars> ...) + (call/ec + (lambda (raw-continue) + (let ((continue + (case-lambda + (() #f) + (args (apply raw-continue args))))) + b1 body ...)))]) + <collection>))))) + ((for (<var> <vars> ... . <tail>) in <collection> b1 body ...) - (map ((@ (ice-9 match) match-lambda) [(<var> <vars> ... . <tail>) b1 body ...]) - <collection>)) + #'(call/ec + (lambda (break) + (map ((@ (ice-9 match) match-lambda) + [(<var> <vars> ... . <tail>) + (call/ec + (lambda (raw-continue) + (let ((continue + (case-lambda + (() (raw-continue #f)) + (args (apply raw-continue args))))) + b1 body ...)))]) + <collection>)))) ((for <var> in <collection> b1 body ...) - (map (lambda (<var>) b1 body ...) - <collection>)))) + (with-syntax ((break (datum->syntax stx 'break)) + (continue (datum->syntax stx 'continue))) + #'(call/ec + (lambda (break) + (map (lambda (<var>) + (call/ec (lambda (raw-continue) + (let ((continue + (case-lambda + (() (raw-continue #f)) + (args (apply raw-continue args))))) + b1 body ...)))) + <collection>))))))) diff --git a/module/hnh/util/env.scm b/module/hnh/util/env.scm index 32ea1cc1..f5992245 100644 --- a/module/hnh/util/env.scm +++ b/module/hnh/util/env.scm @@ -16,7 +16,11 @@ (list n new-value (getenv n))) (list (symbol->string (quote name)) ...) (list value ...))) - (for-each (lambda (pair) (setenv (car pair) (cadr pair))) + (for-each (lambda (pair) + (if (cadr pair) + (setenv (car pair) + (cadr pair)) + (unsetenv (car pair)))) env-pairs)) (lambda () body ...) (lambda () diff --git a/module/hnh/util/exceptions.scm b/module/hnh/util/exceptions.scm index 344eb27a..1c3de8c7 100644 --- a/module/hnh/util/exceptions.scm +++ b/module/hnh/util/exceptions.scm @@ -33,8 +33,7 @@ (define (fatal fmt . args) (display (format #f "FATAL: ~?~%" fmt (or args '())) (current-error-port)) - (raise 2) - ) + (raise SIGINT)) (define (filter-stack pred? stk) diff --git a/module/hnh/util/path.scm b/module/hnh/util/path.scm index b0991073..b92de8cd 100644 --- a/module/hnh/util/path.scm +++ b/module/hnh/util/path.scm @@ -17,7 +17,8 @@ (define path-absolute? absolute-file-name?) ;; TODO remove intermidiate period components -(define (path-append . strings) +;; e.x. /a/../b => /b +(define (path-append path . paths) (fold (lambda (s done) (string-append done @@ -33,11 +34,9 @@ ;; the path absolute. This isn't exactly correct if we have ;; drive letters, but on those system the user should make ;; sure that the first component of the path is non-empty. - (let ((s (car strings))) - (if (string-null? s) - // s)) - (cdr strings) - )) + (if (string-null? path) + // path) + paths)) (define (path-join lst) (apply path-append lst)) diff --git a/module/scripts/find-undocumented.scm b/module/scripts/find-undocumented.scm new file mode 100644 index 00000000..5aebcb25 --- /dev/null +++ b/module/scripts/find-undocumented.scm @@ -0,0 +1,177 @@ +(define-module (scripts find-undocumented) + :use-module (srfi srfi-1) + :use-module (hnh module-introspection all-modules) + :use-module (hnh util) + :use-module (hnh util path) + :use-module (ice-9 format) + :use-module (ice-9 regex) + :use-module (ice-9 rdelim) + :use-module (rnrs records syntactic) + :use-module (glob) + :export (main) + ) + +(define %summary "Find all uncodumented exported declaration in a project.") + +(define %synopsis "find-undocumented <srcdir> <docdir>") + +;; (define %help "") + +;;; All texinfo forms we want to capture. +;;; For each of these, the following grammar holds: +;;; - The first element should be a string of the texinfo tag to match +;;; - The following arguments are +;;; - Any number of `_`, meaning an argument we don't care about +;;; - a single instance of the symbol `name`, which indicates where the name of +;;; the definition is stored. +;;; - An optional final argument `...`, which indicates that more may argumnets +;;; may follow. +(define texinfo-definition-forms + '(("deffn" _ name ...) + ("deftp" _ name ...) + ("defun" name ...) + ("defmac" name ...) + ("defspec" name ...) + ("deftypefn" _ _ name ...) + ("deftypefun" _ name ...) + ("defvr" _ name) + ("defvar" name) + ("defopt" name) + ("deftypevr" _ _ name) + ("deftypevar" _ name) + ("deftp" _ name ...) + ("defcv" _ _ name) + ("deftypecv" _ _ name) + ("defivar" _ name) + ("deftypeivar" _ _ name) + ("defop" _ _ name ...) + ("deftypeop" _ _ _ name ...) + ("defmethod" _ name ...) + ("deftypemethod" _ _ name ...))) + +(define (command cmd) (format #f "@ *(~a)x?" cmd)) +(define parameter "(\\{(@\\}|[^}])+\\}|[^ \t]+)") +(define rest ".*") +(define regexpes + (for form in texinfo-definition-forms + (list + form + (string-concatenate + (intersperse + "[ \t]*" + (for (idx symbol) in (enumerate form) + (cond ((string? symbol) (command symbol)) + ((eq? '_ symbol) parameter) + ((eq? '... symbol) rest) + ((symbol? symbol) parameter) + (else (scm-error 'misc-error "" "" '() #f))))))))) + +(define rxs + (for (name rx) in regexpes + (list name + (make-regexp + (format #f "^ *~a" rx) + regexp/newline)))) + + +(define-record-type doc-definition + (fields symbol type file line)) + +(define (cmp a b) + (eq? + (doc-definition-symbol a) + (doc-definition-symbol b))) + +(define (print-header msg) + (define middle (format #f "= ~a =" msg)) + (define side (make-string (string-length middle) #\=)) + (format #t "~a~%~a~%~a~%" side middle side)) + +(define (print-doc-definition def) + (display (symbol->string (doc-definition-symbol def))) + (cond ((doc-definition-file def) + => (lambda (it) + (display "\t(") + (display it) + (cond ((doc-definition-line def) + => (lambda (it) + (display " ") + (display it)))) + (display ")")))) + (newline)) + +(define (main . args) + (define source-directory "module") + (define doc-dir "doc/ref") + (define skip-files + (append + '( + ;; Ignored since we arent't the implementor. + ;; It could however be nice to document it + "module/graphviz.scm" + ) + ;; Each entry-point should only export a main procedure, + ;; and is documented elsewhere + (glob "module/calp/entry-points/*.scm") + ;; These are scripts for `guild`. + ;; Each file exports a few pre-defined symbols, + ;; and are documented in other ways. + (glob "module/scripts/*.scm") + )) + + (define documented-symbols + (concatenate + (for file in (all-files-under-directory doc-dir ".texi") + (let ((content (call-with-input-file file read-string))) + (concatenate + (for (form rx) in rxs + (for m in (list-matches rx content) + (make-doc-definition + (-> m + (match:substring + ;; Weird offsets to account for how matching groups work + (* 2 (1+ (list-index (lambda (x) (eqv? x 'name)) + (cdr form))))) + (string-trim-both (string->char-set "{}")) + string->symbol) + (string->symbol (match:substring m 1)) + file + (1+ (string-count (match:prefix m) (char-set #\newline))) + )))))))) + + (define defined-symbols + (concatenate + (for path in (all-modules-under-directory source-directory) + (when (member path skip-files) + (continue '())) + + (define components* + (drop (path-split path) + (length (path-split source-directory)))) + + (define name + (map string->symbol + (append (drop-right components* 1) + (list (basename (last components*) ".scm"))))) + (catch 'misc-error + (lambda () + (cond ((resolve-interface name) + => (lambda (module) (map (lambda (symb) (make-doc-definition symb #f path #f)) + (module-map (lambda (k v) k) module)))) + (else + (format (current-error-port) "~s is not a module~%" name) + '()))) + (lambda (err proc fmt args data) + (format (current-error-port) "Failed loading ~s: (~a) ~?~%" name proc fmt args) + '()))))) + + + (print-header "Documented functions without (or with private) definitions:") + (for-each print-doc-definition (lset-difference cmp documented-symbols defined-symbols)) + (newline) + + (print-header "Defined symbols without documentation:") + (for-each print-doc-definition (lset-difference cmp defined-symbols documented-symbols)) + + (newline) + ) diff --git a/module/srfi/srfi-41/util.scm b/module/srfi/srfi-41/util.scm index 16bf1da6..1571cc4c 100644 --- a/module/srfi/srfi-41/util.scm +++ b/module/srfi/srfi-41/util.scm @@ -5,6 +5,7 @@ :use-module ((ice-9 sandbox) :select (call-with-time-limit)) :use-module ((hnh util) :select (find-extreme)) :export (stream-car+cdr + eager-stream-cons interleave-streams stream-insert filter-sorted-stream @@ -17,7 +18,8 @@ stream-partition stream-split stream-paginate - stream-timeslice-limit)) + stream-timeslice-limit + stream-split-by)) (define (stream-car+cdr stream) (values (stream-car stream) @@ -145,3 +147,15 @@ (stream-timeslice-limit (stream-cdr strm) timeslice))) (lambda _ stream-null))) + +(define-stream (stream-split-by pred strm) + (let loop ((accumulated '()) + (strm strm)) + (stream-match strm + (() (if (null? accumulated) + stream-null + (stream (reverse accumulated)))) + ((x . xs) (pred x) + (stream-cons (reverse (cons x accumulated)) (loop '() xs))) + ((x . xs) + (loop (cons x accumulated) xs))))) diff --git a/module/text/markup.scm b/module/text/markup.scm index a7a905df..62f93b0c 100644 --- a/module/text/markup.scm +++ b/module/text/markup.scm @@ -65,6 +65,7 @@ (map (lambda (line) (sxml->ansi-text `(group (ws (@ (minwidth 4))) ,line (br)))) (flow-text (string-concatenate (map sxml->ansi-text body)) + ;; TODO shouldn't this use (- width 4)? width: 66)))] [(ws) (make-string (aif (assoc-ref args 'minwidth) (car it) 1) diff --git a/module/text/numbers.scm b/module/text/numbers.scm index c45016bc..7909573b 100644 --- a/module/text/numbers.scm +++ b/module/text/numbers.scm @@ -2,10 +2,16 @@ :use-module (srfi srfi-88) :export (number->string-cardinal number->string-ordinal + resolve-language each-string)) (define (get mod-symb proc-symb) - (module-ref (resolve-interface `(text numbers ,mod-symb)) + (module-ref (catch 'misc-error + (lambda () (resolve-interface `(text numbers ,mod-symb))) + (lambda (err proc fmt args data) + ;; Possibly check if the err message starts with + ;; "no code for module" + (resolve-interface '(text numbers en)))) proc-symb)) ;; "sv_SE.UTF-8" diff --git a/module/vcomponent/control.scm b/module/vcomponent/control.scm deleted file mode 100644 index 19a6fa18..00000000 --- a/module/vcomponent/control.scm +++ /dev/null @@ -1,37 +0,0 @@ -(define-module (vcomponent util control) - :use-module (hnh util) - :use-module (vcomponent) - :export (with-replaced-properties)) - - -(eval-when (expand load) ; No idea why I must have load here. - (define href (make-procedure-with-setter hash-ref hash-set!)) - - (define (set-temp-values! table component kvs) - (for-each (lambda (kv) - (let ((key (car kv)) - (val (cadr kv))) - (when (prop component key) - (set! (href table key) (prop component key)) - (set! (prop component key) val)))) - kvs)) - - (define (restore-values! table component keys) - (for-each (lambda (key) - (and=> (href table key) - (lambda (val) - (set! (prop component key) val)))) - keys))) - -;; TODO what is this even used for? -(define-syntax with-replaced-properties - (syntax-rules () - [(G_ (component (key val) ...) - body ...) - - (let ((htable (make-hash-table 10))) - (dynamic-wind - (lambda () (set-temp-values! htable component (quote ((key val) ...)))) ; In guard - (lambda () body ...) - (lambda () (restore-values! htable component (quote (key ...))))))])) ; Out guard - diff --git a/module/vcomponent/util/control.scm b/module/vcomponent/util/control.scm index 0869543d..19a6fa18 100644 --- a/module/vcomponent/util/control.scm +++ b/module/vcomponent/util/control.scm @@ -26,7 +26,7 @@ ;; TODO what is this even used for? (define-syntax with-replaced-properties (syntax-rules () - [(_ (component (key val) ...) + [(G_ (component (key val) ...) body ...) (let ((htable (make-hash-table 10))) diff --git a/module/vcomponent/util/search.scm b/module/vcomponent/util/search.scm index e2057e9e..3c2d7663 100644 --- a/module/vcomponent/util/search.scm +++ b/module/vcomponent/util/search.scm @@ -175,6 +175,9 @@ (lambda (err proc fmt args data) ;; NOTE This is mostly a hack to see that we ;; actually check for the correct error. + ;; + ;; stream-ref quite unhelpfully throws this error as + ;; $3 = (wrong-type-arg stream-ref "beyond end of stream" () (#<stream>)) (unless (string=? fmt "beyond end of stream") (scm-error err proc fmt args data)) diff --git a/module/vulgar/color.scm b/module/vulgar/color.scm index 5f9fbe40..91bd977f 100644 --- a/module/vulgar/color.scm +++ b/module/vulgar/color.scm @@ -1,7 +1,6 @@ (define-module (vulgar color) :export (color-if color-escape)) -(define-public STR-YELLOW "\x1b[0;33m") (define-public STR-RESET "\x1b[m") (define-syntax-rule (color-if pred color body ...) diff --git a/module/xdg/basedir.scm b/module/xdg/basedir.scm index 92a5c7d9..f4e7b89b 100644 --- a/module/xdg/basedir.scm +++ b/module/xdg/basedir.scm @@ -3,59 +3,66 @@ ;;; Code: (define-module (xdg basedir) - :export (sysconfdir runtime-dir - data-home config-home cache-home + :export (runtime-dir + data-home config-home state-home cache-home data-dirs config-dirs)) +;;; Check if an environment variable is set to a non-empty value. +(define (set? var) + (cond ((getenv var) + => (lambda (s) + (if (string-null? s) + #f s))) + (else #f))) + ;;; XDG_DATA_HOME ;;; $HOME/.local/share (define (data-home) - (or (getenv "XDG_DATA_HOME") + (or (set? "XDG_DATA_HOME") (string-append (getenv "HOME") "/.local/share"))) ;;; XDG_CONFIG_HOME ;;; $HOME/.config (define (config-home) - (or (getenv "XDG_CONFIG_HOME") + (or (set? "XDG_CONFIG_HOME") (string-append (getenv "HOME") "/.config"))) +;;; XDG_STATE_HOME +;;; $HOME/.local/state +(define (state-home) + (or (set? "XDG_STATE_HOME") + (string-append (getenv "HOME") "/.local/state"))) + ;;; XDG_DATA_DIRS ;;; colon (:) sepparated, in addition to XDG_DATA_HOME ;;; /usr/local/share/:/usr/share/ (define (data-dirs) - (let ((str (getenv "XDG_DATA_DIRS"))) + (let ((str (set? "XDG_DATA_DIRS"))) (if str - (parse-path str) + (string-split str #\:) '("/usr/local/share" "/usr/share")))) -;;; sysconfdir -;;; /etc -;;; Techincly not part of the standard, but it's mentioned -(define (sysconfdir) - (or (getenv "sysconfdir") - "/etc")) - - ;;; XDG_CONFIG_DIRS ;;; colon (:) separated, in adddition to XDG_CONFIG_HOME ;;; /etc/xdg (define (config-dirs) - (let ((str (getenv "XDG_CONFIG_DIRS"))) + (let ((str (set? "XDG_CONFIG_DIRS"))) (if str (string-split str #\:) - (list (string-append sysconfdir "/xdg"))))) + '("/etc/xdg")))) ;;; XDG_CACHE_HOME ;;; $HOME/.cache (define (cache-home) - (or (getenv "XDG_CACHE_HOME") + (or (set? "XDG_CACHE_HOME") (string-append (getenv "HOME") "/.cache"))) ;;; XDG_RUNTIME_DIR ;;; Default to /tmp or /tmp/$(uid), and raise a warning (define (runtime-dir) - (or (getenv "XDG_RUNTIME_DIR") + (or (set? "XDG_RUNTIME_DIR") (begin (display "WARNING: XDG_RUNTIME_DIR unset, defaulting to /tmp\n" (current-error-port)) "/tmp"))) + |