scheme/racket/geiser/modules.rkt

   1 ;;; modules.rkt -- module metadata
   2
   3 ;; Copyright (C) 2009, 2010 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-list)
  22
  23 (require srfi/13 geiser/enter)
  24
  25 (define (ensure-module-spec spec)
  26   (cond [(symbol? spec) spec]
  27         [(not (string? spec)) #f]
  28         [else `(file ,spec)]))
  29
  30 (define (module-spec->namespace spec (lang #f) (current #t))
  31   (define (try-lang)
  32     (and lang
  33          (with-handlers ([exn? (const #f)])
  34            (load-module lang #f (current-namespace))
  35            (module->namespace lang))))
  36   (or (get-namespace spec)
  37       (try-lang)
  38       (and current (current-namespace))))
  39
  40 (define nowhere (open-output-nowhere))
  41
  42 (define (load-module spec (port #f) (ns #f))
  43   (parameterize ([current-error-port (or port nowhere)])
  44     (enter-module (ensure-module-spec spec))
  45     (when (namespace? ns)
  46       (current-namespace ns))))
  47
  48 (define (namespace->module-path-name ns)
  49   (let ([rmp (variable-reference->resolved-module-path
  50               (eval '(#%variable-reference) ns))])
  51     (and (resolved-module-path? rmp)
  52          (resolved-module-path-name rmp))))
  53
  54 (define (module-spec->path-name spec)
  55   (and (symbol? spec)
  56        (or (get-path spec)
  57            (register-path spec
  58                           (namespace->module-path-name
  59                            (module-spec->namespace spec) #f #f)))))
  60
  61 (define (module-path-name->name path)
  62   (cond [(path? path)
  63          (let* ([path (path->string path)]
  64                 [cpaths (map (compose path->string path->directory-path)
  65                              (current-library-collection-paths))]
  66                 [prefix-len (lambda (p)
  67                               (let ((pl (string-length p)))
  68                                 (if (= pl (string-prefix-length p path))
  69                                     pl
  70                                     0)))]
  71                 [lens (map prefix-len cpaths)]
  72                 [real-path (substring path (apply max lens))])
  73            (if (absolute-path? real-path)
  74                (call-with-values (lambda () (split-path path))
  75                  (lambda (_ basename __) (path->string basename)))
  76                (regexp-replace "\\.[^./]*$" real-path "")))]
  77         ;; [(eq? path '#%kernel) "(kernel)"]
  78         [(string? path) path]
  79         [(symbol? path) (symbol->string path)]
  80         [else ""]))
  81
  82 (define namespace->module-name
  83   (compose module-path-name->name namespace->module-path-name))
  84
  85 (define (skippable-dir? path)
  86   (call-with-values (lambda () (split-path path))
  87     (lambda (_ basename __)
  88       (member (path->string basename) '(".svn" "compiled")))))
  89
  90 (define path->symbol (compose string->symbol path->string))
  91
  92 (define (path->entry path)
  93   (let ([ext (filename-extension path)])
  94     (and ext
  95          (or (bytes=? ext #"rkt") (bytes=? ext #"ss"))
  96          (not (bytes=? (bytes-append #"main" ext) (path->bytes path)))
  97          (let* ([path (path->string path)]
  98                 [len (- (string-length path) (bytes-length ext) 1)])
  99            (substring path 0 len)))))
 100
 101 (define (visit-module-path path kind acc)
 102   (define (register e p)
 103     (register-path (string->symbol e) (build-path (current-directory) p))
 104     (cons e acc))
 105   (define (find-main ext)
 106     (let ([m (build-path path (string-append "main." ext))])
 107       (and (file-exists? m) m)))
 108   (case kind
 109     [(file) (let ([entry (path->entry path)])
 110               (if (not entry) acc (register entry path)))]
 111     [(dir) (cond [(skippable-dir? path) (values acc #f)]
 112                  [(or (find-main "rkt") (find-main "ss")) =>
 113                   (curry register (path->string path))]
 114                  [else acc])]
 115     [else acc]))
 116
 117 (define (find-modules path acc)
 118   (if (directory-exists? path)
 119       (parameterize ([current-directory path])
 120         (fold-files visit-module-path acc))
 121       acc))
 122
 123 (define (known-modules)
 124   (sort (foldl find-modules '() (current-library-collection-paths)) string<?))
 125
 126 (define registered (make-hash))
 127
 128 (define (get-path mod) (hash-ref registered mod #f))
 129
 130 (define (register-path mod path)
 131   (hash-set! registered mod path)
 132   path)
 133
 134 (define module-cache #f)
 135
 136 (define (update-module-cache)
 137   (when (not module-cache) (set! module-cache (known-modules))))
 138
 139 (define (module-list)
 140   (update-module-cache)
 141   module-cache)
 142
 143 (define (startup)
 144  (thread update-module-cache)
 145  (void))
 146
 147 (startup)