;;;
;;; reload.scm - reloading modules
;;;
;;;  Copyright(C) 2002 by Alex Shinn <foof@synthcode.com>
;;;
;;;  Permission to use, copy, modify, distribute this software and
;;;  accompanying documentation for any purpose is hereby granted,
;;;  provided that existing copyright notices are retained in all
;;;  copies and that this notice is included verbatim in all
;;;  distributions.
;;;  This software is provided as is, without express or implied
;;;  warranty.  In no circumstances the author(s) shall be liable
;;;  for any damages arising out of the use of this software.
;;;
;;;  $Id: reload.scm,v 1.3 2002/11/15 01:51:18 shirok Exp $
;;;

;;; Created:    <2002-11-06 16:02:55 foof>
;;; Time-stamp: <2002-11-13 10:11:58 foof>
;;; Author:     Alex Shinn <foof@synthcode.com>
;;; Slightly modified by Shiro Kawai

;; Development-only utility to reload modules while retaining data.

(define-module gauche.reload
  (use srfi-1)
  (use srfi-2)
  (use file.util)
  (use srfi-13)
  (use gauche.parameter)
  (export reload reload-modified-modules
          module-reload-rules reload-verbose)
  )
(select-module gauche.reload)

;; parameter reload-verbose
;;   If true, reload and reload-modified-modules reports what they are
;;   doing.
(define reload-verbose (make-parameter #f))

;; parameter module-reload-rules
;;   <rules>       : (<mod-rule> ...)
;;   <mod-rule>    : (<mod-pattern> <rule> ...)
;;   <mod-pattern> : symbol module name, or symbol containing glob pattern
;;   <rule>        : procedure | symbol | regexp
;;                 | (and <rule> ...)
;;                 | (or  <rule> ...)
;;                 | (not <rule>)
(define module-reload-rules (make-parameter '()))

;; make a regexp from a basic glob, handles *, ? and [] groups, adapted
;; from the pleac_guile version
(define (glob->regexp pat)
  (let loop ((chars (string->list pat)) (ls '("^")))
    (if (null? chars)
      (string->regexp (string-concatenate (reverse (cons "$" ls))))
      (let1 c (car chars)
        (if (eq? c #\\)
          (loop (cddr chars) (cons (cadr chars) ls))
          (loop (cdr chars)
                (cons (case c
                        ((#\*) "[^.]*")
                        ((#\?) "[^.]")
                        ((#\[) "[")
                        ((#\]) "]")
                        ((#\.) "\\.")
                        (else  (make-string 1 c)))
                      ls)))))))

;; find-file-in-paths from file.util doesn't work on foo/bar searches
(define (find-in-path file path)
  (find file-is-regular?
        (map (lambda (d)
               (sys-normalize-pathname (string-append d "/" file)))
             path)))

;; procedure reload <module-name> &optional <rule> ...
;;   
(define (reload module-name . predicates)
  (let1 mod (find-module module-name)
    (if (not mod)
        (warn "no such module: ~S" module-name)
        (let ((table (module-table mod))
              (saves (make-hash-table 'eq?)))
          ;; remember data
          (if (not (null? predicates))
              (hash-table-for-each
               table
               (lambda (sym gloc)
                 (let1 value (eval sym mod)
                   (define (check keep?)
                     (cond ((procedure? keep?) (keep? value))
                           ((symbol? keep?) (eq? keep? sym))
                           ((regexp? keep?)
                            (rxmatch keep? (symbol->string sym)))
                           ((null? keep?) #f)
                           ((pair? keep?)
                            (case (car keep?)
                              ((and) (every check (cdr keep?)))
                              ((or)  (any check (cdr keep?)))
                              ((not) (not (check (cdr keep?))))
                              (else ;; just recurse on other lists
                               (or (check (car keep?))
                                   (check (cdr keep?))))))
                           (else (error "invalid predicate: " keep?))))
                   (let loop ((preds predicates))
                     (if (not (null? preds))
                         (if (check (car preds))
                             (begin
                               (when (reload-verbose)
                                 (format #t "keeping value of ~S\n" sym))
                               (hash-table-put! saves sym value))
                             (loop (cdr preds)))))))))
          ;; reload
          (load (%module-name->path module-name))
          ;; restore any remembered data
          (hash-table-for-each
           saves
           (lambda (sym value)
             (eval `(set! ,sym (quote ,value)) mod)))))))


;; procedure reload-modified-modules &optional <reload-rules>
;;   Reloads modules that are modified after this module is loaded.
(define reload-modified-modules
  (let ((init (sys-time))
        (mod-times (make-hash-table 'eq?)))
    (lambda rl
      ;; get default rules from module-reload-rules, and convert to
      ;; regexps up front
      (define rules
        (map (lambda (x)
               (cons (glob->regexp (symbol->string (car x))) (cdr x)))
             (if (pair? rl) (car rl) (module-reload-rules))))
      ;; search for the module name in ls
      (define (find-rule name ls)
        (cond ((null? ls) '())
              ((rxmatch (caar ls) name) (cdar ls))
              (else (find-rule name (cdr ls)))))
      ;; check each loaded module to see if it has changed
      (let1 now (sys-time)
        (for-each
         (lambda (mod)
           (and-let* ((name (module-name mod))
                      (last-load (hash-table-get mod-times name init))
                      (p1 (string-append (%module-name->path name) ".scm"))
                      (path (find-in-path p1 *load-path*))
                      (last-mod (slot-ref (sys-stat path) 'mtime))
                      (rule (find-rule (symbol->string name) rules)))
             (when (> last-mod last-load)
               (when (reload-verbose)
                 (format #t "reloading: ~S\n" name))
               (hash-table-put! mod-times name now)
               (reload name rule))))
         (all-modules))))))

(provide "gauche/reload")

