chibi-scheme/lib/chibi/modules.scm

;; modules.scm -- module introspection utilities
;; Copyright (c) 2011-2013 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt

;;> Module introspection library.

(define (file->sexp-list file)
  (call-with-input-file file
    (lambda (in)
      (port-source?-set! in #t)
      (let lp ((res '()))
        (let ((x (read in)))
          (if (eof-object? x)
              (reverse res)
              (lp (cons x res))))))))

(define (module? x)
  (and (vector? x)
       (>= (vector-length x) 4)
       (or (list? (vector-ref x 0)) (not (vector-ref x 0)))))

(define (module-ast mod) (vector-ref mod 3))
(define (module-ast-set! mod x) (vector-set! mod 3 x))

(define (module-name mod)
  (if (pair? mod)
      (car mod)
      (let lp ((ls *modules*))
        (and (pair? ls)
             (if (eq? mod (cdar ls))
                 (caar ls)
                 (lp (cdr ls)))))))

(define (module-dir mod)
  (let ((name (module-name mod)))
    (if (member name '((chibi) (meta)))
        ""
        (module-name-prefix name))))

;; assuming mod-name was found in file, resolves to the containing lib dir
(define (module-lib-dir file mod-name)
  (let lp ((ls (map (lambda (x)
                      (if (number? x) (number->string x) (symbol->string x)))
                    (reverse mod-name)))
           (path (reverse (string-split (path-strip-extension file) #\/))))
    (if (and (pair? ls) (pair? path) (equal? (car ls) (car path)))
        (lp (cdr ls) (cdr path))
        (if (null? path)
            "."
            (string-join (reverse path) "/")))))

(define (module-metas mod metas . o)
  (let* ((mod (if (module? mod) mod (find-module mod)))
         (dir (if (pair? o) (car o) (module-dir mod))))
    (let lp ((ls (module-meta-data mod)) (res '()))
      (cond
       ((not (pair? ls)) (reverse res))
       ((and (pair? (car ls)) (memq (caar ls) metas))
        (lp (cdr ls) (append (reverse (cdar ls)) res)))
       (else (lp (cdr ls) res))))))

(define (module-extract-declaration-files mod decls)
  (let* ((mod (if (module? mod) mod (find-module mod)))
         (dir (module-dir mod)))
    (define (module-file f)
      (find-module-file (string-append dir f)))
    (map module-file (reverse (module-metas mod decls dir)))))

(define (module-includes mod)
  (module-extract-declaration-files mod '(include)))

(define (module-include-library-declarations mod)
  (module-extract-declaration-files mod '(include-library-declarations)))

(define (module-shared-includes mod)
  (let* ((mod (if (module? mod) mod (find-module mod)))
         (dir (module-dir mod)))
    (define (module-file f)
      (find-module-file (string-append dir f ".stub")))
    (let lp ((ls (reverse (module-metas mod '(include-shared)))) (res '()))
      (cond ((null? ls) (reverse res))
            ((module-file (car ls)) => (lambda (x) (lp (cdr ls) (cons x res))))
            (else (lp (cdr ls) res))))))

(define (analyze-module-source name mod recursive?)
  (let ((env (make-environment))
        (dir (module-dir mod)))
    (define (resolve-file file)
      (find-module-file (string-append dir file)))
    (define (include-source file)
      (cond ((resolve-file file)
             => (lambda (x) (cons 'begin (file->sexp-list x))))
            (else (error "couldn't find include" file))))
    (cond
     ((equal? '(chibi) name)
      (env-define! env '*features* *features*)
      (env-define! env '*shared-object-extension* *shared-object-extension*)
      (%import env (primitive-environment 7) #f #t))
     (else
      (resolve-module-imports env (module-meta-data mod))))
    (let lp ((ls (module-meta-data mod)) (res '()))
      (cond
       ((not (pair? ls))
        (reverse res))
       (else
        (case (and (pair? (car ls)) (caar ls))
          ((import import-immutable)
           (for-each
            (lambda (m)
              (let* ((mod2-name+imports (resolve-import m))
                     (mod2-name (car mod2-name+imports)))
                (if recursive?
                    (analyze-module mod2-name #t))))
            (cdar ls))
           (lp (cdr ls) res))
          ((include include-ci)
           (lp (append (map include-source (cdar ls)) (cdr ls)) res))
          ((include-library-declarations)
           (lp (append (append-map file->sexp-list (map resolve-file (cdar ls))) (cdr ls)) res))
          ((include-shared include-shared-optionally)
           (for-each
            (lambda (file)
              (let ((f (string-append file *shared-object-extension*)))
                (cond ((find-module-file f) => (lambda (path) (load path env))))))
            (cdar ls)))
          ((begin body)
           (let lp2 ((ls2 (cdar ls)) (res res))
             (cond
              ((pair? ls2)
               (let ((x (analyze (car ls2) env)))
                 (eval (car ls2) env)
                 (lp2 (cdr ls2) (cons x res))))
              (else
               (lp (cdr ls) res)))))
          (else
           (lp (cdr ls) res))))))))

(define (analyze-module name . o)
  (let ((recursive? (and (pair? o) (car o)))
        (mod (load-module name)))
    (cond
     ((not (module-ast mod))
      (module-ast-set! mod '())       ; break cycles, just in case
      (module-ast-set! mod (analyze-module-source name mod recursive?))))
    mod))

(define (module-ref mod var-name . o)
  (let ((cell (env-cell (module-env (if (module? mod) mod (load-module mod)))
                        var-name)))
    (if cell
        (cdr cell)
        (if (pair? o) (car o) (error "no binding in module" mod var-name)))))

(define (module-contains? mod var-name)
  (and (env-cell (module-env (if (module? mod) mod (load-module mod))) var-name)
       #t))

(define (module-defines? name mod var-name)
  (let lp ((ls (module-ast (analyze-module name))))
    (cond
     ((null? ls) #f)
     ((and (set? (car ls))
           (eq? var-name (ref-name (set-var (car ls))))))
     ((seq? (car ls)) (lp (append (seq-ls (car ls)) (cdr ls))))
     (else (lp (cdr ls))))))

(define (containing-module x)
  (let lp1 ((ls (reverse *modules*)))
    (and (pair? ls)
         (let ((env (module-env (cdar ls))))
           (let lp2 ((e-ls (if (environment? env) (env-exports env) '())))
             (if (null? e-ls)
                 (lp1 (cdr ls))
                 (let ((cell (env-cell env (car e-ls))))
                   (if (and (eq? x (cdr cell))
                            (or (opcode? x)
                                (module-defines? (caar ls) (cdar ls) (car cell))))
                       (car ls)
                       (lp2 (cdr e-ls))))))))))

(define (procedure-analysis x . o)
  (cond
   ((opcode? x)
    #f)
   (else
    (let ((name (if (procedure? x) (procedure-name x) x))
          (mod (or (and (pair? o) (car o))
                   (containing-module x))))
      (and mod
           (let lp ((ls (module-ast (analyze-module (module-name mod)))))
             (and (pair? ls)
                  (cond
                   ((and (set? (car ls))
                         (eq? name (ref-name (set-var (car ls)))))
                    (set-value (car ls)))
                   ((seq? (car ls))
                    (lp (append (seq-ls (car ls)) (cdr ls))))
                   (else
                    (lp (cdr ls)))))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; finding all available modules

(define (module-file? file)
  (let ((len (string-length file)))
    (and (> len 4) (equal? ".sld" (substring file (- len 4))))))

(define (read-static-modules file)
  (protect (exn (else '()))
    (call-with-input-file file
      (lambda (in)
        (let lp ((res '()))
          (let ((expr (read in)))
            (cond
             ((eof-object? expr)
              res)
             ((and (pair? expr) (eq? 'define-library (car expr)))
              (let ((name (cadr expr))
                    (exports (cond ((assq 'export (cddr expr)) => cdr)
                                   (else '()))))
                (lp (cons (cons name (make-module exports #f #f)) res))))
             (else
              (lp res)))))))))

(define no-module-depth-limit 2)

(define (available-modules-in-directory dir depth res)
  (call-with-values
      (lambda ()
        (partition file-directory?
                   (map (lambda (f) (string-append dir "/" f))
                        (remove (lambda (f) (member f '("." "..")))
                                (directory-files dir)))))
    (lambda (dirs files)
      (let ((mods (append-map read-static-modules
                              (filter module-file? files))))
        (if (and (null? mods) (>= depth no-module-depth-limit))
            res
            (let ((depth (if (pair? mods) 0 (+ 1 depth))))
              (let lp ((ls dirs) (res (append mods res)))
                (if (null? ls)
                    res
                    (lp (cdr ls)
                        (available-modules-in-directory (car ls) depth res)
                        )))))))))

(define (available-modules)
  (let lp ((ls (current-module-path)) (res *modules*))
    (if (null? ls)
        res
        (lp (cdr ls)
            (available-modules-in-directory (car ls) 0 res)))))

(define (modules-exporting-identifier name)
  (let lp ((ls (available-modules))
           (res '()))
    (cond
     ((null? ls) (reverse res))
     ((and (memq name (module-exports (cdar ls)))
           (not (assoc (caar ls) res)))
      (lp (cdr ls) (cons (car ls) res)))
     (else (lp (cdr ls) res)))))