mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +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.
|
||||
;;
|
||||
;; Options:
|
||||
;; --default-module MOD -- Set MOD as the default module (for top-level
|
||||
;; `use-modules' forms that do not follow some
|
||||
;; `define-module' form in a file). MOD should be
|
||||
;; be a list or `#f', in which case such top-level
|
||||
;; `use-modules' forms are effectively ignored.
|
||||
;; Default value: `(guile-user)'.
|
||||
;;
|
||||
;; TODO: Use `(ice-9 format)'.
|
||||
;; -m, --default-module MOD -- Set MOD as the default module (for top-level
|
||||
;; `use-modules' forms that do not follow some
|
||||
;; `define-module' form in a file). MOD should be
|
||||
;; be a list or `#f', in which case such top-level
|
||||
;; `use-modules' forms are effectively ignored.
|
||||
;; Default value: `(guile-user)'.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(define-module (scripts use2dot)
|
||||
:autoload (ice-9 getopt-long) (getopt-long)
|
||||
:use-module ((srfi srfi-13) :select (string-join))
|
||||
: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 (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
|
||||
(format #f "~S" s))
|
||||
|
||||
(define (vv pair) ; var=val
|
||||
(format #f "~A=~A" (car pair) (cdr pair)))
|
||||
(define (vv pairs) ; => ("var=val" ...)
|
||||
(map (lambda (pair)
|
||||
(format #f "~A=~A" (car pair) (cdr pair)))
|
||||
pairs))
|
||||
|
||||
(define (>>header)
|
||||
(format #t "digraph use2dot {\n")
|
||||
(for-each (lambda (s) (format #t " ~A;\n" s))
|
||||
(map vv `((label . ,(q "Guile Module Dependencies"))
|
||||
;;(rankdir . LR)
|
||||
;;(size . ,(q "7.5,10"))
|
||||
(ratio . fill)
|
||||
;;(nodesep . ,(q "0.05"))
|
||||
))))
|
||||
(vv `((label . ,(q "Guile Module Dependencies"))
|
||||
;;(rankdir . LR)
|
||||
;;(size . ,(q "7.5,10"))
|
||||
(ratio . fill)
|
||||
;;(nodesep . ,(q "0.05"))
|
||||
))))
|
||||
|
||||
(define (>>body edges)
|
||||
(for-each
|
||||
|
@ -106,28 +87,26 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
|
|||
((computed) '((style . bold)))
|
||||
(else #f))
|
||||
=> (lambda (etc)
|
||||
(format #t " [~A]" (mapconcat vv etc ",")))))
|
||||
(format #t " [~A]" (string-join (vv etc) ",")))))
|
||||
(format #t ";\n"))
|
||||
edges))
|
||||
|
||||
(define (>>footer)
|
||||
(format #t "}"))
|
||||
|
||||
(define (>> edges)
|
||||
(>>header)
|
||||
(>>body edges)
|
||||
(>>footer))
|
||||
|
||||
(define (use2dot . args)
|
||||
(let* ((override (cond ((member "--default-module" args)
|
||||
=> (lambda (ls)
|
||||
(with-input-from-string
|
||||
(cadr ls)
|
||||
(lambda () (read)))))
|
||||
(else #f)))
|
||||
(files (if override (cddr args) args)))
|
||||
(>>header)
|
||||
(>>body (reverse
|
||||
(((make-frisker
|
||||
`(default-module . ,(or override *default-module*)))
|
||||
files)
|
||||
'edges)))
|
||||
(>>footer)))
|
||||
(let* ((parsed-args (getopt-long (cons "use2dot" args) ;;; kludge
|
||||
'((default-module
|
||||
(single-char #\m) (value #t)))))
|
||||
(=m (option-ref parsed-args 'default-module *default-module*))
|
||||
(scan (make-frisker `(default-module . ,=m)))
|
||||
(files (option-ref parsed-args '() '())))
|
||||
(>> (reverse ((scan files) 'edges)))))
|
||||
|
||||
(define main use2dot)
|
||||
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue