suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Refactor raco's tool listing code

Browse Source
This commit is contained in:
Jack Firth 2015-09-17 10:30:11 -07:00 committed by Matthew Flatt
parent 9c123172fa
commit c05db1ecf4
1 changed files with 74 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

122
racket/collects/raco/all-tools.rkt
View File

@ -1,58 +1,84 @@
#lang racket/base
(require setup/getinfo
racket/list)
(provide all-tools)
(define (log-exn-message-handler exn)
(log-error (exn-message exn))
#f)
(define (get-info/full/skip dir)
(with-handlers ([exn:fail? (lambda (exn)
(log-error (exn-message exn))
#f)])
(with-handlers ([exn:fail? log-exn-message-handler])
(get-info/full dir)))
(define (ensure-list v)
(if (list? v) v (list v)))
(define (check-tool-not-registered-twice tools entry dir)
(define tool-name (car entry))
(define previous-tool (hash-ref tools tool-name #f))
(when previous-tool
(eprintf "warning: tool ~s registered twice: ~e and ~e\n"
tool-name
(car previous-tool)
dir)))
(define (valid-raco-commands-spec? entry)
(and (list? entry)
(= (length entry) 4)
(string? (car entry))
(module-path? (cadr entry))
(string? (caddr entry))
(or (not (list-ref entry 3))
(real? (list-ref entry 3)))))
(define (check-valid-raco-commands-spec entry dir)
(unless (valid-raco-commands-spec? entry)
(eprintf "warning: ~s provided bad `raco-commands' spec: ~e\n"
dir
entry)))
(define (get-info-raco-commands full-info-proc)
(ensure-list (full-info-proc 'raco-commands (lambda () null))))
(define (all-tools)
(let* ([dirs (find-relevant-directories '(raco-commands) 'all-available)]
[tools (make-hash)])
(for ([i (in-list (filter-map get-info/full/skip dirs))]
[d (in-list dirs)])
(let ([entries (let ([l (if i
(i 'raco-commands (lambda () null))
null)])
(if (list? l)
l
(list l)))])
(for ([entry (in-list entries)])
(cond
[(and (list? entry)
(= (length entry) 4)
(string? (car entry))
(module-path? (cadr entry))
(string? (caddr entry))
(or (not (list-ref entry 3))
(real? (list-ref entry 3))))
(let ([p (hash-ref tools (car entry) #f)])
(when p
(eprintf
"warning: tool ~s registered twice: ~e and ~e\n"
(car entry)
(car p)
d)))
(let ([entry (let ([e (cadr entry)])
(if (or (string? e)
(and (pair? e)
(eq? (car e) 'file)
(relative-path? (cadr e))))
;; convert absolute path to realive to "info.rkt":
(list* (car entry)
(build-path d (if (pair? e)
(cadr e)
e))
(cddr entry))
;; module path is absolute already:
entry))])
(hash-set! tools (car entry) entry))]
[else
(eprintf "warning: ~s provided bad `raco-commands' spec: ~e\n"
d
entry)]))))
tools))
(define tools (make-hash))
(define dirs (find-relevant-directories '(raco-commands) 'all-available))
(define infos (filter-map get-info/full/skip dirs))
(for ([i (in-list infos)]
[d (in-list dirs)])
(define entries (get-info-raco-commands i))
(for ([entry (in-list entries)])
(check-valid-raco-commands-spec entry d)
(check-tool-not-registered-twice tools entry d)
(add-tool! tools (convert-entry entry d))))
tools)
(define (convert-entry tool-entry dir)
(define tool-mod-path (cadr tool-entry))
(if (non-module-tool-path? tool-mod-path)
(convert-module-tool-path tool-entry tool-mod-path dir)
tool-entry)) ;; module path is absolute already:
(define (non-module-tool-path? tool-mod-path)
(or (string? tool-mod-path)
(and (pair? tool-mod-path)
(eq? (car tool-mod-path) 'file)
(relative-path? (cadr tool-mod-path)))))
;; convert absolute path to relative to "info.rkt":
(define (convert-module-tool-path tool-entry tool-mod-path dir)
(define new-path
(build-path dir (if (pair? tool-mod-path)
(cadr tool-mod-path)
tool-mod-path)))
(list* (car tool-entry)
new-path
(cddr tool-entry)))
(define (add-tool! tools tool-entry)
(hash-set! tools (car tool-entry) tool-entry))