modules.scm (3577B)
1 ;;; modules.scm -- module metadata 2 3 ;; Copyright (C) 2009, 2010, 2011, 2018 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: Mon Mar 02, 2009 02:00 11 12 (define-module (geiser modules) 13 #:export (symbol-module 14 program-module 15 module-name? 16 module-path 17 find-module 18 all-modules 19 submodules 20 module-location) 21 #:use-module (geiser utils) 22 #:use-module (system vm program) 23 #:use-module (system vm debug) 24 #:use-module (ice-9 regex) 25 #:use-module (ice-9 session) 26 #:use-module (srfi srfi-1)) 27 28 ;; Return hash table mapping filename to list of modules defined in that 29 ;; file. H/t andy wingo. 30 (define (fill-file->module-mapping! ret) 31 (define (record-module m) 32 (let ((f (module-filename m))) 33 (hash-set! ret f (cons m (hash-ref ret f '()))))) 34 (define (visit-module m) 35 (record-module m) 36 (hash-for-each (lambda (k v) (visit-module v)) 37 (module-submodules m))) 38 (visit-module (resolve-module '() #f)) 39 ret) 40 41 (define file->modules (fill-file->module-mapping! (make-hash-table))) 42 43 (define (program-file p) 44 (let ((src (program-source p 0))) 45 (and (pair? src) (cadr src)))) 46 47 (define (program-module p) 48 (let* ((f (program-file p)) 49 (mods (or (hash-ref file->modules f) 50 (hash-ref (fill-file->module-mapping! file->modules) f)))) 51 (and (pair? mods) (not (null? mods)) (car mods)))) 52 53 (define (module-name? module-name) 54 (and (list? module-name) 55 (not (null? module-name)) 56 (every symbol? module-name))) 57 58 (define (symbol-module sym . all) 59 (and sym 60 (catch 'module-name 61 (lambda () 62 (apropos-fold (lambda (module name var init) 63 (if (eq? name sym) 64 (throw 'module-name (module-name module)) 65 init)) 66 #f 67 (regexp-quote (symbol->string sym)) 68 (if (or (null? all) (not (car all))) 69 (apropos-fold-accessible (current-module)) 70 apropos-fold-all))) 71 (lambda (key . args) 72 (and (eq? key 'module-name) (car args)))))) 73 74 (define (module-location name) 75 (make-location (module-path name) #f)) 76 77 (define (find-module mod-name) 78 (and (module-name? mod-name) 79 (resolve-module mod-name #f #:ensure #f))) 80 81 (define (module-path module-name) 82 (and (module-name? module-name) 83 (or ((@@ (ice-9 session) module-filename) module-name) 84 (module-filename (resolve-module module-name #f))))) 85 86 (define (submodules mod) 87 (hash-map->list (lambda (k v) v) (module-submodules mod))) 88 89 (define (root-modules) 90 (submodules (resolve-module '() #f))) 91 92 (define (all-modules) 93 (define (maybe-name m) 94 (and (module-kind m) (format #f "~A" (module-name m)))) 95 (let* ((guile (resolve-module '(guile))) 96 (roots (remove (lambda (m) (eq? m guile)) (root-modules))) 97 (children (append-map all-child-modules roots))) 98 (cons "(guile)" (filter-map maybe-name children)))) 99 100 (define* (all-child-modules mod #:optional (seen '())) 101 (let ((cs (filter (lambda (m) (not (member m seen))) (submodules mod)))) 102 (fold (lambda (m all) (append (all-child-modules m all) all)) 103 (list mod) 104 cs)))