adding check-expect

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

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

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; 

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

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

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)
+                     #%app
-         (rename-out [traced-app #%app])
+                     #%module-begin)
-         shared)
+         (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)))]))