find.rkt (11142B)
1 #lang racket 2 (require racket/system 3 racket/draw 4 racket/runtime-path 5 "orig-colors.rkt") 6 7 (define root-of-plt-git 8 (simplify-path 9 (build-path (collection-file-path "base.rkt" "racket") 10 'up 'up 'up 'up 'up))) 11 12 (define (get-language i) 13 (and (or (regexp-match #rx"scrbl$" (path->string i)) 14 (regexp-match #rx"[.]rkt$" (path->string i)) 15 (regexp-match #rx"[.]ss$" (path->string i)) 16 (regexp-match #rx"[.]scm$" (path->string i))) 17 (call-with-input-file i 18 (λ (port) 19 (simplify-language 20 (and (not (skip-file? i)) 21 (parameterize ([read-accept-reader #t]) 22 (with-handlers ((exn:fail? (λ (x) (printf "exn when reading ~s\n" i) #f #;(raise x)))) 23 (let loop () 24 (let ([line (read-line (peeking-input-port port))]) 25 (cond 26 [(eof-object? line) 27 (error 'get-language "got to eof without finding a language")] 28 [(regexp-match #rx"[(]" line) 29 (cond 30 [(regexp-match #rx"module [^ ]* +(.*)$" line) 31 => 32 (λ (m) 33 (let ([obj (read (open-input-string (list-ref m 1)))]) 34 (if (string? obj) 35 (format "s-exp ~a" obj) 36 (format "~a" obj))))] 37 [else 38 (match (read port) 39 [`(module ,modname ,lang ,stuff ...) 40 (if (string? lang) 41 (format "s-exp ~a" lang) 42 (format "~a" lang))] 43 [else 44 45 #f ;; here we just assume there is no language specified 46 #;(error 'get-language "found a paren, but not a module expression in ~s" i)])])] 47 [(regexp-match #rx"#reader ?scribble/reader" line) 48 (read-line port) 49 (loop)] 50 [(regexp-match #rx"#reader" line) 51 (parse-reader-line port)] 52 [(regexp-match #rx"#lang (.*)$" line) 53 => 54 (λ (m) (list-ref m 1))] 55 [(regexp-match #rx"#!r6rs$" line) "r6rs"] 56 [else 57 (read-line port) 58 (loop)]))))))))))) 59 60 (define (simplify-language lang) 61 (and lang 62 (let ([lang 63 (regexp-replace 64 #rx" +$" 65 (regexp-replace* #rx"\"" 66 (regexp-replace* #rx"s-exp " lang "") 67 "") 68 "")]) 69 (cond 70 [(regexp-match #rx"^scheme" lang) 71 (simplify-language (string-append "racket" (substring lang 6)))] 72 [(regexp-match #rx"#%kernel" lang) 73 "#%kernel"] 74 [(regexp-match #rx"lib infotab.ss setup" lang) 75 "setup/infotab"] 76 [(regexp-match #rx"slideshow" lang) 77 "slideshow"] 78 [(regexp-match #rx"typed/scheme$" lang) 79 "typed/racket"] 80 [(regexp-match #rx"typed-scheme$" lang) 81 "typed/racket"] 82 [(regexp-match #rx"racket/unit/lang" lang) 83 "racket/unit"] 84 [(regexp-match #rx"srfi/provider" lang) 85 "srfi/provider"] 86 [(regexp-match #rx"htdp/bsl/reader" lang) 87 "htdp/bsl"] 88 [(regexp-match #rx"htdp-beginner.ss" lang) 89 "htdp/bsl"] 90 [(regexp-match #rx"htdp-intermediate.ss" lang) 91 "htdp/isl"] 92 [(regexp-match #rx"htdp-intermediate-lambda.ss" lang) 93 "htdp/isl+"] 94 [(regexp-match #rx"htdp-advanced.ss" lang) 95 "htdp/asl"] 96 [else lang])))) 97 98 99 (define (skip-file? path) 100 (let ([str (path->string path)]) 101 (or (regexp-match #rx"collects/games/loa/main.ss" str) 102 (regexp-match #rx"collects/tests" str) 103 (regexp-match #rx"collects/scribblings/guide/contracts-examples" str) 104 (regexp-match #rx"collects/htdp/tests/matrix-" str) 105 (regexp-match #rx"collects/scribblings/guide/read.scrbl" str)))) 106 107 (define (parse-reader-line port) 108 (let ([line (read-line port)]) 109 (cond 110 [(regexp-match #rx"htdp-beginner-reader.ss" line) 111 "htdp/bsl"] 112 [else 113 (error 'parse-reader-line "unknown line ~s" line)]))) 114 115 116 (define ht (make-hash)) 117 (for ((i (in-directory root-of-plt-git))) 118 (let ([lang (get-language i)]) 119 (when lang 120 (hash-set! ht lang (cons i (hash-ref ht lang '())))))) 121 (let ([one-offs '()]) 122 (hash-for-each 123 ht 124 (λ (k v) (when (= 1 (length v)) 125 (hash-remove! ht k) 126 (set! one-offs (cons (car v) one-offs))))) 127 (hash-set! ht "one off language" one-offs)) 128 129 (sort (hash-map ht (λ (x y) (list x (length y)))) string<=? #:key car) 130 131 (define existing-edges (make-hash)) 132 (define existing-interior-nodes (make-hash)) 133 (define directory->languages (make-hash)) 134 135 (define depth-table (make-hash)) 136 137 (define path->rank 138 (let ([rank-table (make-hash)]) 139 (λ (path) 140 (hash-ref rank-table path 141 (λ () 142 (let ([next (hash-count rank-table)]) 143 (hash-set! rank-table path (format "rank~a" next)) 144 (format "rank~a" next))))))) 145 146 (define (file-to-dot filename language) 147 (let ([path (find-relative-path root-of-plt-git filename)]) 148 (let loop ([eles (explode-path path)] 149 [parent (build-path 'same)] 150 [depth 0]) 151 (let* ([child (build-path parent (car eles))] 152 [key (cons parent child)]) 153 154 (cond 155 [(null? (cdr eles)) 156 (unless (member language (hash-ref directory->languages parent '())) 157 (hash-set! directory->languages parent (cons language (hash-ref directory->languages parent '()))) 158 (unless (hash-ref existing-edges key #f) 159 (hash-set! existing-edges key #t) 160 (printf " \"~a\" -> \"~a\" [color=gray,arrowhead=none,arrowtail=none];\n" parent child)) 161 (hash-set! depth-table depth (+ 1 (hash-ref depth-table depth 0))) 162 (let ([rank (path->rank parent)]) 163 (printf " \"~a\" [label=\"\",shape=circle,fillcolor=\"~a\",color=\"~a\",style=filled] ;\n" 164 (path->string child) 165 (language->color filename language) 166 (language->color filename language))))] 167 [else 168 (unless (hash-ref existing-edges key #f) 169 (hash-set! existing-edges key #t) 170 (printf " \"~a\" -> \"~a\" [color=gray,arrowhead=none,arrowtail=none];\n" parent child)) 171 (unless (hash-ref existing-interior-nodes parent #f) 172 (hash-set! existing-interior-nodes parent #t) 173 (printf " \"~a\" [shape=point,color=gray];\n" parent)) 174 (unless (hash-ref existing-interior-nodes child #f) 175 (hash-set! existing-interior-nodes child #t) 176 (printf " \"~a\" [shape=point,color=gray];\n" child)) 177 (loop (cdr eles) child (+ depth 1))]))))) 178 179 (define colors (make-hash)) 180 181 (define (language->color file lang) 182 (hash-ref colors lang 183 (λ () 184 (cond 185 [(regexp-match #rx"web" lang) 186 (next-color lang 'purple)] 187 [(or (regexp-match #rx"frtime" lang)) 188 (next-color lang 'gray)] 189 [(regexp-match #rx"typed" lang) 190 (next-color lang 'orange)] 191 [(or (regexp-match #rx"at-exp" lang) 192 (regexp-match #rx"scribble" lang)) 193 (next-color lang 'red)] 194 [(or (regexp-match #rx"scheme" lang) 195 (regexp-match #rx"racket" lang) 196 (regexp-match #rx"slideshow" lang) 197 (regexp-match #rx"#%kernel" lang) 198 (regexp-match #rx"pre-base.rkt" lang)) 199 (next-color lang 'blue)] 200 [(or (regexp-match #rx"srfi" lang) 201 (regexp-match #rx"r6rs" lang) 202 (regexp-match #rx"r5rs" lang)) 203 (next-color lang 'pink)] 204 [(regexp-match #rx"module-reader" lang) 205 (next-color lang 'brown)] 206 [(regexp-match #rx"setup" lang) 207 (next-color lang 'yellow)] 208 [(or (regexp-match #rx"htdp" lang) 209 (regexp-match #rx"DMdA" lang)) 210 (next-color lang 'green)] 211 [(regexp-match #rx"swindle" lang) 212 (next-color lang 'cyan)] 213 [else 214 (fprintf (current-error-port) "unknown language ~s ~s\n" lang (length (hash-ref ht lang))) 215 (new-color lang 0 0 0)])))) 216 217 (define (new-color lang r g b) 218 (define new-color (string-append 219 "#" 220 (to-hex r) 221 (to-hex g) 222 (to-hex b))) 223 (hash-set! colors lang new-color) 224 new-color) 225 226 (define colors-table (hash-copy orig-colors)) 227 228 (define (next-color lang key) 229 (let ([lst (hash-ref colors-table key)]) 230 (cond 231 [(null? lst) 232 (eprintf "ran out of ~a for ~a\n" key lang) 233 (hash-set! colors-table key (hash-ref orig-colors key)) 234 (next-color lang key)] 235 [else 236 (hash-set! colors-table key (cdr lst)) 237 (cond 238 [(list? (car lst)) 239 (apply new-color lang (car lst))] 240 [else 241 (let ([color (send the-color-database find-color (car lst))]) 242 (new-color lang 243 (send color red) 244 (send color green) 245 (send color blue)))])]))) 246 247 (define (to-hex n) 248 (cond 249 [(<= n 15) (format "0~a" (number->string n 16))] 250 [else (number->string n 16)])) 251 252 (define (to-dot) 253 (printf "digraph {\n") 254 (hash-for-each 255 ht 256 (λ (lang files) 257 (for-each 258 (λ (file) (file-to-dot file lang)) 259 files))) 260 (printf "}\n")) 261 262 (call-with-output-file "lang.dot" 263 (λ (port) 264 (parameterize ([current-output-port port]) 265 (to-dot))) 266 #:exists 'truncate) 267 268 (define-runtime-path lang-colors.rktd "lang-colors.rktd") 269 (call-with-output-file lang-colors.rktd 270 (λ (port) 271 (pretty-write 272 (sort (hash-map colors list) 273 string<=? 274 #:key car) 275 port)) 276 #:exists 'truncate) 277 278 (printf "calling twopi\n") 279 (void 280 (parameterize ([current-input-port (open-input-string "")]) 281 (system (format "~a -Tplain lang.dot > lang.plain" 282 (if (file-exists? "/usr/local/bin/twopi") 283 "/usr/local/bin/twopi" 284 "/usr/bin/twopi")))))