Merge remote-tracking branch 'origin/master'

Makefile

@@ -44,8 +44,9 @@ cs019-doc:
 
 
 setup:
-	raco setup --no-docs -P dyoo whalesong.plt 1 9
+
+	raco setup --no-docs -P dyoo whalesong.plt 1 10
 
 
 planet-link:
-	raco planet link dyoo whalesong.plt 1 9 .
+	raco planet link dyoo whalesong.plt 1 10 .

js/js-impl.js

@@ -1,68 +1,180 @@
-var VOID = plt.baselib.constants.VOID_VALUE;
-var makePrimitiveProcedure = plt.baselib.functions.makePrimitiveProcedure;
+/*jslint devel: true, browser: false, unparam: true, sub: true, windows: false, vars: true, white: true, maxerr: 50, indent: 4 */
 
-EXPORTS['alert'] =
-    makePrimitiveProcedure(
-        'alert',
-        1,
-        function(MACHINE) {
-            var elt = MACHINE.e[MACHINE.e.length - 1];
-            alert(String(elt));
-            return VOID;
-        });
+/*global $,plt,EXPORTS,document,window*/
+(function() {
+    "use strict";
+
+    var VOID = plt.baselib.constants.VOID_VALUE;
+    var makePrimitiveProcedure = plt.baselib.functions.makePrimitiveProcedure;
+    var makeCheckArgumentType = plt.baselib.check.makeCheckArgumentType;
+    var checkSymbolOrString = plt.baselib.check.checkSymbolOrString;
+    var checkString = plt.baselib.check.checkString;
+    var checkAny = makeCheckArgumentType(function(x) { return true; },
+                                         "any");
+
+    var isJsString = function(x) { return typeof(x) === 'string'; };
+    var checkJsString = makeCheckArgumentType(isJsString, 'JavaScript string');
 
 
-EXPORTS['body'] = $(document.body);
 
-EXPORTS['$'] =
-    makePrimitiveProcedure(
-        '$',
-        1,
-        function(MACHINE) {
-            var obj = MACHINE.e[MACHINE.e.length - 1];
-            return $(obj);
-        });
+    var isJsNumber = function(x) { return typeof(x) === 'number'; };
+    var checkNumber = plt.baselib.check.checkNumber;
+    var checkJsNumber = makeCheckArgumentType(isJsNumber, 'JavaScript number');
 
-EXPORTS['call-method'] = 
-    makePrimitiveProcedure(
-        'call-method',
-        plt.baselib.arity.makeArityAtLeast(2),
-        function(MACHINE) {
-            var obj = MACHINE.e[MACHINE.e.length - 1];
-            var methodName = MACHINE.e[MACHINE.e.length - 2];
-            var args = [];
-            for (var i = 0; i < MACHINE.a - 2; i++) {
-                args.push(MACHINE.e[MACHINE.e.length -1 - 2 - i]);
-            }
-            var result = obj[methodName].apply(obj, args);
-            return result;
-        });
+
+    EXPORTS['alert'] =
+        makePrimitiveProcedure(
+            'alert',
+            1,
+            function(MACHINE) {
+                var elt = MACHINE.e[MACHINE.e.length - 1];
+                alert(String(elt));
+                return VOID;
+            });
+
+
+    EXPORTS['body'] = $(document.body);
+
+    EXPORTS['$'] =
+        makePrimitiveProcedure(
+            '$',
+            1,
+            function(MACHINE) {
+                var obj = MACHINE.e[MACHINE.e.length - 1];
+                return $(obj);
+            });
+
+    EXPORTS['call-method'] = 
+        makePrimitiveProcedure(
+            'call-method',
+            plt.baselib.arity.makeArityAtLeast(2),
+            function(MACHINE) {
+                var obj = MACHINE.e[MACHINE.e.length - 1];
+                var methodName = MACHINE.e[MACHINE.e.length - 2];
+                var args = [], i;
+                for (i = 0; i < MACHINE.a - 2; i = i+1) {
+                    args.push(MACHINE.e[MACHINE.e.length -1 - 2 - i]);
+                }
+                var result = obj[methodName].apply(obj, args);
+                return result;
+            });
+
+
+    EXPORTS['window'] = window;
+
+
+    EXPORTS['get-attr'] =
+        makePrimitiveProcedure(
+            'get-attr',
+            plt.baselib.arity.makeArityAtLeast(2),
+            function(MACHINE) {
+                var obj = checkAny(MACHINE, 'get-attr', 0), attr, i;
+                for (i = 1; i < MACHINE.a; i = i + 1) {
+                    attr = checkSymbolOrString(MACHINE, 'get-attr', i).toString();
+                    obj = obj[attr];
+                }
+                return obj;
+            });
+
+
+    EXPORTS['set-attr!'] =
+        makePrimitiveProcedure(
+            'set-attr!',
+            3,
+            function(MACHINE) {
+                var obj = checkAny(MACHINE, 'set-attr!', 0);
+                var attr = checkSymbolOrString(MACHINE, 'set-attr!', 1).toString();
+                var val = checkAny(MACHINE, 'set-attr!', 2);
+                obj[attr] = val;
+                return VOID;
+            });
+
+    EXPORTS['js-string?'] = 
+        makePrimitiveProcedure(
+            'js-string?',
+            1,
+            function(MACHINE) {
+                return typeof(checkAny(MACHINE, 'js-string?', 0)) === 'string';
+            });
+
+    EXPORTS['string->js-string'] =
+        makePrimitiveProcedure(
+            'string->js-string',
+            1,
+            function(MACHINE) {
+                return checkString(MACHINE, 'string->js-string', 0).toString();
+            });
+
+    EXPORTS['js-string->string'] =
+        makePrimitiveProcedure(
+            'js-string->string',
+            1,
+            function(MACHINE) {
+                return checkJsString(MACHINE, 'string->js-string', 0);
+            });
 
 
 
 
-// Javascript-specific extensions.  A small experiment.
-EXPORTS['viewport-width'] = 
-    makePrimitiveProcedure(
-        'viewport-width',
-        0,
-        function(MACHINE) {
-            return $(window).width();
-        });
+    EXPORTS['js-number?'] = 
+        makePrimitiveProcedure(
+            'js-number?',
+            1,
+            function(MACHINE) {
+                return isJsNumber(checkAny(MACHINE, 'js-string?', 0));
+            });    
+    EXPORTS['js-number->number'] = 
+        makePrimitiveProcedure(
+            'js-number->number',
+            1,
+            function(MACHINE) {
+                return plt.baselib.numbers.makeFloat(checkJsNumber(MACHINE, 'js-string?', 0));
+            });    
 
-EXPORTS['viewport-height'] = 
-    makePrimitiveProcedure(
-        'viewport-height',
-        0,
-        function(MACHINE) {
-            return $(window).height();
-        });
+    EXPORTS['number->js-number'] = 
+        makePrimitiveProcedure(
+            'number->js-number',
+            1,
+            function(MACHINE) {
+                return plt.baselib.numbers.toFixnum(checkNumber(MACHINE, 'js-string?', 0));
+            });    
 
 
-EXPORTS['in-javascript-context?'] =
-    makePrimitiveProcedure(
-        'in-javascript-context?',
-        0,
-        function(MACHINE) {
-            return true;
-        });
+    EXPORTS['js-null?'] = 
+        makePrimitiveProcedure(
+            'js-null?',
+            1,
+            function(MACHINE) {
+                return checkAny(MACHINE, 'js-null?', 0) === null;
+            });    
+
+    EXPORTS['js-null'] = null;
+
+
+
+    // Javascript-specific extensions.  A small experiment.
+    EXPORTS['viewport-width'] = 
+        makePrimitiveProcedure(
+            'viewport-width',
+            0,
+            function(MACHINE) {
+                return $(window).width();
+            });
+
+    EXPORTS['viewport-height'] = 
+        makePrimitiveProcedure(
+            'viewport-height',
+            0,
+            function(MACHINE) {
+                return $(window).height();
+            });
+
+
+    EXPORTS['in-javascript-context?'] =
+        makePrimitiveProcedure(
+            'in-javascript-context?',
+            0,
+            function(MACHINE) {
+                return true;
+            });
+}());

js/main.rkt

@@ -7,8 +7,24 @@
                     body
                     call-method
                     $
+                    
+                    window
+                    
+                    get-attr
+                    set-attr!
 
+                    js-string?
+                    string->js-string
+                    js-string->string
+
+                    js-number?
+                    number->js-number
+                    js-number->number
+                    
                     viewport-width
                     viewport-height
                     in-javascript-context?
+
+                    js-null?
+                    js-null
                     ))

js/racket-impl.rkt

@@ -3,7 +3,21 @@
 (provide alert body call-method $
          in-javascript-context?
          viewport-width
-         viewport-height)
+         viewport-height
+
+         window
+         get-attr
+         set-attr!
+         js-string?
+         string->js-string
+         js-string->string
+         js-number?
+         number->js-number
+         js-number->number
+
+         js-null?
+         js-null
+         )
 
 (define (alert x)
   (display x)
@@ -17,6 +31,40 @@
 (define ($ name)
   'not-done-yet)
 
+(define window 'not-available-outside-JavaScript-context)
+
+
+(define (get-attr object attr . other-attrs)
+  (error 'get-attr "Not available outside JavaScript context"))
+
+
+(define (set-attr! obj attr value)
+  (error 'set-attr! "Not available outside JavaScript context"))
+
+
+
+(define (js-string? x)
+  (error 'js-string? "Not available outside JavaScript context"))
+(define (string->js-string x)
+  (error 'string->js-string "Not available outside JavaScript context"))
+(define (js-string->string x)
+  (error 'js-string->string "Not available outside JavaScript context"))
+
+(define (js-number? x)
+  (error 'js-number? "Not available outside JavaScript context"))
+(define (number->js-number x)
+  (error 'number->js-number "Not available outside JavaScript context"))
+(define (js-number->number x)
+  (error 'js-number->number "Not available outside JavaScript context"))
+
+
+
+(define (js-null? x)
+  (error 'js-null? "Not available outside JavaScript context"))
+
+(define js-null 'not-done-yet)
+
+
 
 
 

sandbox/test-storage.rkt

@@ -0,0 +1,27 @@
+#lang planet dyoo/whalesong
+
+(require (planet dyoo/whalesong/storage))
+
+(storage-length)
+(storage-ref "whalesong test")
+(storage-set! "whalesong test" "hello world")
+(storage-ref "whalesong test")
+(storage-length)
+(storage-key 0)
+(storage-clear!)
+(storage-length)
+
+
+(storage-clear!)
+(storage-set! "name" "Danny")
+(storage-set! "advisor" "sk")
+(storage-set! "advisor" "kathi")
+(storage-length)
+(storage-key 0)
+(storage-key 1)
+(storage-remove! "advisor")
+(storage-length)
+(storage-key 0)
+(storage-remove! "name")
+(storage-length)
+(storage-clear!)

sandbox/todo-storage/index.html

@@ -0,0 +1,14 @@
+<html>
+<head><title>TODO List</title></head>
+<body>
+<h1>TODO</h1>
+
+<h2>Items</h2>
+<ul id="items"></ul>
+
+
+<h2>Adding an item</h2>
+<input type="text" id="next-item"/>
+<input type="button" id="add-button" value="Add!"/>
+</body>
+</html>

sandbox/todo-storage/todo.rkt

@@ -0,0 +1,87 @@
+#lang planet dyoo/whalesong
+(require (planet dyoo/whalesong/web-world)
+         (planet dyoo/whalesong/resource)
+         (planet dyoo/whalesong/storage))
+
+;; The world is our TODO list, represented as a list of strings.
+
+(define-resource index.html)
+
+
+;; An item consists of a string id, the item's content, and a finished? flag.
+(define-struct item (id ;; string
+                     content ;; string
+                     finished? ;; boolean
+                     ))
+
+
+;; new-item: string -> item
+(define (new-item content)
+  (make-item (fresh-id) content #f))
+
+
+;; toggle-item-finished: world string -> world
+;; Mark the item with the given id so that it's finished, or reverse that change.
+(define (toggle-item-finished world id)
+  (cond
+   [(empty? world)
+    '()]
+   [(string=? id (item-id (first world)))
+    (cons (make-item id (item-content (first world)) (not (item-finished? (first world))))
+          (rest world))]
+   [else
+    (cons (first world)
+          (toggle-item-finished (rest world) id))]))
+
+
+
+;; world view -> world
+(define (on-add world view)
+  (local [(define text (view-form-value (view-focus view "next-item")))]
+    (cons (new-item text) world)))
+
+
+;; world view -> view
+(define (draw world view)
+  (foldl refresh-item-in-view
+         view
+         world))
+
+
+
+;; refresh-item-in-view: item view -> view
+(define (refresh-item-in-view item view)
+  (cond
+   [(view-focus? view (item-id item))
+    (update-view-css (view-focus view (item-id item))
+                     "text-decoration"
+                     (cond [(item-finished? item)
+                            "line-through"]
+                           [else
+                            "none"]))]
+   [else
+    (view-bind
+     (view-append-child (view-focus view "items")
+                        (xexp->dom `(li (@ (id ,(item-id item)))
+                                        ,(item-content item))))
+     "click"
+     when-item-clicked)]))
+
+
+
+;; when-item-clicked: world view -> world
+;; When an item is clicked, set its finished? flag.
+(define (when-item-clicked world view)
+  (toggle-item-finished world (view-attr view "id")))
+  
+
+(define the-view
+  (view-bind (view-focus (->view index.html) "add-button")
+                        "click"
+                        on-add))
+
+
+(big-bang (list (new-item "milk")
+                (new-item "eggs"))
+          (initial-view the-view)
+          (to-draw draw))

storage.rkt

@@ -0,0 +1,3 @@
+#lang s-exp "lang/base.rkt"
+(require "storage/storage.rkt")
+(provide (all-from-out "storage/storage.rkt"))

storage/storage.rkt

@@ -0,0 +1,41 @@
+#lang s-exp "../lang/base.rkt"
+
+;; Bindings to HTML5 storage
+;; http://dev.w3.org/html5/webstorage/
+
+
+(require "../js.rkt")
+
+(provide storage-length
+         storage-key
+         storage-ref
+         storage-set!
+         storage-remove!
+         storage-clear!)
+
+
+(define localStorage (get-attr window "localStorage"))
+
+(define (storage-length)
+  (inexact->exact (js-number->number (get-attr localStorage "length"))))
+
+(define (storage-key i)
+  (js-string->string (call-method localStorage "key" (number->js-number i))))
+
+(define (storage-ref name)
+  (define val (call-method localStorage "getItem" (string->js-string name)))
+  (if (js-null? val)
+      #f
+      (js-string->string val)))
+
+(define (storage-set! name value)
+  (void (call-method localStorage "setItem"
+                     (string->js-string name)
+                     (string->js-string value))))
+
+(define (storage-remove! name)
+  (void (call-method localStorage "removeItem"
+                     (string->js-string name))))
+
+(define (storage-clear!)
+  (void (call-method localStorage "clear")))