scheme/racket/geiser/enter.rkt

   1 ;;; enter.rkt -- custom module loaders
   2
   3 ;; Copyright (C) 2010, 2012 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 Mar 31, 2010 21:53
  11
  12 #lang racket/base
  13
  14 (require syntax/modcode
  15          (for-syntax racket/base)
  16          racket/path)
  17
  18 (provide get-namespace enter-module module-loader module-loaded?)
  19
  20 (struct mod (name load-path timestamp depends))
  21
  22 (define loaded (make-hash))
  23
  24 (define (module-loaded? path)
  25   (with-handlers ([exn? (lambda (_) #f)])
  26     (let ([rp (module-path-index-resolve (module-path-index-join path #f))])
  27       (hash-has-key? loaded (resolved-module-path-name rp)))))
  28
  29 (define (enter-module mod)
  30   (dynamic-require mod #f)
  31   (check-latest mod))
  32
  33 (define (module-loader orig)
  34   (enter-load/use-compiled orig #f))
  35
  36 (define (notify re? path)
  37   (when re?
  38     (fprintf (current-error-port) " [re-loading ~a]\n" path)))
  39
  40 (define inhibit-eval (make-parameter #f))
  41
  42 (define (get-namespace mod)
  43   (let ([mod (cond [(symbol? mod) mod]
  44                    [(string? mod) (find-module! (string->path mod) mod)]
  45                    [(path? mod) (find-module! mod (path->string mod))]
  46                    [else mod])])
  47     (and mod
  48          (with-handlers ([exn? (lambda (_) #f)])
  49            (parameterize ([inhibit-eval #t])
  50              (module->namespace mod))))))
  51
  52 (define (find-module! path path-str)
  53   (let ([m (or (hash-ref loaded path #f)
  54                (let loop ([ps (remove path (resolve-paths path))]
  55                           [seen '()])
  56                  (cond [(null? ps) #f]
  57                        [(hash-ref loaded (car ps) #f) =>
  58                         (lambda (m)
  59                           (add-paths! m (cdr ps))
  60                           (add-paths! m (cons path seen))
  61                           m)]
  62                        [else (loop (cdr ps) (cons (car ps) seen))])))])
  63     (list 'file (or (and m (mod-load-path m)) path-str))))
  64
  65 (define (add-paths! m ps)
  66   (for-each (lambda (p) (hash-set! loaded p m)) ps))
  67
  68 (define (resolve-paths path)
  69   (define (find root rest)
  70     (let* ([alt-root (resolve-path root)]
  71            [same? (equal? root alt-root)])
  72       (cond [(null? rest) (cons root (if same? '() `(,alt-root)))]
  73             [else (let* ([c (car rest)]
  74                          [cs (cdr rest)]
  75                          [rps (find (build-path root c) cs)])
  76                     (if same?
  77                         rps
  78                         (append rps (find (build-path alt-root c) cs))))])))
  79   (let ([cmps (explode-path path)])
  80     (find (car cmps) (cdr cmps))))
  81
  82 (define ((enter-load/use-compiled orig re?) path name)
  83   (when (inhibit-eval)
  84     (raise (make-exn:fail "namespace not found"
  85                           (current-continuation-marks))))
  86   (if name
  87       ;; Module load:
  88       (let ([code (get-module-code path "compiled" compile
  89                                    (lambda (ext loader?)
  90                                      (load-extension ext)
  91                                      #f)
  92                                    #:notify (lambda (chosen)
  93                                               (notify re? chosen)))]
  94             [path (normal-case-path
  95                    (simplify-path
  96                     (path->complete-path path
  97                                          (or (current-load-relative-directory)
  98                                              (current-directory)))))])
  99         ;; Record module timestamp and dependencies:
 100         (let ([m (mod name
 101                       (path->string path)
 102                       (get-timestamp path)
 103                       (if code
 104                           (apply append
 105                                  (map cdr
 106                                       (module-compiled-imports code)))
 107                           null))])
 108           (add-paths! m (resolve-paths path)))
 109         ;; Evaluate the module:
 110         (eval code))
 111       ;; Not a module:
 112       (begin
 113         (notify re? path)
 114         (orig path name))))
 115
 116 (define (get-timestamp path)
 117   (file-or-directory-modify-seconds path #f (lambda () -inf.0)))
 118
 119 (define (check-latest mod)
 120   (let ([mpi (module-path-index-join mod #f)]
 121         [done (make-hash)])
 122     (let loop ([mpi mpi])
 123       (let* ([rpath (module-path-index-resolve mpi)]
 124              [path (resolved-module-path-name rpath)])
 125         (when (path? path)
 126           (let ([path (normal-case-path path)])
 127             (unless (hash-ref done path #f)
 128               (hash-set! done path #t)
 129               (let ([mod (hash-ref loaded path #f)])
 130                 (when mod
 131                   (for-each loop (mod-depends mod))
 132                   (let ([ts (get-timestamp path)])
 133                     (when (ts . > . (mod-timestamp mod))
 134                       (let ([orig (current-load/use-compiled)])
 135                         (parameterize ([current-load/use-compiled
 136                                         (enter-load/use-compiled orig #f)]
 137                                        [current-module-declare-name rpath])
 138                           ((enter-load/use-compiled orig #t)
 139                            path
 140                            (mod-name mod)))))))))))))))