scheme/racket/geiser/modules.rkt

   1 ;;; modules.rkt -- module metadata
   2
   3 ;; Copyright (C) 2009, 2010, 2011, 2012, 2013 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 (path->name path)
  78   (if (path-string? path)
  79       (let* ([cpaths (map (compose unix-path->string path->directory-path)
  80                           (current-library-collection-paths))]
  81              [prefix-len (lambda (p)
  82                            (let ((pl (string-length p)))
  83                              (if (= pl (string-prefix-length p path))
  84                                  pl
  85                                  0)))]
  86              [lens (map prefix-len cpaths)]
  87              [real-path (substring path (apply max lens))])
  88         (if (absolute-path? real-path)
  89             (let-values ([(_ base __) (split-path path)])
  90               (unix-path->string base))
  91             (regexp-replace "\\.[^./]*$" real-path "")))
  92       path))
  93
  94 (define (module-path-name->name path)
  95   (cond [(path? path) (module-path-name->name (unix-path->string path))]
  96         ;; [(eq? path '#%kernel) "(kernel)"]
  97         [(path-string? path) (path->name path)]
  98         [(symbol? path) (symbol->string path)]
  99         [(list? path) (string-join (map (compose path->name ~a) path) "/")]
 100         [else (~a path)]))
 101
 102 (define (module-path-index->name mpi)
 103   (let ([rmp (module-path-index-resolve mpi)])
 104     (if (resolved-module-path? rmp)
 105         (module-path-name->name (resolved-module-path-name rmp))
 106         unknown-module-name)))
 107
 108 (define (namespace->module-name ns (p #f))
 109   (module-path-name->name (namespace->module-path-name ns p)))
 110
 111 (define (module-identifiers mod)
 112   (define (extract-ids ls)
 113     (append-map (lambda (idls)
 114                   (map car (cdr idls)))
 115                 ls))
 116   (let-values ([(reg syn)
 117                 (module-compiled-exports
 118                  (get-module-code (resolve-module-path
 119                                    (ensure-module-spec mod) #f)))])
 120     (values (extract-ids reg) (extract-ids syn))))
 121
 122 (define (skippable-dir? path)
 123   (call-with-values (lambda () (split-path path))
 124     (lambda (_ basename __)
 125       (member (path->string basename) '(".svn" "compiled")))))
 126
 127 (define path->symbol (compose string->symbol unix-path->string))
 128
 129 (define (path->entry path)
 130   (let ([ext (filename-extension path)])
 131     (and ext
 132          (or (bytes=? ext #"rkt") (bytes=? ext #"ss"))
 133          (not (bytes=? (bytes-append #"main" ext) (path->bytes path)))
 134          (let* ([path (unix-path->string path)]
 135                 [len (- (string-length path) (bytes-length ext) 1)])
 136            (substring path 0 len)))))
 137
 138 (define (ensure-path datum)
 139   (if (string? datum)
 140       (string->path datum)
 141       datum))
 142
 143 (define main-rkt (build-path "main.rkt"))
 144 (define main-ss (build-path "main.ss"))
 145
 146 (define ((visit-module-path reg?) path kind acc)
 147   (define (register e p)
 148     (when reg?
 149       (register-path (string->symbol e) (build-path (current-directory) p)))
 150     (values (cons e acc) reg?))
 151   (define (get-main path main)
 152     (and (file-exists? main) (build-path path main)))
 153   (define (find-main path)
 154     (parameterize ([current-directory path])
 155       (or (get-main path main-rkt) (get-main path main-ss))))
 156   (case kind
 157     [(file) (let ([entry (path->entry path)])
 158               (if (not entry) acc (register entry path)))]
 159     [(dir) (cond [(skippable-dir? path) (values acc #f)]
 160                  [(find-main path) => (curry register (unix-path->string path))]
 161                  [else (values acc reg?)])]
 162     [else acc]))
 163
 164 (define ((find-modules reg?) path acc)
 165   (if (directory-exists? path)
 166       (parameterize ([current-directory path])
 167         (fold-files (visit-module-path reg?) acc))
 168       acc))
 169
 170 (define (take-while pred lst)
 171   (let loop ([lst lst] [acc '()])
 172     (cond [(null? lst) (reverse acc)]
 173           [(pred (car lst)) (loop (cdr lst) (cons (car lst) acc))]
 174           [else (reverse acc)])))
 175
 176 (define (submodules mod)
 177   (let* ([mod-name (if (symbol? mod) mod (get-mod mod))]
 178          [mod-str (and (symbol? mod-name) (symbol->string mod-name))])
 179     (if mod-str
 180         (let ([ms (member mod-str (module-list))])
 181           (and ms
 182                (take-while (lambda (m) (string-prefix? mod-str m))
 183                            (cdr ms))))
 184         (find-submodules mod))))
 185
 186 (define (find-submodules path)
 187   (and (path-string? path)
 188        (let-values ([(dir base ign) (split-path path)])
 189          (and (or (equal? base main-rkt)
 190                   (equal? base main-ss))
 191               (map (lambda (m) (unix-path->string (build-path dir m)))
 192                    (remove "main" ((find-modules #f) dir '())))))))
 193
 194 (define (known-modules)
 195   (sort (foldl (find-modules #t)
 196                '()
 197                (current-library-collection-paths))
 198         string<?))
 199
 200 (define registered (make-hash))
 201 (define registered-paths (make-hash))
 202
 203 (define (get-path mod)
 204   (hash-ref registered mod #f))
 205
 206 (define (get-mod path)
 207   (hash-ref registered-paths path #f))
 208
 209 (define (register-path mod path)
 210   (hash-set! registered mod path)
 211   (hash-set! registered-paths path mod)
 212   path)
 213
 214 (define module-cache #f)
 215
 216 (define (update-module-cache)
 217   (when (not module-cache) (set! module-cache (known-modules))))
 218
 219 (define (module-list)
 220   (update-module-cache)
 221   module-cache)
 222
 223 (define (startup)
 224  (thread update-module-cache)
 225  (void))
 226
 227 (startup)