apropos/tests/apropos-test.scm

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