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 (make-mod name path ts code)
  23   (let ([deps (if code
  24                   (apply append (map cdr (module-compiled-imports code)))
  25                   null)])
  26     (mod name (path->string path) ts deps)))
  27
  28 (define loaded (make-hash))
  29
  30 (define (module-loaded? path)
  31   (with-handlers ([exn? (lambda (_) #f)])
  32     (let ([rp (module-path-index-resolve (module-path-index-join path #f))])
  33       (hash-has-key? loaded (resolved-module-path-name rp)))))
  34
  35 (define (enter-module mod)
  36   (dynamic-require mod #f)
  37   (check-latest mod))
  38
  39 (define (module-loader orig)
  40   (enter-load/use-compiled orig #f))
  41
  42 (define inhibit-eval (make-parameter #f))
  43
  44 (define (get-namespace mod)
  45   (let ([mod (cond [(symbol? mod) mod]
  46                    [(string? mod) (find-module! (string->path mod) mod)]
  47                    [(path? mod) (find-module! mod (path->string mod))]
  48                    [else mod])])
  49     (and mod
  50          (with-handlers ([exn? (lambda (_) #f)])
  51            (parameterize ([inhibit-eval #t])
  52              (module->namespace mod))))))
  53
  54 (define (find-module! path path-str)
  55   (let ([m (or (hash-ref loaded path #f)
  56                (let loop ([ps (remove path (resolve-paths path))]
  57                           [seen '()])
  58                  (cond [(null? ps) #f]
  59                        [(hash-ref loaded (car ps) #f) =>
  60                         (lambda (m)
  61                           (add-paths! m (cdr ps))
  62                           (add-paths! m (cons path seen))
  63                           m)]
  64                        [else (loop (cdr ps) (cons (car ps) seen))])))])
  65     (list 'file (or (and m (mod-load-path m)) path-str))))
  66
  67 (define (add-paths! m ps)
  68   (for-each (lambda (p) (hash-set! loaded p m)) ps))
  69
  70 (define (resolve-paths path)
  71   (define (find root rest)
  72     (let* ([alt-root (resolve-path root)]
  73            [same? (equal? root alt-root)])
  74       (cond [(null? rest) (cons root (if same? '() `(,alt-root)))]
  75             [else (let* ([c (car rest)]
  76                          [cs (cdr rest)]
  77                          [rps (find (build-path root c) cs)])
  78                     (if same?
  79                         rps
  80                         (append rps (find (build-path alt-root c) cs))))])))
  81   (let ([cmps (explode-path path)])
  82     (find (car cmps) (cdr cmps))))
  83
  84 (define (notify re? path)
  85   (when re? (fprintf (current-error-port) " [re-loading ~a]\n" path)))
  86
  87 (define (module-name? name)
  88   (and name (not (and (pair? name) (not (car name))))))
  89
  90 (define ((enter-load/use-compiled orig re?) path name)
  91   (when (inhibit-eval)
  92     (raise (make-exn:fail "namespace not found" (current-continuation-marks))))
  93   (printf "Loading ~s: ~s~%" name path)
  94   (if (module-name? name)
  95       ;; Module load:
  96       (with-handlers ([(lambda (exn)
  97                          (and (pair? name) (exn:get-module-code? exn)))
  98                        ;; Load-handler protocol: quiet failure when a
  99                        ;; submodule is not found
 100                        (lambda (exn) (void))])
 101         (let* ([code (get-module-code
 102                       path "compiled"
 103                       (lambda (e)
 104                         (parameterize ([compile-enforce-module-constants #f])
 105                           (compile e)))
 106                       (lambda (ext loader?) (load-extension ext) #f)
 107                       #:notify (lambda (chosen) (notify re? chosen)))]
 108                [dir (or (current-load-relative-directory) (current-directory))]
 109                [path (path->complete-path path dir)]
 110                [path (normal-case-path (simplify-path path))])
 111           (define-values (ts real-path) (get-timestamp path))
 112           (add-paths! (make-mod name path ts code) (resolve-paths path))
 113           (parameterize ([current-module-declare-source real-path])
 114             (eval code))))
 115       ;; Not a module:
 116       (begin (notify re? path) (orig path name))))
 117
 118 (define (get-timestamp path)
 119   (let ([ts (file-or-directory-modify-seconds path #f (lambda () #f))])
 120     (if ts
 121         (values ts path)
 122         (if (regexp-match? #rx#"[.]rkt$" (path->bytes path))
 123             (let* ([alt-path (path-replace-suffix path #".ss")]
 124                    [ts (file-or-directory-modify-seconds alt-path
 125                                                          #f
 126                                                          (lambda () #f))])
 127               (if ts
 128                   (values ts alt-path)
 129                   (values -inf.0 path)))
 130             (values -inf.0 path)))))
 131
 132 (define orig (current-load/use-compiled))
 133
 134 (define (check-latest mod)
 135   (define mpi (module-path-index-join mod #f))
 136   (define done (make-hash))
 137   (let loop ([mpi mpi])
 138     (define rpath (module-path-index-resolve mpi))
 139     (define path (let ([p (resolved-module-path-name rpath)])
 140                    (if (pair? p) (car p) p)))
 141     (when (path? path)
 142       (define npath (normal-case-path path))
 143       (unless (hash-ref done npath #f)
 144         (hash-set! done npath #t)
 145         (define mod (hash-ref loaded npath #f))
 146         (when mod
 147           (for-each loop (mod-depends mod))
 148           (define-values (ts actual-path) (get-timestamp npath))
 149           (when (ts . > . (mod-timestamp mod))
 150             (define orig (current-load/use-compiled))
 151             (parameterize ([current-load/use-compiled
 152                             (enter-load/use-compiled orig #f)]
 153                            [current-module-declare-name rpath]
 154                            [current-module-declare-source actual-path])
 155               ((enter-load/use-compiled orig #t) npath (mod-name mod)))))))))