scheme/racket/geiser/modules.rkt

   1 ;;; modules.rkt -- module metadata
   2
   3 ;; Copyright (C) 2009, 2010, 2011 Jose Antonio Ortega Ruiz
   4
   5 ;; This program is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the Modified BSD License. You should
   7 ;; have received a copy of the license along with this program. If
   8 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
   9
  10 ;; Start date: Wed May 06, 2009 02:35
  11
  12 #lang racket
  13
  14 (provide load-module
  15          ensure-module-spec
  16          module-spec->namespace
  17          namespace->module-name
  18          namespace->module-path-name
  19          module-path-name->name
  20          module-spec->path-name
  21          module-path-index->name
  22          module-identifiers
  23          module-list
  24          submodules)
  25
  26 (require srfi/13
  27          syntax/modcode
  28          syntax/modresolve
  29          geiser/enter)
  30
  31 (define (ensure-module-spec spec)
  32   (cond [(symbol? spec) spec]
  33         [(not (string? spec)) #f]
  34         [else `(file ,spec)]))
  35
  36 (define (module-spec->namespace spec (lang #f) (current #t))
  37   (define (try-lang)
  38     (and lang
  39          (with-handlers ([exn? (const #f)])
  40            (load-module lang #f (current-namespace))
  41            (module->namespace lang))))
  42   (or (get-namespace spec)
  43       (try-lang)
  44       (and current (current-namespace))))
  45
  46 (define nowhere (open-output-nowhere))
  47
  48 (define (load-module spec (port #f) (ns #f))
  49   (parameterize ([current-error-port (or port nowhere)])
  50     (enter-module (ensure-module-spec spec))
  51     (when (namespace? ns)
  52       (current-namespace ns))))
  53
  54 (define (namespace->rmp ns)
  55   (with-handlers ([exn? (const #f)])
  56     (variable-reference->resolved-module-path
  57      (eval '(#%variable-reference) (or ns (current-namespace))))))
  58
  59 (define (namespace->module-path-name ns (p #f))
  60   (let ([rmp (namespace->rmp ns)])
  61     (or (and (resolved-module-path? rmp)
  62              (resolved-module-path-name rmp))
  63         p)))
  64
  65 (define (module-spec->path-name spec)
  66   (and (symbol? spec)
  67        (or (get-path spec)
  68            (register-path spec
  69                           (namespace->module-path-name
  70                            (module-spec->namespace spec #f #f))))))
  71
  72 (define unknown-module-name "*unresolved module*")
  73
  74 (define (unix-path->string path)
  75   (regexp-replace* "\\\\" (path->string path) "/"))
  76
  77 (define (module-path-name->name path)
  78   (cond [(path? path) (module-path-name->name (unix-path->string path))]
  79         ;; [(eq? path '#%kernel) "(kernel)"]
  80         [(string? path)
  81          (let* ([cpaths (map (compose unix-path->string path->directory-path)
  82                              (current-library-collection-paths))]
  83                 [prefix-len (lambda (p)
  84                               (let ((pl (string-length p)))
  85                                 (if (= pl (string-prefix-length p path))
  86                                     pl
  87                                     0)))]
  88                 [lens (map prefix-len cpaths)]
  89                 [real-path (substring path (apply max lens))])
  90            (if (absolute-path? real-path)
  91              (let-values ([(_ base __) (split-path path)])
  92                (unix-path->string base))
  93              (regexp-replace "\\.[^./]*$" real-path "")))]
  94         [(symbol? path) (symbol->string path)]
  95         [else unknown-module-name]))
  96
  97 (define (module-path-index->name mpi)
  98   (let ([rmp (module-path-index-resolve mpi)])
  99     (if (resolved-module-path? rmp)
 100         (module-path-name->name (resolved-module-path-name rmp))
 101         unknown-module-name)))
 102
 103 (define (namespace->module-name ns (p #f))
 104   (module-path-name->name (namespace->module-path-name ns p)))
 105
 106 (define (module-identifiers mod)
 107   (define (extract-ids ls)
 108     (append-map (lambda (idls)
 109                   (map car (cdr idls)))
 110                 ls))
 111   (let-values ([(reg syn)
 112                 (module-compiled-exports
 113                  (get-module-code (resolve-module-path
 114                                    (ensure-module-spec mod) #f)))])
 115     (values (extract-ids reg) (extract-ids syn))))
 116
 117 (define (skippable-dir? path)
 118   (call-with-values (lambda () (split-path path))
 119     (lambda (_ basename __)
 120       (member (path->string basename) '(".svn" "compiled")))))
 121
 122 (define path->symbol (compose string->symbol unix-path->string))
 123
 124 (define (path->entry path)
 125   (let ([ext (filename-extension path)])
 126     (and ext
 127          (or (bytes=? ext #"rkt") (bytes=? ext #"ss"))
 128          (not (bytes=? (bytes-append #"main" ext) (path->bytes path)))
 129          (let* ([path (unix-path->string path)]
 130                 [len (- (string-length path) (bytes-length ext) 1)])
 131            (substring path 0 len)))))
 132
 133 (define (ensure-path datum)
 134   (if (string? datum)
 135       (string->path datum)
 136       datum))
 137
 138 (define main-rkt (build-path "main.rkt"))
 139 (define main-ss (build-path "main.ss"))
 140
 141 (define ((visit-module-path reg?) path kind acc)
 142   (define (register e p)
 143     (when reg?
 144       (register-path (string->symbol e) (build-path (current-directory) p)))
 145     (values (cons e acc) reg?))
 146   (define (get-main path main)
 147     (and (file-exists? main) (build-path path main)))
 148   (define (find-main path)
 149     (parameterize ([current-directory path])
 150       (or (get-main path main-rkt) (get-main path main-ss))))
 151   (case kind
 152     [(file) (let ([entry (path->entry path)])
 153               (if (not entry) acc (register entry path)))]
 154     [(dir) (cond [(skippable-dir? path) (values acc #f)]
 155                  [(find-main path) => (curry register (unix-path->string path))]
 156                  [else (values acc reg?)])]
 157     [else acc]))
 158
 159 (define ((find-modules reg?) path acc)
 160   (if (directory-exists? path)
 161       (parameterize ([current-directory path])
 162         (fold-files (visit-module-path reg?) acc))
 163       acc))
 164
 165 (define (take-while pred lst)
 166   (let loop ([lst lst] [acc '()])
 167     (cond [(null? lst) (reverse acc)]
 168           [(pred (car lst)) (loop (cdr lst) (cons (car lst) acc))]
 169           [else (reverse acc)])))
 170
 171 (define (submodules mod)
 172   (let* ([mod-name (if (symbol? mod) mod (get-mod mod))]
 173          [mod-str (and (symbol? mod-name) (symbol->string mod-name))])
 174     (if mod-str
 175         (let ([ms (member mod-str (module-list))])
 176           (and ms
 177                (take-while (lambda (m) (string-prefix? mod-str m))
 178                            (cdr ms))))
 179         (find-submodules mod))))
 180
 181 (define (find-submodules path)
 182   (and (path-string? path)
 183        (let-values ([(dir base ign) (split-path path)])
 184          (and (or (equal? base main-rkt)
 185                   (equal? base main-ss))
 186               (map (lambda (m) (unix-path->string (build-path dir m)))
 187                    (remove "main" ((find-modules #f) dir '())))))))
 188
 189 (define (known-modules)
 190   (sort (foldl (find-modules #t)
 191                '()
 192                (current-library-collection-paths))
 193         string<?))
 194
 195 (define registered (make-hash))
 196 (define registered-paths (make-hash))
 197
 198 (define (get-path mod)
 199   (hash-ref registered mod #f))
 200
 201 (define (get-mod path)
 202   (hash-ref registered-paths path #f))
 203
 204 (define (register-path mod path)
 205   (hash-set! registered mod path)
 206   (hash-set! registered-paths path mod)
 207   path)
 208
 209 (define module-cache #f)
 210
 211 (define (update-module-cache)
 212   (when (not module-cache) (set! module-cache (known-modules))))
 213
 214 (define (module-list)
 215   (update-module-cache)
 216   module-cache)
 217
 218 (define (startup)
 219  (thread update-module-cache)
 220  (void))
 221
 222 (startup)