racket/collects/tests/drracket/module-lang-test.rkt

#lang at-exp racket/gui
(require "private/module-lang-test-utils.rkt")
(provide run-test)

;; set up for tests that need external files
(write-test-modules
 (module module-lang-test-tmp1 mzscheme
   (provide (all-from-except mzscheme +)
            x)
   (define x 1))
 (module module-lang-test-tmp2 mzscheme
   (provide e)
   (define e #'1))
 (module module-lang-test-tmp3 mzscheme
   (define-syntax (bug-datum stx)
     (syntax-case stx ()
       [(dat . thing)
        (number? (syntax-e (syntax thing)))
        (syntax/loc stx (#%datum . thing))]))
   (provide #%module-begin [rename bug-datum #%datum]))
 (module module-lang-test-tmp4 racket/base
   (/ 888 2)
   (provide (except-out (all-from-out racket/base) #%top-interaction))))

(test @t{}
      #f
      @rx{Module Language: There must be a valid module
          Try starting your program with
          Interactions disabled}
      #t)
(test @t{1}
      #f
      @rx{Module Language: only a module expression is allowed
          Interactions disabled}
      #t)
(test @t{(module m racket) 1}
      #f
      @rx{Module Language: there can only be one expression in the definitions
          Interactions disabled}
      #t)
(test @t{.}
      #f
      @rx{Module Language: invalid module text
          read: illegal
          Interactions disabled}
      #t)
(test @t{#lang mzscheme
         (define x 1)}
      @t{x}
      "1")
(test @t{#lang m-z-scheme
         (define x 1)}
      #f
      @rx{Module Language: invalid module text
          collection not found
          Interactions disabled}
      #t)
(test @t{#lang racket
         3}
      #f
      "3")
(test @t{(module m racket (provide x) (define x 1))}
      @t{x}
      "1")
(test @t{(module m racket (define x 1))}
      @t{x}
      "1")
(test @t{(module m racket (define x 1) (define y 1) (provide y))}
      @t{x}
      "1")
(test @t{(module m racket (define x 1) (define y 2) (provide y))}
      @t{y}
      "2")
(test @t{(module m mzscheme (require mzlib/list))}
      @t{foldl}
      #rx"foldl")
(test @t{(module m mzscheme (require (rename mzlib/list local-foldl foldl)))}
      @t{local-foldl}
      #rx"foldl>")
(test @t{(module m mzscheme (require (all-except mzlib/list foldl)))}
      @t{first}
      #rx"first>")
(test @t{(module m mzscheme (require (all-except mzlib/list foldl)))}
      @t{foldl}
      ". . reference to an identifier before its definition: foldl")
(test @t{(module m mzscheme (require (prefix mz: mzscheme)))}
      @t{mz:+}
      #rx"procedure:[+]")
(test @t{(module n mzscheme (provide (all-from-except mzscheme +)))}
      @t{+}
      #rx"procedure:[+]")
(test @t{(module m mzscheme
           (require (prefix x: mzlib/list) mzlib/list))}
      @t{foldl}
      #rx"foldl>")
(test @t{(module m mzscheme
           (require (prefix x: mzlib/list) mzlib/list))}
      @t{x:foldl}
      #rx"foldl>")
(test @t{(module m (file @in-here{module-lang-test-tmp1.rkt}) x)}
      @t{x}
      "1")
;; + shouldn't be bound in the REPL because it isn't bound in the module.
(test @t{(module m (file @in-here{module-lang-test-tmp1.rkt}) x)}
      @t{+}
      ". . reference to an identifier before its definition: +")
(test @t{(module m mzscheme (provide lambda))}
      @t{(lambda (x) x)}
      #rx"<procedure")
(test @t{(module m mzscheme (define-syntax (m x) (syntax 1)) (provide m))}
      @t{(m)}
      "1")
(test @t{(module m mzscheme (define-syntax s (syntax 1)) (provide s))}
      @t{s}
      ". s: illegal use of syntax in: s")
(test @t{(module m mzscheme (define-syntax (x stx) #'(define a 10)) x x)}
      @t{a}
      ". . reference to an identifier before its definition: a")
(test @t{(module m mzscheme
           (define-syntax (x stx) #'(define-syntax (a stx) #'10))
           x
           x)}
      @t{a}
      ". . reference to an identifier before its definition: a")
(test @t{(module m mzscheme
           (define-syntax (x stx) #'(define a 10))
           x
           x
           (define a 77))}
      @t{a}
      "77")
(test @t{(module m mzscheme
           (define-syntax (x stx) #'(define-syntax (a stx) #'10))
           x
           x
           (define a 78))}
      @t{a}
      "78")
(test @t{(module m mzscheme
           (require-for-syntax (file @in-here{module-lang-test-tmp2.rkt}))
           (provide s)
           (define-syntax (s stx) e))}
      @t{(require 'm) s}
      @rx{compile: bad syntax;
          literal data is not allowed, because no #%datum syntax transformer
          is bound in: 1$})
(test @t{(module tmp mzscheme
           (provide (rename app #%app)
                    (rename -current-namespace current-namespace)
                    (rename -module->namespace module->namespace))
           (define x 2)
           (define -current-namespace error)
           (define -module->namespace error)
           (define-syntax app (syntax-rules () ((app . x) '(app . x)))))}
      @t{x}
      "2")
(test @t{#lang racket
         (eval 'cons)}
      #f
      @rx{compile: unbound identifier \(and no #%top syntax transformer is bound\) in: cons})
(test @t{(module m (file @in-here{module-lang-test-tmp1.rkt}) 1 2 3)}
      @t{1} ;; just make sure no errors.
      "1")

(test @t{#lang racket}
      @t{(begin-for-syntax (+ 1 2))}
      @t{})

(test @t{#lang racket}
      @t{(begin (struct s (x)) (struct t s (y)) (s-x (t 1 2)))}
      "1")

;; check that we have a working repl in the right language after
;; syntax errors, unless it's a bad language
(test @t{#lang racket
         (define x 1)
         (define y (/ 0))}
      @t{(+ 122 x)}
      @rx{. /: division by zero
          123}
      #t)
(test @t{#lang racket
         (define x 1)
         (define y (/ 0))}
      @t{(if x 123)}
      @rx{. /: division by zero
          . if: bad syntax.*"else"}
      #t)
(test @t{#lang mzscheme
         (define x 1)
         (define y (/ 0))}
      @t{(if x 123)}
      @rx{. /: division by zero
          123}
      #t)
(test @t{(module xx scheme/list
           (define x 1)
           (define y (/ 0)))}
      #f
      @rx{no #%module-begin binding in the module's language
          Interactions disabled:
          does not support a REPL \(no #%top-interaction\)}
      #t)
(test @t{(module xx (file @in-here{module-lang-test-tmp4.rkt})
           (define x 1)
           (* x 123))}
      #f
      @rx{444
          123
          Interactions disabled:
          does not support a REPL \(no #%top-interaction\)
          }
      #t)
(test @t{(module xx (file @in-here{this-file-does-not-exist})
           (define x 1)
           (* x 123))}
      #f
      @rx{cannot open input file
          Module Language: invalid language specification
          Interactions disabled}
      #t)
(test @t{#lang setup/infotab}
      #f
      ;; test the complete buffer, to make sure that there is no error
      "\nInteractions disabled: setup/infotab does not support a REPL (no #%top-interaction)"
      #t)

;; test racket/load behavior
(test @t{#lang racket/load
         (module m mzscheme (provide x) (define x 2))
         (require 'm)
         (printf "~s\n" x)
         (flush-output)}
      #f
      "2")
(test @t{#lang racket/load
         (module m mzscheme (provide x) (define x 2))
         (module n racket/base (require 'm) (provide y) (define y (* x x)))
         (require 'n)
         (printf "~s\n" y)
         (flush-output)}
      #f
      "4")

(test @t{#lang racket
         (define-syntax (f stx)
           (syntax-case stx ()
             [(f)
              (raise (make-exn:fail:syntax "both" (current-continuation-marks) (list #'f stx)))]))}
      @t{(f)}
      (string-append "> (f)\n"
                     ". both in:\n"
                     "  f\n"
                     "  (f)")
      #t)

(test @t{#lang racket/base}
      @t{(begin (values) 1)}
      "1")

(test @t{#lang racket/base}
      @t{    (eval '(values 1 2))}
      @t{1@"\n"2})
(test @t{#lang racket/base}
      @t{    (eval '(list 1 2))}
      @t{'(1 2)})
(test @t{#lang racket/base}
      @t{    (eval '(lambda ()))}
      @t{lambda: bad syntax in: (lambda ())})
(test @t{#lang racket/base}
      @t{(expt 3 (void))}
      @rx{expt: expected argument of type <number>; given #<void>})
(test @t{#lang racket/base}
      @t{1 2 ( 3 4}
      @t{1@"\n"2@"\n". read: expected a `)' to close `('})
(test @t{#lang racket/base}
      "1 2 . 3 4"
      "1\n2\n. read: illegal use of \".\"")
(test @t{#lang racket/base}
      "1 2 (lambda ()) 3 4"
      "1\n2\n. lambda: bad syntax in: (lambda ())")
(test @t{#lang racket/base}
      "1 2 x 3 4"
      "1\n2\n. . reference to an identifier before its definition: x")
(test @t{#lang racket/base}
      "1 2 (raise 1) 3 4"
      "1\n2\nuncaught exception: 1")
(test @t{#lang racket/base}
      "1 2 (raise #f) 3 4"
      "1\n2\nuncaught exception: #f")
(test @t{#lang racket/base}
      "(current-namespace (make-empty-namespace)) if"
      ". compile: unbound identifier (and no #%app syntax transformer is bound) in: #%top-interaction")
(test @t{#lang racket/base}
      (string-append
       "(let ([old (error-escape-handler)])\n"
       "(+ (let/ec k\n(dynamic-wind\n"
       "(lambda () (error-escape-handler (lambda () (k 5))))\n"
       "(lambda () (expt 3 #f))\n"
       "(lambda () (error-escape-handler old))))\n"
       "10))")
      ". . expt: expected argument of type <number>; given #f\n15")
(test @t{#lang racket/base}
      "(write (list (syntax x)))"
      "(.)")
(test @t{#lang racket/base}
      "(parameterize ([current-output-port (open-output-string)]) (write #'1))"
      "")
(test @t{#lang racket/base}
      "(write-special 1)"
      "1#t")
(test @t{#lang racket/gui}
      (format "~s ~s ~s"
              '(define s (make-semaphore 0))
              '(queue-callback
                (lambda ()
                  (dynamic-wind
                   void
                   (lambda () (expt 3 #f))
                   (lambda () (semaphore-post s)))))
              '(begin (yield s) (void)))
      ". . expt: expected argument of type <number>; given #f")
(test @t{#lang racket/base}
      (format "~s ~s" 
              '(define x 1) 
              '((λ (x y) y) (set! x (call/cc (lambda (x) x))) (x 3)))
      ". . procedure application: expected procedure, given: 3; arguments were: 3")
(test @t{#lang racket/base}
      (format "~s ~s ~s ~s"
              '(begin (define k (call/cc (λ (x) x)))
                      (define x 'wrong))
              '(set! x 'right)
              '(k 1)
              'x)
      "'right")
(test @t{#lang racket/base}
      (format "~s"
              '(call-with-continuation-prompt
                (lambda ()
                  (eval '(begin (abort-current-continuation
                                 (default-continuation-prompt-tag)
                                 1 2 3)
                                10)))
                (default-continuation-prompt-tag)
                list))
      "'(1 2 3)")
(test @t{#lang racket/gui}
      "(vector (new snip%))"
      "(vector .)")
(test @t{#lang racket/base}
      "(begin (thread (lambda () x)) (sleep 1/10))"
      ". . reference to an identifier before its definition: x")
(test @t{#lang racket/base}
      "(require texpict/utils)(disk 3)"
      ".")
(test @t{#lang racket/base}
      (string-append
       "(require mzlib/pretty)"
       "(pretty-print-print-hook (lambda x (expt 3 #f)))"
       "(list 1 2 3)")
      "'(1 2 3)")

;; test protection against user-code changing the namespace
(test @t{#lang racket/base
         (current-namespace (make-base-namespace))}
      "(+ 1 2)"
      "3")
(test @t{#lang racket/base
         (current-namespace (make-base-empty-namespace))}
      "(+ 1 2)"
      "3")


(require "private/drracket-test-util.rkt")
(fire-up-drscheme-and-run-tests run-test)