Merge remote-tracking branch 'origin/master' into web-world

Makefile

@@ -1,8 +1,10 @@
 # test-analyzer:
 # 	raco make -v --disable-inline test-analyzer.rkt
 # 	racket test-analyzer.rkt
+all: planet-link launcher
 
-launcher:
+
+launcher: 
 	raco make -v --disable-inline whalesong.rkt
 	racket make-launcher.rkt
 
@@ -44,5 +46,14 @@ doc:
 	scribble  ++xref-in setup/xref load-collections-xref --redirect-main http://docs.racket-lang.org/ --dest generated-docs  --dest-name index.html scribblings/manual.scrbl
 
 
+cs19-doc:
+	scribble  ++xref-in setup/xref load-collections-xref --redirect-main http://docs.racket-lang.org/ --dest generated-docs  scribblings/cs19.scrbl
+
+
+
 setup:
 	raco setup -P dyoo whalesong.plt 1 2
+
+
+planet-link:
+	raco planet link dyoo whalesong.plt 1 4 .

base/reader/reader.rkt

@@ -0,0 +1,9 @@
+#lang s-exp syntax/module-reader
+
+;; http://docs.racket-lang.org/planet/hash-lang-planet.html
+
+#:language (lambda (ip)
+	    `(file ,(path->string base-lang-path)))
+
+(require racket/runtime-path)
+(define-runtime-path base-lang-path "../lang/base.rkt")

js-assembler/package.rkt

@@ -273,7 +273,6 @@ MACHINE.modules[~s] =
      ;; last
      on-last-src))
   
-  
   (fprintf op "var invoke = (function(MACHINE, SUCCESS, FAIL, PARAMS) {")
   (fprintf op "    plt.runtime.ready(function() {")
   (fprintf op "plt.runtime.setReadyFalse();")

js-assembler/runtime-src/baselib-primitives.js

@@ -272,6 +272,23 @@
 
 
 
+    installPrimitiveProcedure(
+        'current-error-port',
+        makeList(0, 1),
+        function (MACHINE) {
+            if (MACHINE.argcount === 1) {
+                MACHINE.params['currentErrorPort'] = 
+                    checkOutputPort(MACHINE, 'current-output-port', 0);
+                return VOID;
+            } else {
+                return MACHINE.params['currentOutputPort'];
+            }
+        });
+
+
+
+
+
 
 
     installPrimitiveProcedure(
@@ -1587,7 +1604,6 @@
                             String(name) + "-accessor",
                             2,
                             function (MACHINE) {
-                                // FIXME: typechecks
                                 return structType.accessor(
                                     MACHINE.env[MACHINE.env.length - 1],
                                     baselib.numbers.toFixnum(MACHINE.env[MACHINE.env.length - 2]));
@@ -1599,7 +1615,6 @@
                             String(name) + "-mutator",
                             3,
                             function (MACHINE) {
-                                // FIXME: typechecks
                                 return structType.mutator(
                                     MACHINE.env[MACHINE.env.length - 1],
                                     baselib.numbers.toFixnum(MACHINE.env[MACHINE.env.length - 2]),
@@ -1637,8 +1652,6 @@
         'make-struct-field-accessor',
         makeList(2, 3),
         function (MACHINE){
-            // FIXME: typechecks
-            // We must guarantee that the ref argument is good.
             var structType = MACHINE.env[MACHINE.env.length - 1].structType;
             var index = MACHINE.env[MACHINE.env.length - 2];
             var name;
@@ -1647,12 +1660,15 @@
             } else {
                 name = 'field' + index;
             }
+            var checkStruct = baselib.check.makeCheckArgumentType(structType.predicate,
+                                                                  structType.name);
             return makePrimitiveProcedure(
                 name,
                 1,
                 function (MACHINE) {
+                    var aStruct = checkStruct(MACHINE, name, 0);
                     return structType.accessor(
-                        MACHINE.env[MACHINE.env.length - 1],
+                        aStruct,
                         baselib.numbers.toFixnum(index));
                 });
             
@@ -1663,8 +1679,6 @@
         'make-struct-field-mutator',
         makeList(2, 3),
         function (MACHINE){
-            // FIXME: typechecks
-            // We must guarantee that the set! argument is good.
             var structType = MACHINE.env[MACHINE.env.length - 1].structType;
             var index = MACHINE.env[MACHINE.env.length - 2];
             var name;
@@ -1673,19 +1687,21 @@
             } else {
                 name = 'field' + index;
             }
+            var checkStruct = baselib.check.makeCheckArgumentType(structType.predicate,
+                                                                  structType.name);
             return makePrimitiveProcedure(
                 name,
                 2,
                 function (MACHINE) {
+                    var aStruct = checkStruct(MACHINE, name, 0);
                     return structType.mutator(
-                        MACHINE.env[MACHINE.env.length - 1],
+                        aStruct,
                         baselib.numbers.toFixnum(index),
                         MACHINE.env[MACHINE.env.length - 2]);
                 });            
         });
 
 
-
     exports['Primitives'] = Primitives;
     exports['installPrimitiveProcedure'] = installPrimitiveProcedure; 
     exports['installPrimitiveClosure'] = installPrimitiveClosure; 

lang/base.rkt

@@ -5,18 +5,11 @@
                      ;; Don't publically export the bindings from #%paramz.
                      exception-handler-key
                      parameterization-key
-                     break-enabled-key
+                     break-enabled-key)
-                     
+         (all-from-out "private/list.rkt"))
-                     ;; Use the traced app
-                     #;#%app)
          
-         (all-from-out "private/list.rkt")
+(require "private/list.rkt")
-         
-         #;(rename-out [traced-app #%app]))
-
-(require "private/list.rkt"
-         "private/traced-app.rkt")
 
 
 ;; Kludge: This forces modbeg to be compiled and packaged.
-(require racket/private/modbeg)
+(require racket/private/modbeg)

lang/reader.rkt

@@ -3,7 +3,7 @@
 ;; http://docs.racket-lang.org/planet/hash-lang-planet.html
 
 #:language (lambda (ip)
-	    `(file ,(path->string base-lang-path)))
+	    `(file ,(path->string whalesong-lang-path)))
 
 (require racket/runtime-path)
-(define-runtime-path base-lang-path "base.rkt")
+(define-runtime-path whalesong-lang-path "whalesong.rkt")

lang/whalesong.rkt

@@ -0,0 +1,13 @@
+#lang s-exp "kernel.rkt"
+
+(require "base.rkt"
+         "private/traced-app.rkt")
+
+;; 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])
+         )

scribblings/cs19.scrbl

@@ -0,0 +1,520 @@
+#lang scribble/manual
+@(require planet/scribble
+          planet/version
+          planet/resolver
+          scribble/eval
+          racket/sandbox
+          racket/port
+          (only-in racket/contract any/c)
+          racket/runtime-path
+          "scribble-helpers.rkt"
+          "../js-assembler/get-js-vm-implemented-primitives.rkt")
+
+@(require (for-label (this-package-in resource))
+          (for-label (this-package-in web-world)))
+
+@(define-runtime-path whalesong-path "..")
+
+
+@title{CS19 instructions for Whalesong}
+@author+email["Danny Yoo" "dyoo@hashcollision.org"]
+
+
+@section{Installation}
+
+We'll install a local development copy of Whalesong in a @filepath{whalesong} subdirectory.
+On the very first time we install Whalesong:
+@verbatim|{
+    $ git clone git://github.com/dyoo/whalesong.git
+    $ cd whalesong
+    $ make
+}|
+The @filepath{make} step make take a minute or two, and creates a command-line program called
+@filepath{whalesong} that we'll use to build Whalesong programs.
+
+
+Whenever we need to update whalesong, we should do the following
+@verbatim|{
+    $ git pull
+    $ make
+}|
+
+
+
+@section{Usage}
+The @filepath{whalesong} launcher in the subdirectory will compile
+programs to standalone @filepath{.xhtml} files.
+
+
+Example usage: using @litchar{whalesong build} to compile a whalesong program.
+@verbatim|{
+fermi ~/whalesong $ cd examples
+
+fermi ~/whalesong/examples $ cat hello.rkt
+#lang planet dyoo/whalesong
+
+(display "hello world")
+(newline)
+
+fermi ~/whalesong/examples $ ../whalesong build hello.rkt 
+
+fermi ~/whalesong/examples $ google-chrome hello.xhtml
+Created new window in existing browser session.
+
+fermi ~/whalesong/examples $ 
+}|
+
+
+@section{Examples}
+
+There are examples in the
+@link["https://github.com/dyoo/whalesong/tree/master/examples"]{@filepath{whalesong/examples}}
+and
+@link["https://github.com/dyoo/whalesong/tree/master/web-world/examples"]{@filepath{whalesong/web-world/examples}}.
+Let's look at a few of them.
+
+
+
+@subsection{Hello world}
+
+Let's try making a simple, standalone executable.  At the moment, the
+program must be written in the base language of @racket[(planet
+dyoo/whalesong)].  This restriction unfortunately  prevents arbitrary
+@racketmodname[racket/base] programs from compiling at the moment;
+the developers (namely, dyoo) will be working to remove this
+restriction as quickly as possible.
+
+
+Write a @filepath{hello.rkt} with the following content
+@filebox["hello.rkt"]{
+@codeblock{
+    #lang planet dyoo/whalesong
+    (display "hello world")
+    (newline)
+}}
+This program is a regular Racket program, and can be executed normally,
+@verbatim|{
+$ racket hello.rkt 
+hello world
+$
+}|
+However, it can also be packaged with @filepath{whalesong}.
+@verbatim|{
+    $ whalesong build hello.rkt
+
+    $ ls -l hello.xhtml
+    -rw-rw-r-- 1 dyoo nogroup 692213 Jun  7 18:00 hello.xhtml
+}|
+Running @tt{whalesong build} on a Racket program will produce a self-contained
+@filepath{.xhtml} file.  If we open this file in our favorite web browser,
+we should see a triumphant message show on screen.
+
+
+
+
+@subsection{Tick tock}
+
+Let's do something a little more interesting, and create a ticker that
+counts on the screen.
+
+The first thing we can do is mock up a web page with a user interface, like this.
+@filebox["index.html"]{
+@verbatim|{
+<html>
+  <head><title>My simple program</title></head>
+  <body>
+    <p>The current counter is: <span id="counter">fill-me-in</span></p>
+  </body>
+</html>
+}|
+}
+We can even look at this in a standard web browser.
+
+Once we're happy with the statics of our program, we can inject dynamic behavior.
+Write a file called @filepath{tick-tock.rkt} with the following content.
+@filebox["tick-tock.rkt"]{
+@codeblock|{
+#lang planet dyoo/whalesong
+(require (planet dyoo/whalesong/web-world)
+         (planet dyoo/whalesong/resource))
+
+(define-resource index.html)
+
+;; draw: world view -> view
+(define (draw world dom)
+  (update-view-text (view-focus dom "#counter") world))
+
+
+;; tick: world view -> world
+(define (tick world dom)
+  (add1 world))
+
+
+;; stop?: world view -> boolean
+(define (stop? world dom)
+  (> world 10))
+
+(big-bang 0
+          (initial-view index.html)
+          (to-draw draw)
+          (on-tick tick 1)
+          (stop-when stop?))
+}|
+}
+
+Several things are happening here.
+@itemize[
+
+@item{We @racket[require] a few libraries to get us some additional
+behavior; in particular, @racketmodname/this-package[web-world] to let
+us write event-driven web-based programs, and @racketmodname/this-package[resource]
+to give us access to external @tech{resource}s.}
+
+@item{We use @racket[define-resource] to refer to external files, like @filepath{index.html} that
+we'd like to include in our program.}
+
+@item{We use @racket[big-bang] to start up a computation that
+responses to events.  In this example, that's clock ticks introduced
+by @racket[on-tick], though because we're on the web, we can
+bind to many other kinds of web events (by using @racket[view-bind]).}
+]
+
+The rest of this document describes the API.
+
+
+
+
+
+
+@section{API}
+
+@defmodule/this-package[web-world]
+
+For the purposes of tour-guide, we'll be focusing on the
+@racketmodname/this-package[web-world] library in Whalesong.
+
+Like the big-bang in regular world, the callbacks are world-to-world
+functions.  One difference introduced by the web is the web page
+itself: because the page itself is a source of state, it too will be
+passed to callbacks.  This library presents a
+functional version of the DOM in the form of a @tech{view}.
+
+The world-updating callbacks may optionally take an @tech{event} object, which 
+provides additional information about the event that triggered the callback.
+
+
+
+@defproc[(big-bang [w world]
+                   [h big-bang-handler] ...) world]{
+Start a big bang computation.
+}
+@defproc[(initial-view [x any]) big-bang-handler]{
+Provide an initial view for the big-bang.  Normally, @racket[x] will be a @tech{resource}
+to a web page.
+@codeblock|{
+...
+(define-resource page1.html)
+...
+(big-bang ...
+          (initial-view page1.html))
+}|
+}
+
+
+@defproc[(stop-when [stop? ([w world] [dom view] ->  boolean)]) big-bang-handler]{
+Tells @racket[big-bang] when to stop.
+@codeblock|{
+...
+(define-struct world (given expected))
+...
+
+;; stop?: world view -> boolean
+(define (stop? world dom)
+  (string=? (world-given world) (world-expected world)))
+
+(big-bang ...
+          (stop-when stop?))
+}|
+}
+
+
+@defproc*[(((on-tick [tick-f ([w world] [v view] [e event]? -> world)] [delay real]) big-bang-handler)
+           ((on-tick [tick-f ([w world] [v view] [e event]? -> world)]) big-bang-handler))]{
+Tells @racket[big-bang] to update the world during clock ticks.
+
+By default, this will send a clock tick 28 times a second, but if
+given @racket[delay], it will use that instead.
+@codeblock|{
+...
+;; tick: world dom -> world
+(define (tick world view)
+  (add1 world))
+
+(big-bang ...
+          (on-tick tick 5)) ;; tick every five seconds
+}|
+}
+
+
+@defproc[(on-mock-location-change [location-f ([w world] [v view] [e event]? -> world)]) big-bang-handler]{
+Tells @racket[big-bang] to update the world during simulated movement.
+
+During the extent of a big-bang, a form widget will appear in the
+@tt{document.body} to allow us to manually send location-changing
+events.
+
+The optional @tech{event} argument will contain numbers for
+@racket["latitude"] and @racket["longitude"].
+@codeblock|{
+...
+;; move: world view event -> world
+(define (move world dom event)
+  (list (event-ref event "latitude")
+        (event-ref event "longitude")))
+...
+(big-bang ...
+          (on-mock-location-change move))
+}|
+}
+
+
+@defproc[(on-location-change [location-f ([w world] [v view] [e event]? -> world)]) big-bang-handler]{
+Tells @racket[big-bang] to update when the location changes, as
+received by the
+@link["http://dev.w3.org/geo/api/spec-source.html"]{Geolocation API}.
+
+The optional @tech{event} argument will contain numbers for
+@racket["latitude"] and @racket["longitude"].
+@codeblock|{
+...
+;; move: world view event -> world
+(define (move world dom event)
+  (list (event-ref event "latitude")
+        (event-ref event "longitude")))
+...
+(big-bang ...
+          (on-location-change move))
+}|
+}
+
+
+
+
+@defproc[(to-draw [draw-f ([w world] [v view] -> view)]) big-bang-handler]{
+Tells @racket[big-bang] how to update the rendering of the world.  The draw
+function will be called every time an event occurs.
+
+@codeblock|{
+...
+(define-struct world (name age))
+
+;; draw: world view -> view
+(define (draw world dom)
+  (update-view-text (view-focus dom "#name-span")
+                    (world-name world)))
+...
+(big-bang ...
+          (to-draw draw))
+}|
+}
+
+
+
+@subsection{Views}
+
+A @deftech{view} is a functional representation of the browser DOM
+tree.  A view is always focused on an element, and the functions in
+this subsection show how to traverse and manipulate the view.
+
+
+
+@defproc[(->view [x any]) view]{
+
+Coerse a value into a view whose focus is on the topmost element.
+Common values for @racket[x] include @tech{resource}s.
+}
+
+
+@defproc[(view-focus [v view] [selector String]) view]{
+Focuses the view on an element, given the @racket[selector].  The view
+will be searched starting from the toplevelmost node.
+
+Selectors are currently restricted to @litchar{#id} selectors for the
+moment.
+}
+
+
+@defproc[(view-left [v view]) view]{
+Move the focus to the previous sibling.
+}
+@defproc[(view-right [v view]) view]{
+Move the focus to the next sibling.}
+
+@defproc[(view-up [v view]) view]{
+Move the focus to the parent.}
+
+@defproc[(view-down [v view]) view]{
+Move the view to the first child.}
+
+@defproc[(view-text [v view]) string]{
+Get the textual content at the focus.
+}
+@defproc[(update-view-text [v view] [s string]) view]{
+Update the textual content at the focus.}
+
+@defproc[(view-bind [v view] [type string] [world-updater ([w world] [v view]  [e event]? -> world)]) view]{
+Attach a world-updating event to the focus.
+
+Attach a world-updating event to the focus.  When the world-updater is
+called, the view will be focused on the element that triggered the
+event.
+
+Common event types include @racket["click"], @racket["mouseenter"], @racket["change"].}
+
+@defproc[(view-show [v view]) view]{
+Show the element at the focus.
+}
+@defproc[(view-hide [v view]) view]{
+Hide the element at the focus.
+}
+
+@defproc[(view-attr [v view] [name String]) view]{
+Get the attribute @racket[name] at the focus.
+}
+
+@defproc[(update-view-attr [v view] [name String] [value String]) view]{
+Update the attribute @racket[n] with the value @racket[v] at the focus.
+}
+
+@defproc[(view-id [v view]) world]{
+Get the unique identifier of the node at the focus.
+}
+
+@defproc[(view-form-value [v view]) view]{
+Get the form value of the node at the focus.}
+
+@defproc[(update-view-form-value [v view] [value String]) view]{
+Update the form value of the node at the focus.}
+
+@defproc[(view-append-child [d dom]) view]{
+Add the dom node @racket[d] as the last child of the focused node.}
+                    
+
+
+@subsection{Events}
+
+An @deftech{event} is a structure that holds name-value pairs.
+Whenever an event occurs in web-world, it may include some auxiliary
+information about the event.  As a concrete example, location events
+from @racket[on-location-change] and @racket[on-mock-location-change]
+can send latitude and longitude values, as long as the world callback
+can accept the event as an argument.
+
+
+@defstruct[event ([kvpairs (listof (list symbol (or/c string number)))])]{}
+
+@defproc[(event-ref [evt event?] [name (or/c symbol string)]) value]{
+Get an value from the event, given its @racket[name].
+}
+
+@defproc[(event-keys [evt event?]) (listof symbol)]{
+Get an list of the event's keys.
+}
+
+
+
+
+@section{Including external resources}
+@defmodule/this-package[resource]
+
+Programs may need to use an external file @deftech{resource} that isn't
+itself a Racket program, but instead some other kind of data.
+Graphical programs will often use @filepath{.png}s, and web-related
+programs @filepath{.html}s, for example.  Whalesong provides the
+@racketmodname/this-package[resource] library to refer and use these
+external resources.  When Whalesong compiles a program into a package,
+these resources will be bundled alongside the JavaScript-compiled
+output.
+
+@defform[(define-resource id [path-string])]{
+Defines a resource with the given path name.
+
+For example,
+@codeblock|{
+#lang planet dyoo/whalesong
+(require (planet dyoo/whalesong/resource))
+(define-resource my-whale-image-resource "humpback.png")
+}|
+}
+As a convenience, we can also write
+@codeblock|{
+#lang planet dyoo/whalesong
+(require (planet dyoo/whalesong/resource))
+(define-resource humpback.png)
+}|
+which defines a variable named @racket[humpback.png] whose
+resource is @filepath{humpback.png}.
+
+
+
+@defproc[(resource->url [a-resource resource?]) string?]{
+Given a resource, gets a URL.
+
+For example,
+@codeblock|{
+#lang planet dyoo/whalesong
+(require (planet dyoo/whalesong/resource)
+         (planet dyoo/whalesong/image))
+
+(define-resource my-whale-image-resource "humpback.png")
+
+(define WHALE-IMAGE
+  (bitmap/url (resource->url my-whale-image-resource)))
+}|
+
+}
+
+
+
+
+@section{Tips and Tricks}
+@subsection{Hiding standard output or directing it to an element}
+
+@declare-exporting/this-package[web-world]
+
+For a web-world program, output is normally done by using
+@racket[to-draw].  However, side effecting functions, such as
+@racket[printf] or @racket[display], are still available, and are
+allowed to continue to append to @tt{document.body}.
+
+We may want to disable such printing or redirect it to a particular
+element on the page.  For such purposes, use a combination of
+@racket[current-output-port] and @racket[open-output-element] to
+redirect the output of these side effect functions to somewhere else.
+
+For example:
+@codeblock|{
+...
+;; Redirect standard output to a div called "stdout-div".
+(current-output-port (open-output-element "stdout-div"))
+...
+(big-bang ...
+          (on-tick (lambda (world dom)
+                     (printf "Tick!\n")
+                     (add1 world)))
+          ...)
+}|
+
+
+All subsequent I/O side effects after the call to
+@racket[current-output-port] will be written out to the
+@tt{stdout-div}, which can be easily styled with @tt{display: none} to
+hide it from normal browser display.
+
+
+
+@defproc[(open-output-element [id string]) output-port]{
+Opens an output port that will be directed to write to the DOM element
+whose id is @racket[id].  Note: writing to this port shouldn't fail,
+even if the id does not currently exist on the page.
+}

version.rkt

@@ -1,4 +1,4 @@
 #lang typed/racket/base
 (provide version)
 (: version String)
-(define version "1.0")
+(define version "1.0")

web-world/event.rkt

@@ -0,0 +1,25 @@
+#lang s-exp "../lang/base.rkt"
+
+(provide (all-defined-out))
+
+(define-struct event (kvpairs))
+
+
+(define (event-keys an-evt)
+  (map car (event-kvpairs an-evt)))
+
+
+(define (event-ref an-evt a-key)
+  (define clean-key (cond
+                     [(symbol? a-key)
+                      a-key]
+                     [(string? a-key)
+                      (string->symbol a-key)]
+                     [else
+                      (raise-type-error 'event-ref "symbol or string" a-key)]))
+  (define kv (assq clean-key (event-kvpairs an-evt)))
+  (cond [(eq? kv #f)
+         (error 'event-ref "Could not find key ~a" a-key)]
+        [else
+         (car (cdr kv))]))
+      

web-world/examples/dwarves/dwarves.rkt

@@ -0,0 +1,53 @@
+#lang planet dyoo/whalesong
+(require (planet dyoo/whalesong/web-world)
+         (planet dyoo/whalesong/resource))
+(define-resource index.html)
+
+;; The world is the set of dwarfs.
+
+
+;; make-item: string -> view
+(define (make-item name)
+  (view-bind (->view `(li ,name))
+             "click"
+             hide-on-click))
+
+
+;; When a dwarf clicks, it hides!
+(define (hide-on-click w v)
+  (remove (view-id v) w))
+
+
+(define dwarf-names 
+  '("Doc" "Grumpy" "Happy" "Sleepy" "Bashful" "Sneezy" "Dopey"))
+
+
+;; Update the view so it shows the next dwarf on the scene,
+;; until we're all done.
+(define (draw w dom-view)
+  (foldl (lambda (name view)
+           (define focused (view-focus view (format "#~a" name)))
+           (cond
+            [(member name w)
+             (view-show focused)]
+            [else
+             (view-hide focused)]))
+         dom-view
+         dwarf-names))
+
+
+
+;; The first view consists of index.html.  We attach event handlers
+;; to each name here.
+(define my-view
+  (foldl (lambda (name view)
+           (view-bind (view-focus view (format "#~a" name))
+                      "click"
+                      hide-on-click))
+         (->view index.html)
+         dwarf-names))
+
+
+(big-bang dwarf-names
+          (initial-view my-view)
+          (to-draw draw))

web-world/examples/dwarves/index.html

@@ -0,0 +1,16 @@
+<html>
+  <head><title>Dwarves</title></head>
+  <body>
+    <h1>Dwarfs from Snow White</h1>
+    <p>Click on a dwarf to make them hide.</p>
+    <ul id="list">
+      <li id="Doc">Doc</li>
+      <li id="Grumpy">Grumpy</li>
+      <li id="Happy">Happy</li>
+      <li id="Sleepy">Sleepy</li>
+      <li id="Bashful">Bashful</li>
+      <li id="Sneezy">Sneezy</li>
+      <li id="Dopey">Dopey</li>
+    </ul>
+  </body>
+</html>

web-world/examples/redirected/index.html

@@ -0,0 +1,13 @@
+<html>
+  <head><title>My simple program</title></head>
+  <body>
+    <p>The current counter is: <span id="counter">fill-me-in</span></p>
+
+
+    <p>There is content from the <tt>printf</tt> statements going into
+      the hidden div below:</p>
+    <!-- This div is hidden. -->
+    <div id="stdout"
+         style="border: 1px solid black; display: none " />
+  </body>
+</html>

web-world/examples/redirected/redirected.rkt

@@ -0,0 +1,26 @@
+#lang planet dyoo/whalesong
+(require (planet dyoo/whalesong/web-world)
+         (planet dyoo/whalesong/resource))
+
+(define-resource index.html)
+
+(current-output-port (open-output-element "stdout"))
+
+
+;; draw: world view -> view
+(define (draw w v)
+  (update-view-text (view-focus v "#counter") w))
+
+
+
+;; tick: world view -> world
+(define (tick w v)
+  (printf "Tick ~s\n" w)
+  (+ w 1))
+
+(big-bang 0
+          (initial-view index.html)
+          (to-draw draw)
+          (on-tick tick 1)
+          (stop-when (lambda (w v)
+                       (> w 10))))

web-world/examples/where-am-i/index.html

@@ -0,0 +1,9 @@
+<html>
+<head><title>Where in the world am I?</title></head>
+<body>
+<p>
+  I am at: <span id="real-location">dunno</span>.
+  The mock location says: <span id="mock-location">dunno</span>.
+</p>
+</body>
+</html>

web-world/examples/where-am-i/where-am-i.rkt

@@ -0,0 +1,45 @@
+#lang planet dyoo/whalesong
+(require (planet dyoo/whalesong/web-world)
+         (planet dyoo/whalesong/resource))
+
+(define-resource index.html)
+
+(define-struct coord (lat lng))
+(define-struct world (real mock))
+
+
+
+(define (location-change world dom evt)
+  (make-world (make-coord (event-ref evt "latitude")
+                          (event-ref evt "longitude"))
+              (world-mock world)))
+
+
+(define (mock-location-change world dom evt)
+  (make-world (world-real world)
+              (make-coord (event-ref evt "latitude")
+                          (event-ref evt "longitude"))))
+
+
+(define (draw world dom)
+  (define v1 (if (coord? (world-real world))
+                 (update-view-text (view-focus dom "#real-location")
+                                   (format "lat=~a, lng=~a"
+                                           (coord-lat (world-real world))
+                                           (coord-lng (world-real world))))
+                 dom))
+  (define v2 (if (coord? (world-mock world))
+                 (update-view-text (view-focus v1 "#mock-location")
+                                   (format "lat=~a, lng=~a"
+                                           (coord-lat (world-mock world))
+                                           (coord-lng (world-mock world))))
+                 v1))
+  v2)
+
+
+
+(big-bang (make-world 'unknown 'unknown)
+          (initial-view index.html)
+          (to-draw draw)
+          (on-location-change location-change)
+          (on-mock-location-change mock-location-change))

web-world/impl.rkt

@@ -1,9 +1,8 @@
 #lang s-exp "../lang/js/js.rkt"
 
 
-;; Make sure the resource library is loaded.
+;; Make sure the resource library is loaded, as well as the event structure library.
-(require "../resource.rkt")
+(require "../resource.rkt" "event.rkt")
-
 
 (declare-implementation
  #:racket "racket-impl.rkt"
@@ -20,8 +19,17 @@
                     ;; clock tick handler
                     on-tick
 
+                    ;; location changes
+                    on-mock-location-change
+
+                    ;; location changes (for real!)
+                    on-location-change
+                    
                     ;; draw and update the view
                     to-draw
+
+                    ;; helper: open an element as an output port.
+                    open-output-element                    
                     
                     ;; coerse to view
                     ->view
@@ -36,10 +44,16 @@
                     update-view-text
 
                     view-bind
+
+                    view-show
+                    view-hide
                     
                     view-attr
                     update-view-attr
 
+                    view-id
+                    
                     view-form-value
                     update-view-form-value
+                    view-append-child
                     ))

web-world/info.rkt

@@ -0,0 +1,3 @@
+#lang setup/infotab
+
+(define compile-omit-paths '("examples"))

web-world/js-impl.js

@@ -9,6 +9,9 @@
     var finalizeClosureCall = plt.baselib.functions.finalizeClosureCall;
     var PAUSE = plt.runtime.PAUSE;
     var isString = plt.baselib.strings.isString;
+    var makeList = plt.baselib.lists.makeList;
+    var makePair = plt.baselib.lists.makePair;
+    var makeSymbol = plt.baselib.symbols.makeSymbol;
 
 
 
@@ -22,6 +25,10 @@
     var resourceStructType = 
         MACHINE.modules['whalesong/resource/structs.rkt'].namespace['struct:resource'];
 
+    var eventStructType = 
+        MACHINE.modules['whalesong/web-world/event.rkt'].namespace['struct:event'];
+
+
 
     var domToCursor = function(dom) {
         var domOpenF = 
@@ -261,17 +268,14 @@
 
         // HACK: every node that is bound needs to have an id.  We
         // enforce this by mutating the node.
-        if ($(this.cursor.node).attr("id") === undefined) {
+        if (! this.cursor.node.id) {
-            $(this.cursor.node).attr("id",
+            this.cursor.node.id = ("__webWorldId_" + mockViewIdGensym++);
-                                ("__webWorldId_" + mockViewIdGensym++));
+        }   
-        }
-            
         return this.act(
             function(cursor) {
                 var newCursor = cursor.replaceNode($(cursor.node).clone(true).get(0));
                 var handler = new EventHandler(name, 
-                                               new DomEventSource(name,
+                                               new DomEventSource(name, newCursor.node), 
-                                                                  newCursor.node), 
                                                worldF);
                 if (currentBigBangRecord !== undefined) {
                     currentBigBangRecord.startEventHandler(handler);
@@ -282,21 +286,80 @@
                 var handler = new EventHandler(name,
                                                new DomEventSource(
                                                    name,
-                                                   $(that.cursor.node).attr('id')),
+                                                   that.cursor.node.id),
                                                worldF);
                 return eventHandlers.concat([handler]);
             },
             function(view) {
+                // HACK: every node that is bound needs to have an id.  We
+                // enforce this by mutating the node.
+                if (! view.focus.get(0).id) {
+                    view.focus.get(0).id = ("__webWorldId_" + mockViewIdGensym++);
+                }
                 var handler = new EventHandler(name, 
                                                new DomEventSource(
                                                    name, 
-                                                   view.focus.get(0)),
+                                                   view.focus.get(0).id),
                                                worldF);
                 view.addEventHandler(handler);
                 currentBigBangRecord.startEventHandler(handler);
             });
     };
 
+    MockView.prototype.show = function() {
+        return this.act(
+            function(cursor) {
+                return cursor.replaceNode($(cursor.node).clone(true).show().get(0));
+            },
+            function(eventHandlers) { return eventHandlers; },
+            function(view) {
+                view.focus.show();
+            }
+        )
+    };
+
+    MockView.prototype.hide = function() {
+        return this.act(
+            function(cursor) {
+                return cursor.replaceNode($(cursor.node).clone(true).hide().get(0));
+            },
+            function(eventHandlers) { return eventHandlers; },
+            function(view) {
+                view.focus.hide();
+            }
+        )
+    };
+
+
+    MockView.prototype.appendChild = function(domNode) {
+        return this.act(
+            function(cursor) {
+                if (cursor.canDown()) {
+                    cursor = cursor.down();
+                    while (cursor.canRight()) {
+                        cursor = cursor.right();
+                    }
+                    return cursor.insertRight(domNode.cloneNode(true));
+                } else {
+                    return cursor.insertDown(domNode.cloneNode(true));
+                }
+            },
+            function(eventHandlers) { return eventHandlers; },
+            function(view) {
+                var clone = $(domNode).clone(true);
+                clone.appendTo(view.focus);
+                view.focus = clone;
+            }
+        )
+    };
+
+    MockView.prototype.id = function() {
+        return this.cursor.node.id;
+    };
+
+
+
+
 
     //////////////////////////////////////////////////////////////////////
 
@@ -422,6 +485,40 @@
     };
 
 
+    var coerseToDomNode = function(x, onSuccess, onFail) {
+        var dom;
+        if (isDomNode(x)) { 
+            return onSuccess(x); 
+        } else  if (isResource(x)) {
+            try {
+                dom = $(resourceContent(x).toString())
+                    .css("margin", "0px")
+                    .css("padding", "0px")
+                    .css("border", "0px");
+            } catch (exn) {
+                return onFail(exn);
+            }
+            return onSuccess(dom.get(0));
+        } else if (isMockView(x)) {
+            return onSuccess(x.cursor.top().node);
+        } else {
+            try {
+                dom = plt.baselib.format.toDomNode(x);
+            } catch (exn) {
+                return onFail(exn);
+            }
+            return onSuccess(dom);
+        }
+    };
+
+
+    var isDomNode = function(x) {
+        return (x.hasOwnProperty('nodeType') &&
+                x.nodeType === 1);
+    };
+
+
+
 
 
 
@@ -484,6 +581,15 @@
     EventHandler.prototype.toString = function() { return "#<" + this.name + ">"; };
     var isEventHandler = plt.baselib.makeClassPredicate(EventHandler);
 
+
+
+    var WithOutputToHandler = function(outputPort) {
+        this.outputPort = outputPort;
+    };
+    WithOutputToHandler.prototype = plt.baselib.heir(WorldHandler.prototype);
+    var isWithOutputToHandler = plt.baselib.makeClassPredicate(WithOutputToHandler);
+
+
     //////////////////////////////////////////////////////////////////////
 
 
@@ -510,6 +616,29 @@
 
 
 
+    // convert an object to an event.
+    // At the moment, we only copy over those values which are numbers or strings.
+    var objectToEvent = function(obj) {
+        var key, val;
+        var result = makeList();
+        for (key in obj) {
+            if (obj.hasOwnProperty(key)) {
+                val = obj[key];
+                if (typeof(val) === 'number') {
+                    result = makePair(makeList(makeSymbol(key),
+                                               plt.baselib.numbers.makeFloat(val)),
+                                      result);
+                } else if (typeof(val) === 'string') {
+                    result = makePair(makeList(makeSymbol(key), val),
+                                      result);
+                }                         
+            }
+        }
+        return eventStructType.constructor(result);
+    };
+
+
+
 
 
     /* Event sources.
@@ -556,8 +685,9 @@
 
     TickEventSource.prototype.onStart = function(fireEvent) {
         this.id = setInterval(
-            function() {
+            function(evt) {
-                fireEvent(undefined);
+                fireEvent(undefined,
+                          objectToEvent(evt));
             },
             this.delay);
     };
@@ -570,6 +700,93 @@
     };
 
 
+
+
+
+
+    var MockLocationEventSource = function() {
+        this.elt = undefined;
+    };
+    MockLocationEventSource.prototype = plt.baselib.heir(EventSource.prototype);
+    MockLocationEventSource.prototype.onStart = function(fireEvent) {
+        var mockLocationSetter = document.createElement("div");
+	    
+        var latInput = document.createElement("input");
+        latInput.type = "text";
+	
+        var latOutput = document.createElement("input");
+        latOutput.type = "text";
+        
+        var submitButton = document.createElement("input");
+        submitButton.type = "button";
+        submitButton.value = "send lat/lng";
+        submitButton.onclick = function() {
+            fireEvent(undefined,
+                      objectToEvent({ latitude: Number(latInput.value),
+                                      longitude: Number(latOutput.value)}));
+            return false;
+        };
+	
+        mockLocationSetter.style.border = "1pt solid black";
+        mockLocationSetter.appendChild(
+            document.createTextNode("mock location setter"));
+        mockLocationSetter.appendChild(latInput);
+        mockLocationSetter.appendChild(latOutput);
+        mockLocationSetter.appendChild(submitButton);
+        document.body.appendChild(mockLocationSetter);
+
+        this.elt = mockLocationSetter;
+    };
+
+    MockLocationEventSource.prototype.onStop = function() {
+        if (this.elt !== undefined) { 
+            document.body.removeChild(this.elt);
+            this.elt = undefined;
+        };
+    };
+
+    
+
+
+
+    // This version really does use the geolocation object.
+    var LocationEventSource = function() {
+        this.id = undefined;
+    };
+
+    LocationEventSource.prototype = plt.baselib.heir(EventSource.prototype);
+
+    LocationEventSource.prototype.onStart = function(fireEvent) {
+        var success = function(position) {
+            fireEvent(undefined,
+                      objectToEvent(position.coords));
+        };
+        var fail = function(err) {
+            // Quiet failure
+        }
+        if (!!(navigator.geolocation)) {
+            navigator.geolocation.getCurrentPosition(success, fail);
+            this.id = navigator.geolocation.watchPosition(success, fail); 
+        }
+    };
+    
+    LocationEventSource.prototype.onStop = function() {
+        if (this.id !== undefined) { 
+            navigator.geolocation.clearWatch(this.id);
+            this.id = undefined;
+        };
+    };
+
+
+
+
+
+
+
+
+
+
+
     // DomElementSource: string (U DOM string) -> EventSource
     // A DomEventSource allows DOM elements to send events over to
     // web-world.
@@ -589,7 +806,7 @@
 
         this.handler = function(evt) {
             if (element !== undefined) {
-                fireEvent(element, evt);
+                fireEvent(element, objectToEvent(evt));
             }
         };
         if (element !== undefined) {
@@ -663,12 +880,19 @@
         var stopWhen = (find(handlers, isStopWhenHandler) || { stopWhen: defaultStopWhen }).stopWhen;
         var toDraw = (find(handlers, isToDrawHandler) || {toDraw : defaultToDraw} ).toDraw;
 
+        var oldOutputPort = MACHINE.params.currentOutputPort;
+
         var eventQueue = new EventQueue();
 
         var top = $("<div/>");
         var eventHandlers = filter(handlers, isEventHandler).concat(view.getEventHandlers());
 
         MACHINE.params.currentDisplayer(MACHINE, top);
+        
+        // From this point forward, redirect standard output if requested.
+        if (find(handlers, isWithOutputToHandler)) {
+            MACHINE.params.currentOutputPort = find(handlers, isWithOutputToHandler).outputPort;
+        }
 
         PAUSE(function(restart) {
             var i;
@@ -678,6 +902,7 @@
                 stopEventHandlers();
                 restart(function(MACHINE) {
                     MACHINE.argcount = oldArgcount;
+                    MACHINE.params.currentOutputPort = oldOutputPort;
                     currentBigBangRecord = oldCurrentBigBangRecord;
                     finalizeClosureCall(MACHINE, world);
                 });
@@ -688,6 +913,7 @@
                 stopEventHandlers();
                 restart(function(MACHINE) {
                     currentBigBangRecord = oldCurrentBigBangRecord;
+                    MACHINE.params.currentOutputPort = oldOutputPort;
                     plt.baselib.exceptions.raise(MACHINE, exn);
                 });
             };
@@ -752,29 +978,37 @@
 
                     // FIXME: deal with event data here
                     racketWorldCallback = nextEvent.handler.racketWorldCallback;
-                    racketWorldCallback(MACHINE, 
+                    data = nextEvent.data[0];
-                                        world,
+                    var onGoodWorldUpdate = 
-                                        mockView,
+                        function(newWorld) {
-                                        // data, 
+                            world = newWorld;
-                                        function(newWorld) {
+                            stopWhen(MACHINE,
-                                            world = newWorld;
+                                     world,
-                                            stopWhen(MACHINE,
+                                     mockView,
-                                                     world,
+                                     function(shouldStop) {
-                                                     mockView,
+                                         if (shouldStop) {
-                                                     function(shouldStop) {
+                                             refreshView(onCleanRestart,
-                                                         if (shouldStop) {
+                                                         fail);
-                                                             refreshView(
+                                         } else {
-                                                                 function() {
+                                             dispatchEventsInQueue(success, fail);
-                                                                     onCleanRestart();
+                                         }
-                                                                 },
+                                     },
-                                                                 fail);
+                                     fail);
-                                                         } else {
+                        };
-                                                             dispatchEventsInQueue(success, fail);
+                    if (plt.baselib.arity.isArityMatching(racketWorldCallback.racketArity, 3)) {
-                                                         }
+                        racketWorldCallback(MACHINE, 
-                                                     },
+                                            world,
-                                                     fail);
+                                            mockView,
-                                        },
+                                            data,
-                                        fail);
+                                            onGoodWorldUpdate,
+                                            fail);
+                    } else {
+                        racketWorldCallback(MACHINE, 
+                                            world,
+                                            mockView,
+                                            onGoodWorldUpdate,
+                                            fail);
+                    }
                 } else {
                     dispatchingEvents = false;
                     success();
@@ -821,7 +1055,7 @@
     };
 
     var wrapFunction = function(proc) {
-        return function(MACHINE) {
+        var f = function(MACHINE) {
             var success = arguments[arguments.length - 2];
             var fail = arguments[arguments.length - 1];
             var args = [].slice.call(arguments, 1, arguments.length - 2);
@@ -831,6 +1065,8 @@
                                                                         success,
                                                                         fail].concat(args));
         };
+        f.racketArity = proc.racketArity;
+        return f;
     };
 
 
@@ -867,12 +1103,27 @@
 
 
 
+
+    var DomElementOutputPort = function(id) {
+        this.id = id;
+    };
+
+    DomElementOutputPort.prototype = plt.baselib.heir(plt.baselib.ports.OutputPort.prototype);
+
+    DomElementOutputPort.prototype.writeDomNode = function (MACHINE, v) {
+        $("#" + this.id).append(v);
+        $(v).trigger({type : 'afterAttach'});
+        $('*', v).trigger({type : 'afterAttach'});
+    };
+
+
+
     //////////////////////////////////////////////////////////////////////
 
     var checkReal = plt.baselib.check.checkReal;
     var checkString = plt.baselib.check.checkString;
     var checkSymbolOrString = plt.baselib.check.checkSymbolOrString;
-    
+    var checkOutputPort = plt.baselib.check.checkOutputPort;    
     var checkProcedure = plt.baselib.check.checkProcedure;
 
     var checkResourceOrView = plt.baselib.check.makeCheckArgumentType(
@@ -1102,7 +1353,7 @@
         3,
         function(MACHINE) {
             var view = checkMockView(MACHINE, 'view-bind', 0);
-            var name = checkSymbolOrString(MACHINE, 'view-bind', 1).toString();
+            var name = checkSymbolOrString(MACHINE, 'view-bind', 1);
             var worldF = wrapFunction(checkProcedure(MACHINE, 'view-bind', 2));
             return view.bind(name, worldF);
         });
@@ -1126,6 +1377,95 @@
             return view.updateFormValue(value);
         });
 
+    EXPORTS['view-show'] = makePrimitiveProcedure(
+        'view-show',
+        1,
+        function(MACHINE) {
+            var view = checkMockView(MACHINE, 'view-show', 0);
+            return view.show();
+        });
+
+
+    EXPORTS['view-hide'] = makePrimitiveProcedure(
+        'view-hide',
+        1,
+        function(MACHINE) {
+            var view = checkMockView(MACHINE, 'view-hide', 0);
+            return view.hide();
+        });
+
+
+    
+    EXPORTS['view-append-child'] = makeClosure(
+        'view-append-child',
+        2,
+        function(MACHINE) {
+            var view = checkMockView(MACHINE, 'view-append-child', 0);
+            var oldArgcount = MACHINE.argcount;
+            var x = MACHINE.env[MACHINE.env.length - 2];
+            PAUSE(function(restart) {
+                coerseToDomNode(x,
+                                function(dom) {
+                                     restart(function(MACHINE) {
+                                         MACHINE.argcount = oldArgcount;
+                                         var updatedView = view.appendChild(dom);
+                                         finalizeClosureCall(MACHINE, updatedView);
+                                     });
+                                },
+                                function(err) {
+                                    restart(function(MACHINE) {
+                                         plt.baselib.exceptions.raise(
+                                             MACHINE, 
+                                             new Error(plt.baselib.format.format(
+                                                 "unable to translate ~s to dom node: ~a",
+                                                 [x, exn.message])));
+                                        
+                                    });
+                                });
+            });
+        });
+
+
+    EXPORTS['view-id'] = makePrimitiveProcedure(
+        'view-id',
+        1,
+        function(MACHINE) {
+            var view = checkMockView(MACHINE, 'view-hide', 0);
+            return view.id();
+        });
+
+
+
+
+    EXPORTS['on-location-change'] = makePrimitiveProcedure(
+        'on-location-change',
+        1,
+        function(MACHINE) {
+            var onChange = wrapFunction(checkProcedure(MACHINE, 'on-location-change', 0));
+            return new EventHandler('on-location-change', 
+                                    new LocationEventSource(), 
+                                    onChange);
+        });
+
+
+    EXPORTS['on-mock-location-change'] = makePrimitiveProcedure(
+        'on-mock-location-change',
+        1,
+        function(MACHINE) {
+            var onChange = wrapFunction(checkProcedure(MACHINE, 'on-mock-location-change', 0));
+            return new EventHandler('on-mock-location-change', 
+                                    new MockLocationEventSource(), 
+                                    onChange);
+        });
+
+
+    EXPORTS['open-output-element'] = makePrimitiveProcedure(
+        'open-output-element',
+        1,
+        function(MACHINE) {
+            var id = checkString(MACHINE, 'open-output-element', 0);
+            return new DomElementOutputPort(id.toString());
+        });
 
 
 

web-world/main.rkt

@@ -1,4 +1,7 @@
 #lang s-exp "../lang/base.rkt"
 
-(require "impl.rkt")
+(require "impl.rkt"
-(provide (all-from-out "impl.rkt"))
+         "event.rkt")
+
+(provide (all-from-out "impl.rkt")
+         (all-from-out "event.rkt"))

web-world/racket-impl.rkt

@@ -1,16 +1,28 @@
 #lang racket/base
 
-(provide big-bang initial-view stop-when on-tick to-draw
+(provide big-bang initial-view stop-when
+         on-tick
+         on-location-change on-mock-location-change
+         to-draw
+
          ->view
          view-focus
          view-left view-right view-up view-down
          view-text update-view-text
          view-attr update-view-attr
+         view-id
+
          view-bind
 
          view-form-value
          update-view-form-value
-         )
+
+         view-show
+         view-hide
+         view-append-child
+
+         open-output-element)
+
 
 (define (big-bang world . handlers)
   (error 'big-bang "Please run in JavaScript context."))
@@ -27,6 +39,22 @@
                [(f delay)
                 (error 'on-tick "Please run in JavaScript context.")]))
 
+
+(define on-location-change
+  (case-lambda [(f)
+                (error 'on-location-change "Please run in JavaScript context.")]
+               [(f delay)
+                (error 'on-location-change "Please run in JavaScript context.")]))
+
+
+(define on-mock-location-change
+  (case-lambda [(f)
+                (error 'on-mock-location-change "Please run in JavaScript context.")]
+               [(f delay)
+                (error 'on-mock-location-change "Please run in JavaScript context.")]))
+
+
+
 (define (to-draw w)
   (error 'to-draw "Please run in JavaScript context."))
 
@@ -67,6 +95,10 @@
   (error 'update-view-attr "Please run in JavaScript context."))
 
 
+(define (view-id v)
+  (error 'view-id "Please run in JavaScript context."))
+
+
 (define (view-bind v type worldF)
   (error 'view-bind "Please run in JavaScript context."))
 
@@ -75,3 +107,18 @@
 
 (define (update-view-form-value val)
   (error 'view-form-value "Please run in JavaScript context."))
+
+
+(define (view-show)
+  (error 'view-show "Please run in JavaScript context."))
+
+(define (view-hide)
+  (error 'view-hide "Please run in JavaScript context."))
+
+
+(define (view-append-child dom)
+  (error 'view-append "Please run in JavaScript context."))
+
+
+(define (open-output-element id)
+  (error 'open-output-element "Please run in JavaScript context."))