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 (notify re? path)
  43   (when re?
  44     (fprintf (current-error-port) " [re-loading ~a]\n" path)))
  45
  46 (define inhibit-eval (make-parameter #f))
  47
  48 (define (get-namespace mod)
  49   (let ([mod (cond [(symbol? mod) mod]
  50                    [(string? mod) (find-module! (string->path mod) mod)]
  51                    [(path? mod) (find-module! mod (path->string mod))]
  52                    [else mod])])
  53     (and mod
  54          (with-handlers ([exn? (lambda (_) #f)])
  55            (parameterize ([inhibit-eval #t])
  56              (module->namespace mod))))))
  57
  58 (define (find-module! path path-str)
  59   (let ([m (or (hash-ref loaded path #f)
  60                (let loop ([ps (remove path (resolve-paths path))]
  61                           [seen '()])
  62                  (cond [(null? ps) #f]
  63                        [(hash-ref loaded (car ps) #f) =>
  64                         (lambda (m)
  65                           (add-paths! m (cdr ps))
  66                           (add-paths! m (cons path seen))
  67                           m)]
  68                        [else (loop (cdr ps) (cons (car ps) seen))])))])
  69     (list 'file (or (and m (mod-load-path m)) path-str))))
  70
  71 (define (add-paths! m ps)
  72   (for-each (lambda (p) (hash-set! loaded p m)) ps))
  73
  74 (define (resolve-paths path)
  75   (define (find root rest)
  76     (let* ([alt-root (resolve-path root)]
  77            [same? (equal? root alt-root)])
  78       (cond [(null? rest) (cons root (if same? '() `(,alt-root)))]
  79             [else (let* ([c (car rest)]
  80                          [cs (cdr rest)]
  81                          [rps (find (build-path root c) cs)])
  82                     (if same?
  83                         rps
  84                         (append rps (find (build-path alt-root c) cs))))])))
  85   (let ([cmps (explode-path path)])
  86     (find (car cmps) (cdr cmps))))
  87
  88 (define ((enter-load/use-compiled orig re?) path name)
  89   (when (inhibit-eval)
  90     (raise (make-exn:fail "namespace not found" (current-continuation-marks))))
  91   (if (and name (or (not (list? name)) (car name))) ;; submodule names are lists
  92       ;; Module load:
  93       (let* ([code (get-module-code
  94                     path "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              [dir (or (current-load-relative-directory) (current-directory))]
 101              [path (path->complete-path path dir)]
 102              [path (normal-case-path (simplify-path path))])
 103         (define-values (ts real-path) (get-timestamp path))
 104         (add-paths! (make-mod name path ts code) (resolve-paths path))
 105         (parameterize ([current-module-declare-source real-path]) (eval code)))
 106       ;; Not a module:
 107       (begin (notify re? path) (orig path name))))
 108
 109
 110 (define (get-timestamp path)
 111   (let ([ts (file-or-directory-modify-seconds path #f (lambda () #f))])
 112     (if ts
 113         (values ts path)
 114         (if (regexp-match? #rx#"[.]rkt$" (path->bytes path))
 115             (let* ([alt-path (path-replace-suffix path #".ss")]
 116                    [ts (file-or-directory-modify-seconds alt-path
 117                                                          #f
 118                                                          (lambda () #f))])
 119               (if ts
 120                   (values ts alt-path)
 121                   (values -inf.0 path)))
 122             (values -inf.0 path)))))
 123
 124 (define (check-latest mod)
 125   (define mpi (module-path-index-join mod #f))
 126   (define done (make-hash))
 127   (let loop ([mpi mpi])
 128     (define rpath (module-path-index-resolve mpi))
 129     (define path (let ([p (resolved-module-path-name rpath)])
 130                    (if (pair? p) (car p) p)))
 131     (when (path? path)
 132       (define npath (normal-case-path path))
 133       (unless (hash-ref done npath #f)
 134         (hash-set! done npath #t)
 135         (define mod (hash-ref loaded npath #f))
 136         (when mod
 137           (for-each loop (mod-depends mod))
 138           (define-values (ts actual-path) (get-timestamp npath))
 139           (when (ts . > . (mod-timestamp mod))
 140             (define orig (current-load/use-compiled))
 141             (parameterize ([current-load/use-compiled
 142                             (enter-load/use-compiled orig #f)]
 143                            [current-module-declare-name rpath]
 144                            [current-module-declare-source actual-path])
 145               ((enter-load/use-compiled orig #t) npath (mod-name mod)))))))))