readit

  1(import (chicken process-context) (chicken file) (chicken format)
  2        matchable (readit parser) srfi-1 srfi-37)
  3(include-relative "util.scm")
  4
  5(define kflag #f)
  6(define shape '())
  7
  8(define (usage)
  9  (print "Usage: readit [-k] [-n shape] FILE...")
 10  (exit))
 11
 12(define help
 13  (option
 14    '(#\h "help") #f #f
 15    (lambda _
 16      (usage))))
 17
 18(define use-keys
 19  (option
 20    '(#\k "keys") #f #f
 21    (lambda (o n x vals)
 22      (set! kflag #t)
 23      vals)))
 24
 25(define node-shape
 26  (option
 27    '(#\n "node-shape") #t #t
 28    (lambda (o n x vals)
 29      (set! shape x)
 30      vals)))
 31
 32(define (dot-escape str)
 33  (define (needs-esc c)
 34    (or (eqv? c #\") (eqv? c #\\)))
 35
 36  (define (dot-escape* cur end)
 37    (if (> cur end)
 38      ""
 39      (let ((c (string-ref str cur)))
 40        (string-append
 41          (if (needs-esc c)
 42            (list->string (list #\\ c))
 43            (string c))
 44          (dot-escape* (+ cur 1) end)))))
 45
 46  (dot-escape* 0 (- (string-length str) 1)))
 47
 48(define (build-alist entries)
 49  (fold (lambda (entry alist)
 50          (let* ((meta (car entry))
 51                 (key  (meta-key meta))
 52                 (pair (cons key entry)))
 53            (if (assoc key alist)
 54              (error "duplicate key" key)
 55              (cons pair alist))))
 56        '() entries))
 57
 58(define (filter-refs entry)
 59  (match-let (((_ fields _) entry))
 60    (filter (lambda (field)
 61              (match-let (((key . val) field))
 62                (readit-ref? val))) fields)))
 63
 64(define (print-ref entry field alist)
 65  (define (node-desc meta)
 66    (if kflag
 67      (meta-key meta)
 68      (dot-escape (meta-title meta))))
 69
 70  (match-let (((key . val) field))
 71    (for-each (lambda (ref)
 72      (printf "\t\"~A\" -> \"~A\" [label=\"~A\"];~%"
 73            (node-desc (car entry))
 74            (let* ((p (assoc ref alist))
 75                   (e (if (not p)
 76                        (error "undefined reference" ref)
 77                        (cdr p))))
 78              (node-desc (car e)))
 79            (dot-escape key))) (vector->list val))))
 80
 81(define (print-graph entries)
 82  (let ((alist (build-alist entries)))
 83    (printf "digraph G {~%")
 84    (unless (null? shape)
 85      (printf "\tnode [shape=\"~A\"];~%" shape))
 86    (for-each (lambda (entry)
 87                (let ((refs (filter-refs entry)))
 88                  (for-each (lambda (ref)
 89                              (print-ref entry ref alist)) refs)))
 90              entries)
 91    (printf "}~%")))
 92
 93(define (main)
 94  (let* ((files (parse-args (list help use-keys node-shape)))
 95         (entries
 96           (if (null? files)
 97             (parse-input (current-input-port))
 98             (parse-files files))))
 99    (print-graph entries)))
100
101(cond-expand
102  ((or chicken-script compiling) (main))
103  (else #t))