;;;; 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)