Gaucheのライブラリモジュールの依存関係のグラフ

最初に書こうと思ったのはファイルの依存関係とタイムスタンプから実行の必要なテストを見つけるプログラムで、makefile風に書くと

dependency-list: **/*.scm
        update-dependency dependency-list $?
        for test in $$(find-test --backward dependency-list $?); do \
                gosh $${test} ; \
        done

のようなプログラムだったのだけど、とりあえずモジュールの依存関係をグラフ化してみた

追記: Gauche 0.9.7に対して再びグラフ化してみた。
f:id:lemniscus:20190106131331p:plain
グラフ化はGraphvizのtwopiで、

twopi -Tpng dotファイル -o 出力ファイル.png 

みたいにして、dotファイルの生成は以下のプログラム。

(use file.util)
(use srfi-1)
(use srfi-11)
(use text.tree)

(define (defined&used-modules file)
  (define (collect-module-names sexp)
    (cond ((or (not (list? sexp))
               (null? sexp))
           '())
          ((and (memq (car sexp) '(use extend))
                    (symbol? (cadr sexp)))  ; (use ,expr)の形でないこと
           (cdr sexp))
          ((eq? (car sexp) 'autoload)
           (list (cadr sexp)))
          (else
            (let1 module-names (append-map
                                 (lambda (x) (collect-module-names x))
                                 sexp)
              (if (memq (car sexp) '(define-module select-module))
                (cons (cons 'def (cadr sexp)) module-names)
                module-names)))))

  (let1 module-names (collect-module-names (file->sexp-list file))
    (receive (defs useds) (partition pair? module-names)
        (values 
          (delete-duplicates (map cdr defs))
          (delete-duplicates useds)))))

;; モジュールの依存関係module-dependencyの表現
;; ((名前 定義したモジュールのリスト useしたモジュールのリスト) ...)
;; 「名前」はファイル名と同名のモジュールを定義していればそのモジュール名
;; 定義していなければファイル名とする
(define (paths->module-dependency paths glob-pattern)
  (define (make-entry file)
    (receive (defined-mods used-mods) (defined&used-modules file)
      (let1 mod-name (path->module-name (path-sans-extension file))
        (if (memq mod-name defined-mods)
          (list mod-name (delete mod-name defined-mods) used-mods)
          (list file defined-mods used-mods)))))

  (let* ((cwd (current-directory)))
    (begin0
      (append-map
        (lambda (path)
          (cond
            ((not (file-is-directory? path)) '())
            (else
              (current-directory path)
              (map make-entry (glob glob-pattern)))))
        paths)
      (current-directory cwd))))

(define (make-relation mod-dependency defined-or-used)
  (let1 index (cond ((eq? defined-or-used 'defined) 1)
                    ((eq? defined-or-used 'used) 2)
                    (else (errorf "make-relation:~s\n" defined-or-used)))
    (append-map (lambda (entry)
                  (let ((name (list-ref entry 0))
                        (mods (list-ref entry index)))
                    (map (lambda (module)
                           (list name module))
                         mods)))
                mod-dependency)))

(define (reference-frequency relation)
  (let* ((ends (map cadr relation))
         (xs (sort-by ends x->string string<?)))
    (cdr (let loop ((module "dummy") ; いけにえの技法
                    (xs xs)
                    (counter 0))
           (cond ((null? xs) (list (cons module counter)))
                 ((eq? module (car xs))
                  (loop module (cdr xs) (+ 1 counter)))
                 (else
                   (cons (cons module counter)
                         (loop (car xs) (cdr xs) 1))))))))

(define (dot-about-frequency frequency normal-fontsize)
  (map (lambda (x)
         (let ((module (car x))
               (frequency (cdr x)))
           (format #f "~s [fontsize=~s];\n"
                   (if (string? module)
                     (path-swap-extension module "scm")
                     (x->string module))
                   (+ normal-fontsize -1 frequency)
                   )))
       frequency))

(define (dot-about-edges relation edge-color)
  (map (lambda (from-to)
         (let ((from (car from-to))
               (to (cadr from-to)))
           (list (if (string? from)
                   (format #f "~s [fontcolor=blue];\n" from)
                   '())
                 (let1 to (if (string? to)
                            (path-swap-extension to "scm")
                            to)
                   (list (format #f "~s -> ~s [color=~s];\n"
                                 (x->string from)
                                 (x->string to)
                                 edge-color)
                         (if (string? to)
                           (format #f "~s [fontcolor=blue];\n" to)
                           (format #f "~s [fontcolor=black];\n"
                                   (x->string to)))
                         (format #f "~s [shape=plaintext];\n"
                                 (x->string to)))))))
       relation))

(define (dot-tree)
  (define fontsize 7)
  (let1 mod-dependency (paths->module-dependency *load-path* "**/*.scm")
    (let ((use-relation (make-relation mod-dependency 'used))
          (define-relation (make-relation mod-dependency 'defined)))
      (list
        "digraph dependency {\n"
        "edge [penwidth=0.3];\n"
        "edge [arrowsize=0.01];\n"
        "node [shape=plaintext];\n"
        #`"node [fontsize=,|fontsize|];\n"
        "node [fontcolor=dimgray];\n"
        "node [height=0.02];\n"
        "node [width=0.02];\n"
        (dot-about-frequency (reference-frequency use-relation) fontsize)
        (dot-about-edges use-relation "green")
        (dot-about-edges define-relation "blue")
        "}\n"))))

(write-tree (dot-tree))