scheme/racket/geiser/enter.rkt

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