[bpt/guile.git] / test-suite / tests / modules.test

;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*-

;;;; Copyright (C) 2006, 2007, 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-modules)
  :use-module (srfi srfi-1)
  :use-module ((ice-9 streams)  ;; for test purposes
               #:renamer (symbol-prefix-proc 's:))
  :use-module (test-suite lib))


(define (every? . args)
  (not (not (apply every args))))


\f
;;;
;;; Foundations.
;;;

(with-test-prefix "foundations"

  (pass-if "modules don't remain anonymous"
    ;; This is a requirement for `psyntax': it stores module names and relies
    ;; on being able to `resolve-module' them.
    (let ((m (make-module)))
      (and (module-name m)
           (eq? m (resolve-module (module-name m))))))

  (pass-if "module-add!"
    (let ((m (make-module))
          (value (cons 'x 'y)))
      (module-add! m 'something (make-variable value))
      (eq? (module-ref m 'something) value)))

  (pass-if "module-define!"
    (let ((m (make-module))
          (value (cons 'x 'y)))
      (module-define! m 'something value)
      (eq? (module-ref m 'something) value)))

  (pass-if "module-use!"
    (let ((m (make-module))
          (import (make-module)))
      (module-define! m 'something 'something)
      (module-define! import 'imported 'imported)
      (module-use! m import)
      (and (eq? (module-ref m 'something) 'something)
           (eq? (module-ref m 'imported)  'imported)
           (module-local-variable m 'something)
           (not (module-local-variable m 'imported))
           #t)))

  (pass-if "module-use! (duplicates local binding)"
    ;; Imported bindings can't override locale bindings.
    (let ((m (make-module))
          (import (make-module)))
      (module-define! m 'something 'something)
      (module-define! import 'something 'imported)
      (module-use! m import)
      (eq? (module-ref m 'something) 'something)))

  (pass-if "module-locally-bound?"
     (let ((m (make-module))
           (import (make-module)))
       (module-define! m 'something #t)
       (module-define! import 'imported #t)
       (module-use! m import)
       (and (module-locally-bound? m 'something)
            (not (module-locally-bound? m 'imported)))))

  (pass-if "module-{local-,}variable"
     (let ((m (make-module))
           (import (make-module)))
       (module-define! m 'local #t)
       (module-define! import 'imported #t)
       (module-use! m import)
       (and (module-local-variable m 'local)
            (not (module-local-variable m 'imported))
            (eq? (module-variable m 'local)
                 (module-local-variable m 'local))
            (eq? (module-local-variable import 'imported)
                 (module-variable m 'imported)))))

  (pass-if "module-import-interface"
    (and (every? (lambda (sym iface)
                   (eq? (module-import-interface (current-module) sym)
                        iface))
                 '(current-module exception:bad-variable every)
                 (cons the-scm-module
                       (map resolve-interface
                            '((test-suite lib) (srfi srfi-1)))))

         ;; For renamed bindings, a custom interface is used so we can't
         ;; check for equality with `eq?'.
         (every? (lambda (sym iface)
                   (let ((import
                          (module-import-interface (current-module) sym)))
                     (equal? (module-name import)
                             (module-name iface))))
                 '(s:make-stream s:stream-car s:stream-cdr)
                 (make-list 3 (resolve-interface '(ice-9 streams))))))

  (pass-if "module-reverse-lookup"
    (let ((mods   '((srfi srfi-1) (test-suite lib)      (ice-9 streams)))
          (syms   '(every         exception:bad-variable make-stream))
          (locals '(every         exception:bad-variable s:make-stream)))
      (every? (lambda (var sym)
                (eq? (module-reverse-lookup (current-module) var)
                     sym))
              (map module-variable
                   (map resolve-interface mods)
                   syms)
              locals))))


\f
;;;
;;; Observers.
;;;

(with-test-prefix "observers"

  (pass-if "weak observer invoked"
    (let* ((m (make-module))
           (invoked 0))
      (module-observe-weak m (lambda (mod)
                               (if (eq? mod m)
                                   (set! invoked (+ invoked 1)))))
      (module-define! m 'something 2)
      (module-define! m 'something-else 1)
      (= invoked 2)))

  (pass-if "all weak observers invoked"
    ;; With the two-argument `module-observe-weak' available in previous
    ;; versions, the observer would get unregistered as soon as the observing
    ;; closure gets GC'd, making it impossible to use an anonymous lambda as
    ;; the observing procedure.

    (let* ((m (make-module))
           (observer-count 500)
           (observer-ids (let loop ((i observer-count)
                                    (ids '()))
                           (if (= i 0)
                               ids
                               (loop (- i 1) (cons (make-module) ids)))))
           (observers-invoked (make-hash-table observer-count)))

      ;; register weak observers
      (for-each (lambda (id)
                  (module-observe-weak m id
                                       (lambda (m)
                                         (hashq-set! observers-invoked
                                                     id #t))))
                observer-ids)

      (gc)

      ;; invoke them
      (module-call-observers m)

      ;; make sure all of them were invoked
      (->bool (every (lambda (id)
                       (hashq-ref observers-invoked id))
                     observer-ids))))

  (pass-if "imported bindings updated"
    (let ((m (make-module))
          (imported (make-module)))
      ;; Beautify them, notably adding them a public interface.
      (beautify-user-module! m)
      (beautify-user-module! imported)

      (module-use! m (module-public-interface imported))
      (module-define! imported 'imported-binding #t)

      ;; At this point, `imported-binding' is local to IMPORTED.
      (and (not (module-variable m 'imported-binding))
           (begin
             ;; Export `imported-binding' from IMPORTED.
             (module-export! imported '(imported-binding))

             ;; Make sure it is now visible from M.
             (module-ref m 'imported-binding))))))


\f
;;;
;;; Duplicate bindings handling.
;;;

(with-test-prefix "duplicate bindings"

  (pass-if "simple duplicate handler"
    ;; Import the same binding twice.
    (let* ((m (make-module))
           (import1 (make-module))
           (import2 (make-module))
           (handler-invoked? #f)
           (handler (lambda (module name int1 val1 int2 val2 var val)
                      (set! handler-invoked? #t)
                      ;; Keep the first binding.
                      (or var (module-local-variable int1 name)))))

      (set-module-duplicates-handlers! m (list handler))
      (module-define! m 'something 'something)
      (set-module-name! import1 'imported-module-1)
      (set-module-name! import2 'imported-module-2)
      (module-define! import1 'imported 'imported-1)
      (module-define! import2 'imported 'imported-2)
      (module-use! m import1)
      (module-use! m import2)
      (and (eq? (module-ref m 'imported) 'imported-1)
           handler-invoked?))))

\f
;;;
;;; Lazy binder.
;;;

(with-test-prefix "lazy binder"

  (pass-if "not invoked"
    (let ((m (make-module))
          (invoked? #f))
      (module-define! m 'something 2)
      (set-module-binder! m (lambda args (set! invoked? #t) #f))
      (and (module-ref m 'something)
           (not invoked?))))

  (pass-if "not invoked (module-add!)"
    (let ((m (make-module))
          (invoked? #f))
      (set-module-binder! m (lambda args (set! invoked? #t) #f))
      (module-add! m 'something (make-variable 2))
      (and (module-ref m 'something)
           (not invoked?))))

  (pass-if "invoked (module-ref)"
    (let ((m (make-module))
          (invoked? #f))
      (set-module-binder! m (lambda args (set! invoked? #t) #f))
      (false-if-exception (module-ref m 'something))
      invoked?))

  (pass-if "invoked (module-define!)"
    (let ((m (make-module))
          (invoked? #f))
      (set-module-binder! m (lambda args (set! invoked? #t) #f))
      (module-define! m 'something 2)
      (and invoked?
           (eq? (module-ref m 'something) 2))))

  (pass-if "honored (ref)"
    (let ((m (make-module))
          (invoked? #f)
          (value (cons 'x 'y)))
      (set-module-binder! m
                          (lambda (mod sym define?)
                            (set! invoked? #t)
                            (cond ((not (eq? m mod))
                                   (error "invalid module" mod))
                                  (define?
                                   (error "DEFINE? shouldn't be set"))
                                  (else
                                   (make-variable value)))))
      (and (eq? (module-ref m 'something) value)
           invoked?))))


\f
;;;
;;; Higher-level features.
;;;

(with-test-prefix "autoload"

  (pass-if "module-autoload!"
     (let ((m (make-module)))
       (module-autoload! m '(ice-9 q) '(make-q))
       (not (not (module-ref m 'make-q)))))

  (pass-if "autoloaded"
     (catch #t
       (lambda ()
	 ;; Simple autoloading.
	 (eval '(begin
		  (define-module (test-autoload-one)
		    :autoload (ice-9 q) (make-q))
		  (not (not make-q)))
	       (current-module)))
	(lambda (key . args)
	  #f)))

  ;; In Guile 1.8.0 this failed because the binder in
  ;; `make-autoload-interface' would try to remove the autoload interface
  ;; from the module's "uses" without making sure it is still part of these
  ;; "uses".
  ;;
  (pass-if "autoloaded+used"
     (catch #t
       (lambda ()
	 (eval '(begin
		  (define-module (test-autoload-two)
		    :autoload (ice-9 q) (make-q)
		    :use-module (ice-9 q))
		  (not (not make-q)))
	       (current-module)))
	(lambda (key . args)
	  #f))))
Commit	Line	Data
6e7d5622 KR	1	;;;; modules.test --- exercise some of guile's module stuff -- scheme --
6e7d5622 KR	2
16f451f3	3	;;;; Copyright (C) 2006, 2007, 2009 Free Software Foundation, Inc.
6e7d5622 KR	4	;;;;
	5	;;;; This library is free software; you can redistribute it and/or
	6	;;;; modify it under the terms of the GNU Lesser General Public
	7	;;;; License as published by the Free Software Foundation; either
53befeb7 NJ	8	;;;; version 3 of the License, or (at your option) any later version.
53befeb7 NJ	9	;;;;
6e7d5622 KR	10	;;;; This library is distributed in the hope that it will be useful,
	11	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	12	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	13	;;;; Lesser General Public License for more details.
53befeb7	14	;;;;
6e7d5622 KR	15	;;;; You should have received a copy of the GNU Lesser General Public
	16	;;;; License along with this library; if not, write to the Free Software
	17	;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
	18
608860a5 LC	19	(define-module (test-suite test-modules)
	20	:use-module (srfi srfi-1)
	21	:use-module ((ice-9 streams) ;; for test purposes
	22	#:renamer (symbol-prefix-proc 's:))
	23	:use-module (test-suite lib))
	24
	25
	26	(define (every? . args)
	27	(not (not (apply every args))))
	28
	29
	30	\f
	31	;;;
	32	;;; Foundations.
	33	;;;
	34
	35	(with-test-prefix "foundations"
	36
16f451f3 LC	37	(pass-if "modules don't remain anonymous"
	38	;; This is a requirement for `psyntax': it stores module names and relies
	39	;; on being able to `resolve-module' them.
	40	(let ((m (make-module)))
	41	(and (module-name m)
	42	(eq? m (resolve-module (module-name m))))))
	43
608860a5 LC	44	(pass-if "module-add!"
	45	(let ((m (make-module))
	46	(value (cons 'x 'y)))
	47	(module-add! m 'something (make-variable value))
	48	(eq? (module-ref m 'something) value)))
	49
	50	(pass-if "module-define!"
	51	(let ((m (make-module))
	52	(value (cons 'x 'y)))
	53	(module-define! m 'something value)
	54	(eq? (module-ref m 'something) value)))
	55
	56	(pass-if "module-use!"
	57	(let ((m (make-module))
	58	(import (make-module)))
	59	(module-define! m 'something 'something)
	60	(module-define! import 'imported 'imported)
	61	(module-use! m import)
	62	(and (eq? (module-ref m 'something) 'something)
	63	(eq? (module-ref m 'imported) 'imported)
	64	(module-local-variable m 'something)
	65	(not (module-local-variable m 'imported))
	66	#t)))
	67
	68	(pass-if "module-use! (duplicates local binding)"
	69	;; Imported bindings can't override locale bindings.
	70	(let ((m (make-module))
	71	(import (make-module)))
	72	(module-define! m 'something 'something)
	73	(module-define! import 'something 'imported)
	74	(module-use! m import)
	75	(eq? (module-ref m 'something) 'something)))
	76
	77	(pass-if "module-locally-bound?"
	78	(let ((m (make-module))
	79	(import (make-module)))
	80	(module-define! m 'something #t)
	81	(module-define! import 'imported #t)
	82	(module-use! m import)
	83	(and (module-locally-bound? m 'something)
	84	(not (module-locally-bound? m 'imported)))))
	85
	86	(pass-if "module-{local-,}variable"
	87	(let ((m (make-module))
	88	(import (make-module)))
	89	(module-define! m 'local #t)
	90	(module-define! import 'imported #t)
	91	(module-use! m import)
	92	(and (module-local-variable m 'local)
	93	(not (module-local-variable m 'imported))
	94	(eq? (module-variable m 'local)
	95	(module-local-variable m 'local))
	96	(eq? (module-local-variable import 'imported)
	97	(module-variable m 'imported)))))
	98
	99	(pass-if "module-import-interface"
	100	(and (every? (lambda (sym iface)
	101	(eq? (module-import-interface (current-module) sym)
	102	iface))
	103	'(current-module exception:bad-variable every)
	104	(cons the-scm-module
	105	(map resolve-interface
	106	'((test-suite lib) (srfi srfi-1)))))
	107
108	;; For renamed bindings, a custom interface is used so we can't
109	;; check for equality with `eq?'.
110	(every? (lambda (sym iface)
111	(let ((import
112	(module-import-interface (current-module) sym)))
113	(equal? (module-name import)
114	(module-name iface))))
115	'(s:make-stream s:stream-car s:stream-cdr)
116	(make-list 3 (resolve-interface '(ice-9 streams))))))
117
118	(pass-if "module-reverse-lookup"
119	(let ((mods '((srfi srfi-1) (test-suite lib) (ice-9 streams)))
120	(syms '(every exception:bad-variable make-stream))
121	(locals '(every exception:bad-variable s:make-stream)))
122	(every? (lambda (var sym)
123	(eq? (module-reverse-lookup (current-module) var)
124	sym))
125	(map module-variable
126	(map resolve-interface mods)
127	syms)
128	locals))))
129
130
131	\f
132	;;;
133	;;; Observers.
134	;;;
135
136	(with-test-prefix "observers"
137
138	(pass-if "weak observer invoked"
139	(let* ((m (make-module))
140	(invoked 0))
141	(module-observe-weak m (lambda (mod)
142	(if (eq? mod m)
143	(set! invoked (+ invoked 1)))))
144	(module-define! m 'something 2)
145	(module-define! m 'something-else 1)
146	(= invoked 2)))
147
148	(pass-if "all weak observers invoked"
149	;; With the two-argument `module-observe-weak' available in previous
150	;; versions, the observer would get unregistered as soon as the observing
151	;; closure gets GC'd, making it impossible to use an anonymous lambda as
152	;; the observing procedure.
153
154	(let* ((m (make-module))
155	(observer-count 500)
156	(observer-ids (let loop ((i observer-count)
157	(ids '()))
158	(if (= i 0)
159	ids
160	(loop (- i 1) (cons (make-module) ids)))))
161	(observers-invoked (make-hash-table observer-count)))
162
163	;; register weak observers
164	(for-each (lambda (id)
165	(module-observe-weak m id
166	(lambda (m)
167	(hashq-set! observers-invoked
168	id #t))))
169	observer-ids)
170
171	(gc)
172
173	;; invoke them
174	(module-call-observers m)
175
176	;; make sure all of them were invoked
177	(->bool (every (lambda (id)
178	(hashq-ref observers-invoked id))
179	observer-ids))))
180
181	(pass-if "imported bindings updated"
182	(let ((m (make-module))
183	(imported (make-module)))
184	;; Beautify them, notably adding them a public interface.
185	(beautify-user-module! m)
186	(beautify-user-module! imported)
187
188	(module-use! m (module-public-interface imported))
189	(module-define! imported 'imported-binding #t)
190
191	;; At this point, `imported-binding' is local to IMPORTED.
192	(and (not (module-variable m 'imported-binding))
193	(begin
194	;; Export `imported-binding' from IMPORTED.
195	(module-export! imported '(imported-binding))
196
197	;; Make sure it is now visible from M.
198	(module-ref m 'imported-binding))))))
199
200
201	\f
202	;;;
203	;;; Duplicate bindings handling.
204	;;;
205
206	(with-test-prefix "duplicate bindings"
207
208	(pass-if "simple duplicate handler"
209	;; Import the same binding twice.
210	(let* ((m (make-module))
211	(import1 (make-module))
212	(import2 (make-module))
213	(handler-invoked? #f)
214	(handler (lambda (module name int1 val1 int2 val2 var val)
215	(set! handler-invoked? #t)
216	;; Keep the first binding.
217	(or var (module-local-variable int1 name)))))
218
219	(set-module-duplicates-handlers! m (list handler))
220	(module-define! m 'something 'something)
221	(set-module-name! import1 'imported-module-1)
222	(set-module-name! import2 'imported-module-2)
223	(module-define! import1 'imported 'imported-1)
224	(module-define! import2 'imported 'imported-2)
225	(module-use! m import1)
226	(module-use! m import2)
227	(and (eq? (module-ref m 'imported) 'imported-1)
228	handler-invoked?))))
229
230	\f
231	;;;
232	;;; Lazy binder.
233	;;;
234
235	(with-test-prefix "lazy binder"
236
237	(pass-if "not invoked"
238	(let ((m (make-module))
239	(invoked? #f))
240	(module-define! m 'something 2)
241	(set-module-binder! m (lambda args (set! invoked? #t) #f))
242	(and (module-ref m 'something)
243	(not invoked?))))
244
245	(pass-if "not invoked (module-add!)"
246	(let ((m (make-module))
247	(invoked? #f))
248	(set-module-binder! m (lambda args (set! invoked? #t) #f))
249	(module-add! m 'something (make-variable 2))
250	(and (module-ref m 'something)
251	(not invoked?))))
252
253	(pass-if "invoked (module-ref)"
254	(let ((m (make-module))
255	(invoked? #f))
256	(set-module-binder! m (lambda args (set! invoked? #t) #f))
257	(false-if-exception (module-ref m 'something))
258	invoked?))
259
260	(pass-if "invoked (module-define!)"
261	(let ((m (make-module))
262	(invoked? #f))
263	(set-module-binder! m (lambda args (set! invoked? #t) #f))
264	(module-define! m 'something 2)
265	(and invoked?
266	(eq? (module-ref m 'something) 2))))
267
268	(pass-if "honored (ref)"
269	(let ((m (make-module))
270	(invoked? #f)
271	(value (cons 'x 'y)))
272	(set-module-binder! m
273	(lambda (mod sym define?)
274	(set! invoked? #t)
275	(cond ((not (eq? m mod))
276	(error "invalid module" mod))
277	(define?
278	(error "DEFINE? shouldn't be set"))
279	(else
280	(make-variable value)))))
281	(and (eq? (module-ref m 'something) value)
282	invoked?))))
283
284
285	\f
286	;;;
287	;;; Higher-level features.
288	;;;
6e7d5622 KR	289
	290	(with-test-prefix "autoload"
	291
608860a5 LC	292	(pass-if "module-autoload!"
	293	(let ((m (make-module)))
	294	(module-autoload! m '(ice-9 q) '(make-q))
	295	(not (not (module-ref m 'make-q)))))
	296
6e7d5622 KR	297	(pass-if "autoloaded"
	298	(catch #t
	299	(lambda ()
	300	;; Simple autoloading.
	301	(eval '(begin
	302	(define-module (test-autoload-one)
	303	:autoload (ice-9 q) (make-q))
	304	(not (not make-q)))
	305	(current-module)))
	306	(lambda (key . args)
	307	#f)))
	308
	309	;; In Guile 1.8.0 this failed because the binder in
	310	;; `make-autoload-interface' would try to remove the autoload interface
	311	;; from the module's "uses" without making sure it is still part of these
	312	;; "uses".
	313	;;
	314	(pass-if "autoloaded+used"
	315	(catch #t
	316	(lambda ()
	317	(eval '(begin
	318	(define-module (test-autoload-two)
	319	:autoload (ice-9 q) (make-q)
	320	:use-module (ice-9 q))
	321	(not (not make-q)))
	322	(current-module)))
	323	(lambda (key . args)
	324	#f))))