272 lines
8 KiB
Scheme
272 lines
8 KiB
Scheme
;;;; apropos-test.scm -*- Scheme -*-
|
|
;;;; Kon Lovett, Jul '18
|
|
|
|
;FIXME need better internal (system) symbol tests
|
|
|
|
(import test)
|
|
|
|
(cond-expand
|
|
(compiling
|
|
(print)
|
|
(print #<<EOS
|
|
*****
|
|
* Expect compiler wornings for type errors
|
|
*****
|
|
EOS
|
|
) )
|
|
(else) )
|
|
|
|
(test-begin "Apropos")
|
|
|
|
;;;
|
|
|
|
(import (chicken syntax))
|
|
(import (chicken sort))
|
|
(import apropos-api)
|
|
|
|
;;
|
|
|
|
(test-group "Parameters"
|
|
|
|
(test 10 (apropos-default-base))
|
|
;NOTE difficult test since a warning, not an error
|
|
;(test-error (apropos-default-base 27))
|
|
|
|
(test-assert (apropos-interning))
|
|
|
|
(test '() (apropos-default-options))
|
|
|
|
;what it isn't
|
|
(test-error (apropos-excluded-modules #f))
|
|
(test-error (apropos-excluded-modules "abc"))
|
|
(test-error (apropos-excluded-modules '(a 23 "c")))
|
|
(test-error (apropos-excluded-modules '(a (b "c") "d")))
|
|
(test-error (apropos-excluded-modules '(a (srfi -8) "d")))
|
|
;what it is
|
|
(test-assert (list? (apropos-excluded-modules)))
|
|
;invertable
|
|
(test (apropos-excluded-modules)
|
|
(apropos-excluded-modules (apropos-excluded-modules)))
|
|
(parameterize ((apropos-excluded-modules
|
|
(append '((foo bar baz) foo (srfi 0))
|
|
(apropos-excluded-modules))))
|
|
(test "foo.bar.baz" (car (apropos-excluded-modules)))
|
|
(test "foo" (cadr (apropos-excluded-modules)))
|
|
(test "srfi-0" (caddr (apropos-excluded-modules))) )
|
|
|
|
;not exposed
|
|
;(test '|| (toplevel-module-symbol))
|
|
)
|
|
|
|
;;
|
|
|
|
(define (symbol<? a b) (string<? (symbol->string a) (symbol->string b)))
|
|
(define (car-symbol<? a b) (symbol<? (car a) (car b)))
|
|
(define (cdar-symbol<? a b) (symbol<? (cdar a) (cdar b)))
|
|
|
|
(define-syntax *apropos-list-test
|
|
(syntax-rules ()
|
|
((*apropos-list-test ?msg ?exp ?val ?less?)
|
|
(test ?msg (sort ?exp ?less?) (sort ?val ?less?)) ) ) )
|
|
|
|
(define-syntax apropos-list-test
|
|
(syntax-rules ()
|
|
;
|
|
((apropos-list-test ?exp ?val)
|
|
(apropos-list-test "apropos-list" ?exp ?val) )
|
|
;
|
|
((apropos-list-test ?msg ?exp ?val)
|
|
(*apropos-list-test ?msg ?exp ?val symbol<?) ) ) )
|
|
|
|
(define-syntax apropos-information-list-test
|
|
(syntax-rules ()
|
|
;
|
|
((apropos-information-list-test ?exp ?val)
|
|
(apropos-information-list-test "apropos-information-list" ?exp ?val) )
|
|
;
|
|
((apropos-information-list-test ?msg ?exp ?val)
|
|
(*apropos-list-test ?msg ?exp ?val cdar-symbol<?) ) ) )
|
|
|
|
;;
|
|
|
|
(test-group "Imported"
|
|
(cond-expand
|
|
(csi
|
|
;tests wildcard module but restricts to just imported
|
|
(apropos-list-test "test w/ imported?: #t"
|
|
'(test#current-test-group test#test-exit test#test-run
|
|
test#current-test-applier test#current-test-handler
|
|
test#current-test-verbosity test#test-total-count test#test-group-inc!
|
|
test#current-test-epsilon test#current-test-group-reporter
|
|
test#test-failure-count test#test-end test#current-test-skipper
|
|
test#test-begin test#current-test-comparator)
|
|
;NOTE module+identifier pattern syntax has ' as lead tag so an evaluated arg
|
|
;must be quoted
|
|
(apropos-list ''(_ . test) #:imported? #t)) )
|
|
(else
|
|
;(almost) nothing imported so specify module & check the oblist
|
|
(apropos-list-test "test w/ specific module"
|
|
'(test#current-test-group test#test-exit test#test-run
|
|
test#current-test-applier test#current-test-handler
|
|
test#current-test-verbosity test#test-total-count test#test-group-inc!
|
|
test#current-test-epsilon test#current-test-group-reporter
|
|
test#test-failure-count test#test-end test#current-test-skipper
|
|
test#test-begin test#current-test-comparator)
|
|
;NOTE module+identifier pattern syntax has ' as lead tag so an evaluated arg
|
|
;must be quoted
|
|
(apropos-list ''(test . test))) ) )
|
|
)
|
|
|
|
;; build test symbols
|
|
|
|
(define (foobarproc0) 'foobarproc0)
|
|
(define (foobarproc1 a) 'foobarproc1)
|
|
(define (foobarproc2 a b) 'foobarproc2)
|
|
(define (foobarprocn a b . r) 'foobarprocn)
|
|
|
|
(define foobarprocx (lambda (a b c) 'foobarprocx))
|
|
|
|
;RQRD due to use of macro identifiers
|
|
(declare (compile-syntax))
|
|
|
|
(define-syntax foobarmacro1
|
|
(er-macro-transformer
|
|
(lambda (f r c)
|
|
'foobarmacro1 ) ) )
|
|
|
|
(define-syntax foobarmacro2
|
|
(syntax-rules ()
|
|
((_) 'foobarmacro1 ) ) )
|
|
|
|
(define foobarvar1 'foobarvar1)
|
|
(define foobarvar2 'foobarvar2)
|
|
|
|
(define Foobarvar1 'Foobarvar1)
|
|
(define Foobarvar2 'Foobarvar2)
|
|
|
|
#;(define (foocoreinline flag) (##core#inline "C_set_gc_report" flag))
|
|
#;(define fooprimitive (##core#primitive "C_get_memory_info"))
|
|
|
|
(define ##foo#bar1 '##foo#bar1)
|
|
(define ##foo#bar2 (lambda () '##foo#bar2))
|
|
|
|
(define ##bar#foo1 '##bar#foo1)
|
|
(define ##bar#foo2 (lambda () '##bar#foo2))
|
|
|
|
;; test for symbols
|
|
|
|
(test-group "Symbol List"
|
|
|
|
(apropos-list-test
|
|
'(foobarvar2 foobarvar1 foobarprocx foobarprocn foobarproc2 foobarproc1 foobarproc0)
|
|
(apropos-list 'foobar))
|
|
|
|
(apropos-list-test
|
|
'(foobarvar2 foobarvar1 foobarprocx foobarprocn foobarproc2 foobarproc1 foobarproc0)
|
|
(apropos-list "foobar"))
|
|
|
|
(apropos-list-test
|
|
'(##bar#foo1 ##bar#foo2 foobarmacro1 foobarmacro2 foobarproc0 foobarproc1 foobarproc2 foobarprocn foobarprocx foobarvar1 foobarvar2)
|
|
(apropos-list 'foo #:macros? #t #:internal? #t #:find #:name))
|
|
|
|
;NOTE #:split still works!
|
|
(apropos-list-test
|
|
'(##foo#bar1 ##foo#bar2)
|
|
(apropos-list 'foo #:macros? #t #:internal? #t #:split #:module))
|
|
|
|
(apropos-list-test
|
|
'(foobarvar2 foobarvar1 foobarprocx foobarprocn foobarproc2 foobarproc1 foobarproc0 foobarmacro1 foobarmacro2)
|
|
(apropos-list 'foobar #:macros? #t))
|
|
|
|
(apropos-list-test
|
|
'(foobarvar2 foobarvar1 foobarprocx foobarprocn foobarproc2 foobarproc1 foobarproc0 Foobarvar2 Foobarvar1)
|
|
(apropos-list 'foobar #:case-insensitive? #t))
|
|
|
|
(apropos-list-test
|
|
'(foobarvar2 foobarvar1 Foobarvar1 Foobarvar2)
|
|
(apropos-list ''".+barvar[12]"))
|
|
)
|
|
|
|
#; ;CHICKEN version dependent! Can fail so must be run manually
|
|
(test-group "Internal (hidden symbols)"
|
|
(apropos-list-test "internal check"
|
|
'(##sys#peek-and-free-c-string-list
|
|
##sys#peek-c-string-list
|
|
chicken.internal.syntax-rules#drop-right
|
|
chicken.internal.syntax-rules#syntax-rules-mismatch
|
|
chicken.internal.syntax-rules#take-right)
|
|
(apropos-list '(or "syntax-rules" "c-string-list") #:internal? #t))
|
|
)
|
|
|
|
;;
|
|
|
|
#|
|
|
#;14> (define foobarprocx (lambda (a b c) 'foobarprocx))
|
|
#;15> '(((|| . foobarmacro1) . macro))
|
|
(((||: . foobarmacro1) . macro))
|
|
#;16> '(((||: . foobarmacro1) . macro))
|
|
(((: . foobarmacro1) . macro))
|
|
#;17> ||
|
|
||:
|
|
#;18> ||:
|
|
|
|
Error: unbound variable: :
|
|
#;19> #:||
|
|
||:
|
|
#;20> (eq? #:|| #:||)
|
|
#t
|
|
#;21> (caaar (apropos-information-list 'foobarproc))
|
|
||:
|
|
#;22> (eq? #:|| (caaar (apropos-information-list 'foobarproc)))
|
|
#f
|
|
|#
|
|
|
|
;oh , my - #:|| from reader is not eq? #:|| from symbol-table
|
|
|
|
(test-group "Information List"
|
|
(apropos-information-list-test
|
|
'(((|| . foobarmacro1) . macro)
|
|
((|| . foobarmacro2) . macro)
|
|
((|| . foobarproc0) procedure)
|
|
((|| . foobarproc1) procedure a)
|
|
((|| . foobarproc2) procedure a b)
|
|
((|| . foobarprocn) procedure a b . r)
|
|
((|| . foobarprocx) procedure a b c)
|
|
((|| . foobarvar1) . variable)
|
|
((|| . foobarvar2) . variable))
|
|
(apropos-information-list 'foobar #:macros? #t #:internal? #t))
|
|
|
|
(test "apropos-information-list"
|
|
'(((|| . foobarproc0) procedure)
|
|
((|| . foobarproc1) procedure a)
|
|
((|| . foobarproc2) procedure a b)
|
|
((|| . foobarprocn) procedure a b . r)
|
|
((|| . foobarprocx) procedure a b c))
|
|
(apropos-information-list 'foobarproc #:macros? #t #:internal? #t #:sort #:module))
|
|
)
|
|
|
|
#| ;UNSUPPORTED
|
|
;;
|
|
|
|
(use environments)
|
|
|
|
(define tstenv1 (make-environment #t))
|
|
|
|
(environment-extend! tstenv1 'foobarprocx (lambda (a b c) 'foobarprocx))
|
|
(environment-extend! tstenv1 'foobarvar1 'foobarvar1)
|
|
(environment-extend! tstenv1 'foobarvar2 'foobarvar2)
|
|
(environment-extend! tstenv1 '##bar#foo1 '##bar#foo1)
|
|
(environment-extend! tstenv1 '##bar#foo1 (lambda () '##bar#foo1))
|
|
|
|
;make-environment cannot create a syntax-environment
|
|
;apropos always uses the ##sys#macro-environment for macro lookup
|
|
|
|
(test '(foobarprocx foobarvar2 foobarvar1 ##bar#foo1)
|
|
(apropos-list 'foo tstenv1 #:internal? #t))
|
|
|#
|
|
|
|
;;;
|
|
|
|
(test-end "Apropos")
|
|
|
|
(test-exit)
|