From cb94b0ee7e781b0a6bf30f3fddfbca48fd87f125 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Wed, 31 Aug 2011 18:26:06 -0400 Subject: [PATCH] adding check-expect --- examples/checking.rkt | 8 +++ js-assembler/runtime-src/baselib-check.js | 6 +- .../runtime-src/baselib-primitives.js | 70 ++++++++++++++++++- lang/check-expect/check-expect.rkt | 6 +- lang/kernel.rkt | 12 +++- lang/whalesong.rkt | 30 ++++++-- 6 files changed, 120 insertions(+), 12 deletions(-) create mode 100644 examples/checking.rkt diff --git a/examples/checking.rkt b/examples/checking.rkt new file mode 100644 index 0000000..2ee955e --- /dev/null +++ b/examples/checking.rkt @@ -0,0 +1,8 @@ +#lang planet dyoo/whalesong + +(define (greet name) + (string-append "hello" name)) + +(check-expect (greet "danny") "hello danny") +(check-expect (greet "huh") "this should fail") +(check-expect (greet "world") "hello world") diff --git a/js-assembler/runtime-src/baselib-check.js b/js-assembler/runtime-src/baselib-check.js index fde0998..6df8dcc 100644 --- a/js-assembler/runtime-src/baselib-check.js +++ b/js-assembler/runtime-src/baselib-check.js @@ -238,7 +238,9 @@ 'placeholder'); - + var checkSrcloc = makeCheckArgumentType( + baselib.srclocs.isSrcloc, + 'srcloc'); ////////////////////////////////////////////////////////////////////// @@ -275,6 +277,6 @@ exports.checkByte = checkByte; exports.checkBoolean = checkBoolean; exports.checkPlaceholder = checkPlaceholder; - + exports.checkSrcloc = checkSrcloc; }(this.plt.baselib)); diff --git a/js-assembler/runtime-src/baselib-primitives.js b/js-assembler/runtime-src/baselib-primitives.js index d68dc7a..605a93e 100644 --- a/js-assembler/runtime-src/baselib-primitives.js +++ b/js-assembler/runtime-src/baselib-primitives.js @@ -83,6 +83,7 @@ var checkMutableBox = baselib.check.checkMutableBox; var checkInspector = baselib.check.checkInspector; var checkPlaceholder = baselib.check.checkPlaceholder; + var checkSrcloc = baselib.check.checkSrcloc; ////////////////////////////////////////////////////////////////////// @@ -1285,7 +1286,7 @@ 1, function(MACHINE) { var n = checkInteger(MACHINE, 'even?', 0); - return baselib.numbers.equals(0, baselib.numbers.modulo(n, 2)) + return baselib.numbers.equals(0, baselib.numbers.modulo(n, 2)); }); installPrimitiveProcedure( @@ -1293,7 +1294,7 @@ 1, function(MACHINE) { var n = checkInteger(MACHINE, 'odd?', 0); - return baselib.numbers.equals(1, baselib.numbers.modulo(n, 2)) + return baselib.numbers.equals(1, baselib.numbers.modulo(n, 2)); }); @@ -1987,6 +1988,71 @@ + installPrimitiveProcedure( + 'srcloc', + 5, + function(MACHINE) { + var source = MACHINE.env[MACHINE.env.length - 1]; + var line = checkNatural(MACHINE, 'srcloc', 1); + var column = checkNatural(MACHINE, 'srcloc', 2); + var position = checkNatural(MACHINE, 'srcloc', 3); + var span = checkNatural(MACHINE, 'srcloc', 4); + return baselib.srclocs.makeSrcloc(source, line, column, position, span); + }); + installPrimitiveProcedure( + 'make-srcloc', + 5, + function(MACHINE) { + var source = MACHINE.env[MACHINE.env.length - 1]; + var line = checkNatural(MACHINE, 'make-srcloc', 1); + var column = checkNatural(MACHINE, 'make-srcloc', 2); + var position = checkNatural(MACHINE, 'make-srcloc', 3); + var span = checkNatural(MACHINE, 'make-srcloc', 4); + return baselib.srclocs.makeSrcloc(source, line, column, position, span); + }); + installPrimitiveProcedure( + 'srcloc?', + 1, + function(MACHINE) { + return baselib.srclocs.isSrcloc(MACHINE.env[MACHINE.env.length - 1]); + }); + installPrimitiveProcedure( + 'srcloc-source', + 1, + function(MACHINE) { + return baselib.srclocs.srclocSource(checkSrcloc(MACHINE, 'srcloc-source', 0)); + }); + installPrimitiveProcedure( + 'srcloc-line', + 1, + function(MACHINE) { + return baselib.srclocs.srclocLine(checkSrcloc(MACHINE, 'srcloc-line', 0)); + }); + installPrimitiveProcedure( + 'srcloc-column', + 1, + function(MACHINE) { + return baselib.srclocs.srclocColumn(checkSrcloc(MACHINE, 'srcloc-column', 0)); + }); + installPrimitiveProcedure( + 'srcloc-position', + 1, + function(MACHINE) { + return baselib.srclocs.srclocPosition(checkSrcloc(MACHINE, 'srcloc-position', 0)); + }); + installPrimitiveProcedure( + 'srcloc-span', + 1, + function(MACHINE) { + return baselib.srclocs.srclocSpan(checkSrcloc(MACHINE, 'srcloc-span', 0)); + }); + + + + + + + exports['Primitives'] = Primitives; exports['installPrimitiveProcedure'] = installPrimitiveProcedure; exports['installPrimitiveClosure'] = installPrimitiveClosure; diff --git a/lang/check-expect/check-expect.rkt b/lang/check-expect/check-expect.rkt index 911cc1e..58a5b68 100644 --- a/lang/check-expect/check-expect.rkt +++ b/lang/check-expect/check-expect.rkt @@ -1,9 +1,9 @@ -#lang s-exp "../kernel.rkt" +#lang s-exp "../base.rkt" (require (for-syntax racket/base)) (provide check-expect - check-within + ;check-within ;check-error run-tests) @@ -37,7 +37,7 @@ #'(accumulate-test! (lambda () (check-expect* 'stx - (make-location 'id offset line column span) + (srcloc 'id offset line column span) (lambda () test) (lambda () expected))))))])) diff --git a/lang/kernel.rkt b/lang/kernel.rkt index e052d4e..890dd86 100644 --- a/lang/kernel.rkt +++ b/lang/kernel.rkt @@ -444,7 +444,17 @@ char=? make-reader-graph make-placeholder placeholder-set! - ) + + + srcloc + make-srcloc + srcloc? + srcloc-id + srcloc-line + srcloc-column + srcloc-position + srcloc-span + ) diff --git a/lang/whalesong.rkt b/lang/whalesong.rkt index ccf875c..af45a5e 100644 --- a/lang/whalesong.rkt +++ b/lang/whalesong.rkt @@ -1,13 +1,35 @@ #lang s-exp "kernel.rkt" +;; Acts like the "Pretty Big" kind of language; has several features turned on by default. +;; These include: +;; +;; * Automatically running tests +;; * Annotating all applications so they produce stack traces on error +;; * Adding the "shared" form by default. + (require "base.rkt" "private/traced-app.rkt" - "private/shared.rkt") + "private/shared.rkt" + "check-expect/check-expect.rkt" + (for-syntax racket/base)) ;; Programs written in Whalesong will have tracing enabled by default. ;; If you don't want this, write in whalesong/base instead. (provide (except-out (all-from-out "base.rkt") - #%app) - (rename-out [traced-app #%app]) - shared) \ No newline at end of file + #%app + #%module-begin) + (rename-out [traced-app #%app] + [my-module-begin #%module-begin]) + shared + (except-out (all-from-out "check-expect/check-expect.rkt") + run-tests)) + + + +(define-syntax (my-module-begin stx) + (syntax-case stx () + [(_ body ...) + (syntax/loc stx + (#%module-begin body ... + (run-tests)))])) \ No newline at end of file