mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 19:50:24 +02:00
Autoload module (ice-9 getopt-long).
Use module (srfi srfi-13). Export `use2dot'. (string-append/separator, mapconcat): Delete. (vv): Now take list of pairs, and return the mapping.. (>>header): Use `string-join'. (>>): New proc. (use2dot): Use `getopt-long'. Use `>>'.
This commit is contained in:
parent
b51e36348a
commit
7c8ce087f9
1 changed files with 33 additions and 54 deletions
|
@ -42,60 +42,41 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
|
||||||
;; string, or "[computed in FILE]" otherwise.
|
;; string, or "[computed in FILE]" otherwise.
|
||||||
;;
|
;;
|
||||||
;; Options:
|
;; Options:
|
||||||
;; --default-module MOD -- Set MOD as the default module (for top-level
|
;; -m, --default-module MOD -- Set MOD as the default module (for top-level
|
||||||
;; `use-modules' forms that do not follow some
|
;; `use-modules' forms that do not follow some
|
||||||
;; `define-module' form in a file). MOD should be
|
;; `define-module' form in a file). MOD should be
|
||||||
;; be a list or `#f', in which case such top-level
|
;; be a list or `#f', in which case such top-level
|
||||||
;; `use-modules' forms are effectively ignored.
|
;; `use-modules' forms are effectively ignored.
|
||||||
;; Default value: `(guile-user)'.
|
;; Default value: `(guile-user)'.
|
||||||
;;
|
|
||||||
;; TODO: Use `(ice-9 format)'.
|
|
||||||
|
|
||||||
;;; Code:
|
;;; Code:
|
||||||
|
|
||||||
(define-module (scripts use2dot)
|
(define-module (scripts use2dot)
|
||||||
|
:autoload (ice-9 getopt-long) (getopt-long)
|
||||||
|
:use-module ((srfi srfi-13) :select (string-join))
|
||||||
:use-module ((scripts frisk)
|
:use-module ((scripts frisk)
|
||||||
:select (make-frisker edge-type edge-up edge-down)))
|
:select (make-frisker edge-type edge-up edge-down))
|
||||||
|
:export (use2dot))
|
||||||
|
|
||||||
(define *default-module* '(guile-user))
|
(define *default-module* '(guile-user))
|
||||||
|
|
||||||
(define (string-append/separator separator strings)
|
|
||||||
;; from (ttn stringutils) -- todo: use srfi-13
|
|
||||||
;; "Append w/ SEPARATOR a list of STRINGS.
|
|
||||||
;; SEPARATOR can be a character or a string."
|
|
||||||
(let ((rev (reverse strings))
|
|
||||||
(sep (if (char? separator)
|
|
||||||
(make-string 1 separator)
|
|
||||||
separator)))
|
|
||||||
(apply string-append
|
|
||||||
(let loop ((s (cdr rev))
|
|
||||||
(acc (list (car rev))))
|
|
||||||
(if (null? s)
|
|
||||||
acc
|
|
||||||
(loop (cdr s)
|
|
||||||
(cons (car s)
|
|
||||||
(cons sep acc))))))))
|
|
||||||
|
|
||||||
(define (mapconcat proc ls sep)
|
|
||||||
;; from (ttn stringutils) -- todo: use srfi-13
|
|
||||||
;; "Map PROC over LS, concatening resulting strings with separator SEP."
|
|
||||||
(string-append/separator sep (map proc ls)))
|
|
||||||
|
|
||||||
(define (q s) ; quote
|
(define (q s) ; quote
|
||||||
(format #f "~S" s))
|
(format #f "~S" s))
|
||||||
|
|
||||||
(define (vv pair) ; var=val
|
(define (vv pairs) ; => ("var=val" ...)
|
||||||
(format #f "~A=~A" (car pair) (cdr pair)))
|
(map (lambda (pair)
|
||||||
|
(format #f "~A=~A" (car pair) (cdr pair)))
|
||||||
|
pairs))
|
||||||
|
|
||||||
(define (>>header)
|
(define (>>header)
|
||||||
(format #t "digraph use2dot {\n")
|
(format #t "digraph use2dot {\n")
|
||||||
(for-each (lambda (s) (format #t " ~A;\n" s))
|
(for-each (lambda (s) (format #t " ~A;\n" s))
|
||||||
(map vv `((label . ,(q "Guile Module Dependencies"))
|
(vv `((label . ,(q "Guile Module Dependencies"))
|
||||||
;;(rankdir . LR)
|
;;(rankdir . LR)
|
||||||
;;(size . ,(q "7.5,10"))
|
;;(size . ,(q "7.5,10"))
|
||||||
(ratio . fill)
|
(ratio . fill)
|
||||||
;;(nodesep . ,(q "0.05"))
|
;;(nodesep . ,(q "0.05"))
|
||||||
))))
|
))))
|
||||||
|
|
||||||
(define (>>body edges)
|
(define (>>body edges)
|
||||||
(for-each
|
(for-each
|
||||||
|
@ -106,28 +87,26 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
|
||||||
((computed) '((style . bold)))
|
((computed) '((style . bold)))
|
||||||
(else #f))
|
(else #f))
|
||||||
=> (lambda (etc)
|
=> (lambda (etc)
|
||||||
(format #t " [~A]" (mapconcat vv etc ",")))))
|
(format #t " [~A]" (string-join (vv etc) ",")))))
|
||||||
(format #t ";\n"))
|
(format #t ";\n"))
|
||||||
edges))
|
edges))
|
||||||
|
|
||||||
(define (>>footer)
|
(define (>>footer)
|
||||||
(format #t "}"))
|
(format #t "}"))
|
||||||
|
|
||||||
|
(define (>> edges)
|
||||||
|
(>>header)
|
||||||
|
(>>body edges)
|
||||||
|
(>>footer))
|
||||||
|
|
||||||
(define (use2dot . args)
|
(define (use2dot . args)
|
||||||
(let* ((override (cond ((member "--default-module" args)
|
(let* ((parsed-args (getopt-long (cons "use2dot" args) ;;; kludge
|
||||||
=> (lambda (ls)
|
'((default-module
|
||||||
(with-input-from-string
|
(single-char #\m) (value #t)))))
|
||||||
(cadr ls)
|
(=m (option-ref parsed-args 'default-module *default-module*))
|
||||||
(lambda () (read)))))
|
(scan (make-frisker `(default-module . ,=m)))
|
||||||
(else #f)))
|
(files (option-ref parsed-args '() '())))
|
||||||
(files (if override (cddr args) args)))
|
(>> (reverse ((scan files) 'edges)))))
|
||||||
(>>header)
|
|
||||||
(>>body (reverse
|
|
||||||
(((make-frisker
|
|
||||||
`(default-module . ,(or override *default-module*)))
|
|
||||||
files)
|
|
||||||
'edges)))
|
|
||||||
(>>footer)))
|
|
||||||
|
|
||||||
(define main use2dot)
|
(define main use2dot)
|
||||||
|
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue