├── .gitignore
├── README.md
├── compiler-rjs
    ├── README.md
    ├── compiler.rkt
    ├── compiler2.rkt
    ├── compiler3.rkt
    ├── htdp
    │   ├── colors.rkt
    │   └── ffi.rkt
    ├── info.rkt
    ├── runtime.exports
    ├── runtime.js
    └── runtime.rkt
├── compiler-test
    ├── letrec.tests
    ├── numbers.tests
    └── test-suite-compiler.rkt
├── info.rkt
├── urlang-examples
    ├── README.md
    ├── demo-fact.rkt
    ├── info.rkt
    ├── parabola
    │   └── parabola.rkt
    ├── quiz
    │   └── quiz.rkt
    ├── ractive
    │   ├── README.md
    │   ├── ractive-bootstrap-example.html
    │   ├── ractive-bootstrap-example.rkt
    │   ├── ractive-original.rkt
    │   ├── ractive.js
    │   └── ractive.rkt
    ├── raphael
    │   ├── browser.exports
    │   ├── browser.html
    │   ├── browser.js
    │   └── browser.rkt
    ├── react
    │   └── urx.rkt
    └── space-invaders
    │   └── space-invaders.rkt
├── urlang-test
    ├── test-extra.rkt
    └── urlang-tests.rkt
└── urlang
    ├── README.md
    ├── extra.rkt
    ├── for.rkt
    ├── globals.rkt
    ├── html.rkt
    ├── html
        ├── README.md
        ├── all.rkt
        ├── at-html.rkt
        ├── tag-comparison.rkt
        └── to-at-exp.rkt
    ├── info.rkt
    ├── main.rkt
    ├── react
        └── urx.rkt
    ├── symbol-table.rkt
    └── tests
        ├── test-async-and-await.rkt
        ├── test-const-and-let.rkt
        ├── test-extra.rkt
        ├── test-for.rkt
        ├── test-new-expressions.rkt
        └── test-operators.rkt


/.gitignore:
--------------------------------------------------------------------------------
 1 | # The "build" and "bundle" directories are used when creating installers
 2 | # via the `server', `client', and/or `farm' maefile targets.
 3 | #/build/
 4 | #/bundle/
 5 | 
 6 | # It's common to configure the PLTADDONDIR to be here.
 7 | #/add-on/
 8 | 
 9 | # This is where to put packages installed with `--clone`
10 | #/extra-pkgs/
11 | 
12 | # Everything below makes sense on any package repository, so it's
13 | # stuff that should be put into each such repository. The same holds
14 | # for ".mailmap" (which some people can decide if they want to thin it
15 | # out or not include it) and for ".gitattributes" (which is probably
16 | # irrelevant except maybe for the core repo).
17 | 
18 | compiled/
19 | 
20 | # common backups, autosaves, lock files, OS meta-files
21 | *~
22 | \#*
23 | .#*
24 | .DS_Store
25 | *.bak
26 | TAGS
27 | 
28 | # generated by patch
29 | *.orig
30 | *.rej
31 | 
32 | # coredumps
33 | *.core     
34 |      
35 |   
36 | 
37 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
  1 | # URLANG
  2 | 
  3 | > Urlang is JavaScript with a sane syntax
  4 | 
  5 | Urlang is a language designed to allow straightforward translation to JavaScript.
  6 | Think of Urlang as JavaScript with sane syntax and JavaScript semantics.
  7 | JavaScript in this context is short for ECMAScript 5 in strict mode.
  8 | 
  9 | Although the constructs of Urlang and JavaScript map almost one-to-one,
 10 | a little sugar was added:
 11 |   * function definitions allow default arguments
 12 |   * let expressions
 13 | 
 14 | Even though the syntax of Urlang is Racket-like, remember that the
 15 | semantics is standard JavaScript. This means in particular that tail calls
 16 | build context.
 17 | 
 18 | 
 19 | ## Examples
 20 | 
 21 | The following examples are compiled using the `urlang` form.
 22 | 
 23 |     (urlang <module> ...)
 24 | 
 25 | The urlang form compiles the modules. The result of compiling
 26 | a module is saved a file whose path is the module-name with `.js`
 27 | added.
 28 | 
 29 | The `urlang` form is controlled by the following parameters:
 30 | 
 31 |     (current-urlang-run?                           #t)  ; compile and run (using node)
 32 |     (current-urlang-echo?                          #t)  ; print JavaScript to screen
 33 |     (current-urlang-console.log-module-level-expr? #t)  ; use conole.log to print module-level exprs
 34 | 
 35 | 
 36 | ### Example (factorial)
 37 | 
 38 |      > (urlang
 39 |          (urmodule fact                                           ; module name
 40 |            (export fact)                                          ; fact is exported
 41 |            (import + - * = displayln ref console)
 42 |            (define (fact n) (if (= n 0) 1 (* n (fact (- n 1)))))
 43 |            (fact 5)))
 44 | 
 45 | The generated JavaScript:
 46 | 
 47 |      "use strict";
 48 |      function fact(n){return (((n===0)===false)?(n*(fact((n-1)))):1);};
 49 |      console.log((fact(5)));
 50 |      exports.fact=fact;
 51 | 
 52 | The output from Node:
 53 | 
 54 |      "120\n"
 55 | 
 56 | 
 57 | ### Example (`cond`-macro and `array`)
 58 | 
 59 | Urlang macro transformers receive and produce standard Racket syntax objects.
 60 | This implies that standard tools such as syntax-parse are available.
 61 | 
 62 | Consider an Urlang version of `cond`:
 63 | 
 64 |     SYNTAX (cond [e0 e1 e2 ...] ... [else en]), 
 65 |        like Racket cond except there is no new scope 
 66 | 
 67 |  The urlang macro transformer is an standard (phase 0) Racket function.
 68 | 
 69 |       (define-urlang-macro cond
 70 |         (λ (stx)   
 71 |           (syntax-parse stx
 72 |             [(_cond [else e0:Expr e:Expr ...])
 73 |              #'(begin e0 e ...)]
 74 |             [(_cond [e0 e1 e2 ...] clause ...)
 75 |              (syntax/loc stx
 76 |                (if e0 (begin e1 e2 ...) (cond clause ...)))]
 77 |             [(_cond)
 78 |              (raise-syntax-error 'cond "expected an else clause" stx)])))
 79 |              
 80 |  The macro can now we be used:
 81 |              
 82 |     > (urlang
 83 |         (urmodule sum-example
 84 |           (define (even? x) (=== (% x 2) 0))
 85 |           (var (sum 0) x (a (array 1 2 3 4 5)) (i 0) (n a.length))
 86 |           (while (< i n)
 87 |             (:= x (ref a i))
 88 |             (cond
 89 |               [(even? x)  (+= sum (ref a i))]
 90 |               [else       "skip"])
 91 |             (+= i 1))
 92 |           sum))
 93 | 
 94 | The generated JavaScript:
 95 | 
 96 |     "use strict";
 97 |     function even_p(x){return ((x%2)===0);};
 98 |     var sum=0,x,a=[1,2,3,4,5],i=0,n=a.length;
 99 |     while((i<n)){(x=a[i]);(((even_p(x))===false)?"skip":(sum+=a[i]));(i+=1);};
100 |     console.log(sum);
101 | 
102 | The output from Node:
103 | 
104 |     "6\n"
105 | 
106 | # Overview
107 | 
108 | The heart of the system is a compiler written using the Nanopass
109 | compiler Framework. The compiler is exported as a function
110 | 
111 |     compile : urlang-module -> JavaScript
112 | 
113 | that compiles an urlang module and produces JavaScript,
114 | that can be evaluated by the Node.js platform (or be embedded in a web page).
115 | 
116 | The Urlang module to be compiled can be represented 
117 | 
118 |    1. as a syntax object
119 |    2. as a Nanopass structure (representing an Lurlang program)
120 | 
121 | Use 1) to program in Urlang directly.
122 | 
123 | Use 2) if you intend to use Urlang as a compiler backend.
124 | 
125 | [Note: Nanopass is a framework for implementing compilers.]
126 | 
127 | The intended use of Urlang is to use 1) to write (generate) a Racket runtime in JavaScript.
128 | The middle-end of the Racket-to-JavaScript compiler will produce output as Nanopass
129 | structures, so 2) will be used as the backend for the Racket-to-JavaScript compiler.
130 | 
131 | Internally the function expand
132 | 
133 |     expand : syntax -> LUrlang
134 | 
135 | will parse and expand its input and produce an LUrlang representation.
136 | 
137 | Note that `expand` allows the user to extend the input language
138 | using define-urlang-macro. An Urlang macro is a syntax to syntax
139 | transformation implemented as a normal Racket function.
140 | This allow you to use all of the standard Racket macro machinery.
141 | 
142 | Main functions:
143 | 
144 |     expand : syntax -> Lurlang
145 |         expand the input and produce a fully expanded Urlang program
146 |         represented as a Lurlang structure
147 |         
148 |     compile : syntax ->
149 |         Expand and compile. The output is written to standard out.
150 |         
151 |     eval : syntax -> value
152 |         expand, compile and run the input (an Urlang module represented as a syntax object)
153 |         Running means that `node` is used to run the generated JavaScript.
154 | 
155 | Having Urlang as a `#lang` language allows
156 | 
157 |  * macros (using full Racket at compile time)
158 |  * export of defined names
159 |  * easier testing
160 | 
161 | In the grammar below:
162 | 
163 |   - `x` stands for a non-keyword identifier
164 |   - `f` stands for an identifier defined as a function
165 | 
166 | ````
167 |  <module>            ::= (urmodule <module-name> <module-path> <module-level-form> ...)
168 | 
169 |  <module-level-form> ::= <export> | <import> | <definition> | <statement> 
170 |  <export>            ::= (export x ...)
171 |  <import>            ::= (import x ...)
172 |  <definition>        ::= (define (f <formal> ...) <body>)
173 |                       |  (define x <expr>)
174 |  <formal>           ::= x | [x <expr>]
175 | 
176 |  <statement>         ::= <var-decl> | <block> | <while> | <do-while> | <if> | <break> | <expr> 
177 |  <var-decl>          ::= (var <var-binding> ...)
178 |  <block>             ::= (block <statement> ...)
179 |  <var-binding>       ::= x | (x e)
180 |  <while>             ::= (while <expr> <statement> ...)
181 |  <do-while>          ::= (do-while <expr> <statement> ...)
182 |  <if>                ::= (sif <expr> <statement> <statement>)
183 |  <break>             ::= (break) | (break label)
184 | 
185 |  <body>              ::= <statement> ... <expr>
186 | 
187 |  <expr>              ::= <datum>   | <reference> | <application> | <sequence>
188 |                       |  <ternary> | <assignment> | <let> | <lambda> | <dot>
189 |  <ternary>           ::= (if <expr> <expr> <expr>)
190 |  <reference>         ::= x
191 |  <application>       ::= (<expr> <expr> ...)
192 |  <sequence>          ::= (begin <expr> ...)
193 |  <assignment>        ::= (:= x <expr>)
194 |  <let>               ::= (let ((x <expr>) ...) <statement> ... <expr>)
195 |  <lambda>            ::= (lambda (<formal> ...) <body>)
196 | 
197 |  <keyword>           ::= define | begin | urmodule | if | := | ...se code...
198 | 
199 |  <datum>             ::= <fixnum> | <string> | #t | #f
200 | 
201 |  <identifier>     an identifier that is not a keyword
202 |  <fixnum>         an integer between -2^53 and 2^53
203 |  <module-name>    a symbol or string
204 | ````
205 | 
206 | # NOTES
207 | 
208 | Some application are special cases:
209 | 
210 |     (ref e0 e1)     becomes  e0[e1]
211 |     (ref e0 "str")  becomes  e0.str    
212 |     (array e ...)   becomes  [e,...]
213 | 
214 | Property access with dot notation is rewritten to use bracket syntax in the parser.
215 | 
216 | Example:  `object.property` becomes `object["property"]`
217 | 
218 | 
219 | # SEMANTICS
220 | 
221 | ### `(if e0 e1 e2)`
222 | If `e0` evaluates to value strictly equal to false, then `e2` otherwise `e1`.
223 | Note: The JavaScript becomes  `((e0===false) ? e2 : e1)`
224 | 
225 | ### `(var x (y 3))`
226 | Binds `x` to undefined and `y` to `3`.
227 | 


--------------------------------------------------------------------------------
/compiler-rjs/README.md:
--------------------------------------------------------------------------------
 1 | Racket to JavaScript Compiler
 2 | =============================
 3 | 
 4 | This collection contains a compiler that hopefully
 5 | will evolve into a compiler that can compile Racket
 6 | programs into JavaScript programs.
 7 | 
 8 | The real Racket runtime is *huge* so it is is doubtful,
 9 | that all corners of Racket will be covered. However
10 | I hope to the compiler eventually will be able to
11 | compile a large subset of all Racket programs.
12 | 
13 | The status so far:
14 | 
15 |     - no continuation marks
16 |     - no exceptions
17 | 
18 | The runtime library is in "runtime.rkt".
19 | See the complete list of support data structures
20 | and implemented functions in the source.
21 | 
22 | On JavaScript implementations that support (JavaScript) TCO the output
23 | of the compiler ought to handle (Racket) tail calls properly.
24 | 
25 | /Jens Axel Søgaard
26 | 


--------------------------------------------------------------------------------
/compiler-rjs/htdp/colors.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | ; uncomment to test in Racket
  3 | (struct color (red green blue [alpha #:auto])
  4 |   #:auto-value 255 #:transparent)
  5 | 
  6 | (define (color->web-color color)
  7 |   (string-append "rgba("
  8 |                  (color-red   color) ","
  9 |                  (color-green color) ","
 10 |                  (color-blue  color) ","
 11 |                  (color-alpha color) ")"))
 12 | 
 13 | (define (string->web-color str)
 14 |   (color->web-color (string->color str)))
 15 | 
 16 | (define string->color
 17 |   (let ()
 18 |     (define *color-table* (make-hasheq))
 19 |     (define colors
 20 |       ; TODO: This is the short list.
 21 |       ;       The full list is below.
 22 |       '(["orange"               (255 165   0)]
 23 |         ["darkred"              (139   0   0)]
 24 |         ["red"                  (255   0   0)]
 25 |         ["lightpink"            (255 182 193)]
 26 |         ["pink"                 (255 192 203)]
 27 |         ["brown"                (132  60  36)]
 28 |         ["gold"                 (255 215   0)]
 29 |         ["yellow"               (255 255   0)]
 30 |         ["olive"                (128 128   0)]
 31 |         ["green"                (  0 255   0)]
 32 |         ["dark green"           (  0 100   0)]
 33 |         ["darkgreen"            (  0 100   0)]
 34 |         ["aquamarine"           (112 216 144)]
 35 |         ["lightgreen"           (144 238 144)]
 36 |         ["turquoise"            ( 64 224 208)]
 37 |         ["royalblue"            ( 65 105 225)]
 38 |         ["cyan"                 (  0 255 255)]
 39 |         ["aqua"                 (  0 255 255)]
 40 |         ["darkcyan"             (  0 139 139)]
 41 |         ["teal"                 (  0 128 128)]
 42 |         ["sky blue"             (135 206 235)]
 43 |         ["skyblue"              (135 206 235)]
 44 |         ["light blue"           (173 216 230)]
 45 |         ["lightblue"            (173 216 230)]
 46 |         ["lightcyan"            (224 255 255)]
 47 |         ["medium blue"          (  0   0 205)]
 48 |         ["mediumblue"           (  0   0 205)]
 49 |         ["darkblue"             (  0   0 139)]
 50 |         ["midnight blue"        ( 25  25 112)]
 51 |         ["midnightblue"         ( 25  25 112)]
 52 |         ["navy"                 ( 36  36 140)]
 53 |         ["blue"                 (  0   0 255)]
 54 |         ["indigo"               ( 75   0 130)]
 55 |         ["purple"               (160  32 240)]
 56 |         ["darkviolet"           (148   0 211)]
 57 |         ["mediumpurple"         (147 112 219)]
 58 |         ["magenta"              (255   0 255)]
 59 |         ["darkmagenta"          (139   0 139)]
 60 |         ["violet"               (238 130 238)]
 61 |         ["lavender"             (230 230 250)]
 62 |         ["white"                (255 255 255)]
 63 |         ["light gray"           (211 211 211)]
 64 |         ["lightgray"            (211 211 211)]
 65 |         ["silver"               (192 192 192)]
 66 |         ["gray"                 (190 190 190)]
 67 |         ["dark gray"            (169 169 169)]
 68 |         ["darkgray"             (169 169 169)]
 69 |         ["black"                (  0   0   0)])
 70 |       #;'(["orange"               (255 165   0)]
 71 |         ["orangered"            (255  69   0)]
 72 |         ["tomato"               (255  99  71)]
 73 |         ["darkred"              (139   0   0)]
 74 |         ["red"                  (255   0   0)]
 75 |         ["firebrick"            (178  34  34)]
 76 |         ["crimson"              (220  20  60)]
 77 |         ["deeppink"             (255  20 147)]
 78 |         ["maroon"               (176  48  96)]
 79 |         ["indian red"           (205  92  92)]
 80 |         ["indianred"            (205  92  92)]
 81 |         ["medium violet red"    (199  21 133)]
 82 |         ["mediumvioletred"      (199  21 133)]
 83 |         ["violet red"           (208  32 144)]
 84 |         ["violetred"            (208  32 144)]
 85 |         ["lightcoral"           (240 128 128)]
 86 |         ["hotpink"              (255 105 180)]
 87 |         ["palevioletred"        (219 112 147)]
 88 |         ["lightpink"            (255 182 193)]
 89 |         ["rosybrown"            (188 143 143)]
 90 |         ["pink"                 (255 192 203)]
 91 |         ["orchid"               (218 112 214)]
 92 |         ["lavenderblush"        (255 240 245)]
 93 |         ["snow"                 (255 250 250)]
 94 |         ["chocolate"            (210 105  30)]
 95 |         ["saddlebrown"          (139  69  19)]
 96 |         ["brown"                (132  60  36)]
 97 |         ["darkorange"           (255 140   0)]
 98 |         ["coral"                (255 127 80)]
 99 |         ["sienna"               (160  82  45)]
100 |         ["salmon"               (250 128 114)]
101 |         ["peru"                 (205 133  63)]
102 |         ["darkgoldenrod"        (184 134  11)]
103 |         ["goldenrod"            (218 165  32)]
104 |         ["sandybrown"           (244 164  96)]
105 |         ["lightsalmon"          (255 160 122)]
106 |         ["darksalmon"           (233 150 122)]
107 |         ["gold"                 (255 215   0)]
108 |         ["yellow"               (255 255   0)]
109 |         ["olive"                (128 128   0)]
110 |         ["burlywood"            (222 184 135)]
111 |         ["tan"                  (210 180 140)]
112 |         ["navajowhite"          (255 222 173)]
113 |         ["peachpuff"            (255 218 185)]
114 |         ["khaki"                (240 230 140)]
115 |         ["darkkhaki"            (189 183 107)]
116 |         ["moccasin"             (255 228 181)]
117 |         ["wheat"                (245 222 179)]
118 |         ["bisque"               (255 228 196)]
119 |         ["palegoldenrod"        (238 232 170)]
120 |         ["blanchedalmond"       (255 235 205)]
121 |         ["medium goldenrod"     (234 234 173)]
122 |         ["mediumgoldenrod"      (234 234 173)]
123 |         ["papayawhip"           (255 239 213)]
124 |         ["mistyrose"            (255 228 225)]
125 |         ["lemonchiffon"         (255 250 205)]
126 |         ["antiquewhite"         (250 235 215)]
127 |         ["cornsilk"             (255 248 220)]
128 |         ["lightgoldenrodyellow" (250 250 210)]
129 |         ["oldlace"              (253 245 230)]
130 |         ["linen"                (250 240 230)]
131 |         ["lightyellow"          (255 255 224)]
132 |         ["seashell"             (255 245 238)]
133 |         ["beige"                (245 245 220)]
134 |         ["floralwhite"          (255 250 240)]
135 |         ["ivory"                (255 255 240)]
136 |         ["green"                (  0 255   0)]
137 |         ["lawngreen"            (124 252   0)]
138 |         ["chartreuse"           (127 255   0)]
139 |         ["green yellow"         (173 255  47)]
140 |         ["greenyellow"          (173 255  47)]
141 |         ["yellow green"         (154 205  50)]
142 |         ["yellowgreen"          (154 205  50)]
143 |         ["medium forest green"  (107 142  35)]
144 |         ["olivedrab"            (107 142  35)]
145 |         ["mediumforestgreen"    (107 142  35)]
146 |         ["dark olive green"     ( 85 107  47)]
147 |         ["darkolivegreen"       ( 85 107  47)]
148 |         ["darkseagreen"         (143 188 139)]
149 |         ["lime"                 (  0 255   0)]
150 |         ["dark green"           (  0 100   0)]
151 |         ["darkgreen"            (  0 100   0)]
152 |         ["lime green"           ( 50 205  50)]
153 |         ["limegreen"            ( 50 205  50)]
154 |         ["forest green"         ( 34 139  34)]
155 |         ["forestgreen"          ( 34 139  34)]
156 |         ["spring green"         (  0 255 127)]
157 |         ["springgreen"          (  0 255 127)]
158 |         ["medium spring green"  (  0 250 154)]
159 |         ["mediumspringgreen"    (  0 250 154)]
160 |         ["sea green"            ( 46 139  87)]
161 |         ["seagreen"             ( 46 139  87)]
162 |         ["medium sea green"     ( 60 179 113)]
163 |         ["mediumseagreen"       ( 60 179 113)]
164 |         ["aquamarine"           (112 216 144)]
165 |         ["lightgreen"           (144 238 144)]
166 |         ["pale green"           (152 251 152)]
167 |         ["palegreen"            (152 251 152)]
168 |         ["medium aquamarine"    (102 205 170)]
169 |         ["mediumaquamarine"     (102 205 170)]
170 |         ["turquoise"            ( 64 224 208)]
171 |         ["lightseagreen"        ( 32 178 170)]
172 |         ["medium turquoise"     ( 72 209 204)]
173 |         ["mediumturquoise"      ( 72 209 204)]
174 |         ["honeydew"             (240 255 240)]
175 |         ["mintcream"            (245 255 250)]
176 |         ["royalblue"            ( 65 105 225)]
177 |         ["dodgerblue"           ( 30 144 255)]
178 |         ["deepskyblue"          (  0 191 255)]
179 |         ["cornflowerblue"       (100 149 237)]
180 |         ["steel blue"           ( 70 130 180)]
181 |         ["steelblue"            ( 70 130 180)]
182 |         ["lightskyblue"         (135 206 250)]
183 |         ["dark turquoise"       (  0 206 209)]
184 |         ["darkturquoise"        (  0 206 209)]
185 |         ["cyan"                 (  0 255 255)]
186 |         ["aqua"                 (  0 255 255)]
187 |         ["darkcyan"             (  0 139 139)]
188 |         ["teal"                 (  0 128 128)]
189 |         ["sky blue"             (135 206 235)]
190 |         ["skyblue"              (135 206 235)]
191 |         ["cadet blue"           ( 96 160 160)]
192 |         ["cadetblue"            ( 95 158 160)]
193 |         ["dark slate gray"      ( 47  79  79)]
194 |         ["darkslategray"        ( 47  79  79)]
195 |         ["lightslategray"       (119 136 153)]
196 |         ["slategray"            (112 128 144)]
197 |         ["light steel blue"     (176 196 222)]
198 |         ["lightsteelblue"       (176 196 222)]
199 |         ["light blue"           (173 216 230)]
200 |         ["lightblue"            (173 216 230)]
201 |         ["powderblue"           (176 224 230)]
202 |         ["paleturquoise"        (175 238 238)]
203 |         ["lightcyan"            (224 255 255)]
204 |         ["aliceblue"            (240 248 255)]
205 |         ["azure"                (240 255 255)]
206 |         ["medium blue"          (  0   0 205)]
207 |         ["mediumblue"           (  0   0 205)]
208 |         ["darkblue"             (  0   0 139)]
209 |         ["midnight blue"        ( 25  25 112)]
210 |         ["midnightblue"         ( 25  25 112)]
211 |         ["navy"                 ( 36  36 140)]
212 |         ["blue"                 (  0   0 255)]
213 |         ["indigo"               ( 75   0 130)]
214 |         ["blue violet"          (138  43 226)]
215 |         ["blueviolet"           (138  43 226)]
216 |         ["medium slate blue"    (123 104 238)]
217 |         ["mediumslateblue"      (123 104 238)]
218 |         ["slate blue"           (106  90 205)]
219 |         ["slateblue"            (106  90 205)]
220 |         ["purple"               (160  32 240)]
221 |         ["dark slate blue"      ( 72  61 139)]
222 |         ["darkslateblue"        ( 72  61 139)]
223 |         ["darkviolet"           (148   0 211)]
224 |         ["dark orchid"          (153  50 204)]
225 |         ["darkorchid"           (153  50 204)]
226 |         ["mediumpurple"         (147 112 219)]
227 |         ["cornflower blue"      ( 68  64 108)]
228 |         ["medium orchid"        (186  85 211)]
229 |         ["mediumorchid"         (186  85 211)]
230 |         ["magenta"              (255   0 255)]
231 |         ["fuchsia"              (255   0 255)]
232 |         ["darkmagenta"          (139   0 139)]
233 |         ["violet"               (238 130 238)]
234 |         ["plum"                 (221 160 221)]
235 |         ["lavender"             (230 230 250)]
236 |         ["thistle"              (216 191 216)]
237 |         ["ghostwhite"           (248 248 255)]
238 |         ["white"                (255 255 255)]
239 |         ["whitesmoke"           (245 245 245)]
240 |         ["gainsboro"            (220 220 220)]
241 |         ["light gray"           (211 211 211)]
242 |         ["lightgray"            (211 211 211)]
243 |         ["silver"               (192 192 192)]
244 |         ["gray"                 (190 190 190)]
245 |         ["dark gray"            (169 169 169)]
246 |         ["darkgray"             (169 169 169)]
247 |         ["dim gray"             (105 105 105)]
248 |         ["dimgray"              (105 105 105)]
249 |         ["black"                (  0   0   0)]))
250 |     (for ([x (in-list colors)])
251 |       (define name (first x))
252 |       (define rgb  (second x))
253 |       (define-values (r g b) (values (first rgb) (second rgb) (third rgb)))
254 |       (hash-set! *color-table* (string->symbol (first x)) (color r g b)))
255 |     (λ (color-string)
256 |       (hash-ref *color-table* (string->symbol (string-downcase color-string))))))
257 | 


--------------------------------------------------------------------------------
/compiler-rjs/htdp/ffi.rkt:
--------------------------------------------------------------------------------
  1 | ; Uncommment to test in Racket
  2 | #lang racket/base
  3 | (require (for-syntax racket/base))
  4 | 
  5 | (begin
  6 |   (define assoc->object values)
  7 |   (define (js-ref  . xs) (cons 'js-ref  xs))
  8 |   (define (js-set! . xs) (cons 'js-set! xs))
  9 |   (define (js-call . xs) (cons 'js-call xs))
 10 |   (define (js-undefined) 'undefined))
 11 | 
 12 | ;;; Types
 13 | (struct ffi-type (name check ex im))
 14 | 
 15 | ;;; Real
 16 | (define (check-real x)  (number? x))
 17 | (define (export-real x) x)
 18 | (define (import-real x) x)
 19 | (define Real (ffi-type "Real" check-real export-real import-real))
 20 | ;;; Boolean
 21 | (define (check-boolean x) #t)
 22 | (define (boolify x) (if x #t #f))
 23 | (define Boolean (ffi-type "Boolean" check-boolean boolify boolify))
 24 | ;;; String (accepts symbols too, but returns strings
 25 | (define (check-string x)      (or (string? x) (symbol? x)))
 26 | (define (export-string x) (if (string? x) (string->immutable-string x) (symbol->string x)))
 27 | (define (import-string x) x)
 28 | (define String (ffi-type "String" check-string export-string import-string))
 29 | ;;; Number01 (a number between 0 and 1)
 30 | (define (check-number01 x)  (and (number? x) (<= 0 x) (<= x 1)))
 31 | (define (export-number01 x) x)
 32 | (define (import-number01 x) x)
 33 | (define Number01 (ffi-type "Number01" check-number01 export-number01 import-number01))
 34 | ;;; Dict (an object with properties used as key-value pairs)
 35 | (define (export-dict x) (if (list? x) (assoc->object x) x))
 36 | (define (import-dict x) (error 'import-dict "TODO") x)
 37 | (define Dict (ffi-type "Dict" list? export-dict import-dict))
 38 | ;;; Void
 39 | (define (always-true x) #t)
 40 | (define Void           (ffi-type "Void"           always-true void void))
 41 | ;;; Do Nothing 
 42 | (define Any            (ffi-type "Any"            always-true #f #f))
 43 | (define CanvasPattern  (ffi-type "CanvasPattern"  always-true #f #f))
 44 | (define CanvasGradient (ffi-type "CanvasGradient" always-true #f #f))
 45 | (define LineDashArray  (ffi-type "LineDashArray"  always-true #f #f))
 46 | (define TextMetrics    (ffi-type "TextMetrics"    always-true #f #f))
 47 | (define Path2D         (ffi-type "Path2D"         always-true #f #f))
 48 | (define ImageData      (ffi-type "ImageData"      always-true #f #f))
 49 | (define Element        (ffi-type "Element"        always-true #f #f))
 50 | (define Segments       (ffi-type "Segments"       always-true #f #f))
 51 | (define Image          (ffi-type "Image"          always-true #f #f))
 52 | ; An Image can be one of these:
 53 | ;   HTMLImageElement (<img>),
 54 | ;   HTMLVideoElement (<video>),
 55 | ;   HTMLCanvasElement (<canvas>),
 56 | ;   CanvasRenderingContext2D,
 57 | ;   ImageBitmap,
 58 | ;   ImageData, or a
 59 | ;   Blob.
 60 | 
 61 | (require (for-syntax syntax/parse) syntax/parse)
 62 | 
 63 | (begin-for-syntax
 64 |   (define-syntax-class Argument ; argument in a method
 65 |     (pattern name:id                 #:attr type #f)
 66 |     (pattern [name:id ffi-type-name] #:attr type #'ffi-type-name)))
 67 | 
 68 | (define-syntax (define-interface stx)
 69 |   (syntax-parse stx
 70 |     [(_define-interface interface-name
 71 |       #:inherits   (super ...)
 72 |       #:properties [rkt-prop-name js-prop-name] ...
 73 |       #:methods    [rkt-method-name
 74 |                     (js-method-name ma:Argument ... (~optional (~seq #:optional optma:Argument ...)
 75 |                                                                #:defaults ([(optma.name 1) null])))
 76 |                     return-type] ...)
 77 |      (define (add-! id)
 78 |        (datum->syntax id (string->symbol (string-append (symbol->string (syntax-e id)) "!"))))
 79 |      (with-syntax
 80 |          ([(rkt-prop-name! ...)     (map add-!          (syntax->list  #'(rkt-prop-name ...)))]
 81 |           [(js-prop-name-str ...)   (map symbol->string (syntax->datum #'(rkt-prop-name ...)))]
 82 |           [(js-method-name-str ...) (map symbol->string (syntax->datum #'(rkt-method-name ...)))]
 83 |           [((arg    ...) ...)       (attribute    ma.name)]
 84 |           [((type ...) ...)         (attribute ma.type)]
 85 |           [((optarg ...) ...)       (attribute optma.name)]
 86 |           [((opttype ...) ...)      (map (λ(x) (if (not x) '() x)) (attribute optma.type))])
 87 |          (syntax/loc stx
 88 |            (begin
 89 |              (define undef (js-undefined))
 90 |              ;; Properties
 91 |              (define (rkt-prop-name   obj)
 92 |                (js-ref  obj js-prop-name-str))
 93 |              ...
 94 |              (define (rkt-prop-name!  obj val)
 95 |                (js-set! obj js-prop-name-str val))
 96 |              ...
 97 |              (define (rkt-method-name obj arg ... [optarg undef] ...)
 98 |                (define who 'rkt-method-name)
 99 |                (let ([arg (if type
100 |                               (if ((ffi-type-check type) arg)
101 |                                   (let ([ex (ffi-type-ex type)])
102 |                                     (if ex (ex arg) arg))
103 |                                   (error who "expected ~a for the ~a argument, got: ~a"
104 |                                          (ffi-type-name type) 'arg arg))
105 |                               arg)]
106 |                      ...)
107 |                  (let ([optarg (if (not (eq? optarg undef))
108 |                                    (if opttype
109 |                                        (if ((ffi-type-check opttype) optarg)
110 |                                            (let ([ex (ffi-type-ex opttype)])
111 |                                              (if ex (ex optarg) optarg))
112 |                                            (error who
113 |                                                  "expected ~a for the ~a (optional) argument, got: ~a"
114 |                                                  (ffi-type-name opttype) 'optarg optarg))
115 |                                        optarg)
116 |                                    undef)]
117 |                        ...)
118 |                    (let ([im  (ffi-type-ex return-type)]
119 |                          [val (js-call obj js-method-name-str arg ... optarg ...)])
120 |                      (if im (im val) val)))))
121 |                ...)))]))
122 | 
123 | ;;; HTMLCanvasElement
124 | (define-interface HTMLCanvasElement
125 |   #:inherits   (HTMLElement)
126 |   #:properties
127 |   [canvas-height height]
128 |   [canvas-width  width]
129 |   #:methods    
130 |   [get-context  (getContext [contextType String] [contextAttributes Dict])                   Any]
131 |   [to-blob      (toBlob  callback #:optional [mimeType String] [qualityArguments Number01])  Any]
132 |   [to-data-url  (toDataUrl        #:optional [type     String] [encoderOptions   Number01])  Any])
133 | 
134 | (define-interface CanvasRenderingContext2D
135 |   #:inherits   ()
136 |   #:properties
137 |   [context-canvas                     canvas]
138 |   [context-fill-style                 fillStyle]
139 |   [context-font                       font]
140 |   [context-global-alpha               globalAlpha]
141 |   [context-global-composite-operation globalCompositeOperation]
142 |   [context-line-cap                   lineCap]
143 |   [context-line-dash-offset           lineDashOffset]
144 |   [context-line-join                  lineJoin]
145 |   [context-line-width                 lineWidth]
146 |   [context-miter-limit                miterLimit]
147 |   [context-shadow-blur                shadowBlur]
148 |   [context-shadow-color               shadowColor]
149 |   [context-shadow-offset-x            shadowOffsetX]
150 |   [context-shadow-offset-y            shadowOffsetY]
151 |   [context-stroke-style               strokeStyle]
152 |   [context-text-align                 textAlign]
153 |   [context-text-baseline              textBaseline]
154 |   #:methods    
155 |   [arc  (arc [x Real] [y Real] [radius Real] [startAngle Real] [endAngle Real]
156 |              #:optional [anticlockwise Boolean])
157 |         Void]
158 |   [arc-to            (arc-to [x1 Real] [y1 Real] [x2 Real] [y2 Real] [radius Real])              Void]
159 |   [begin-path        (begin-path)                                                                Void]
160 |   [bezier-curve-to   (bezier-curve-to [cp1x Real] [cp1y Real]
161 |                                       [cp2x Real] [cp2y Real] [x Real] [ey Real])                Void]
162 |   [clear-rect             (clearRect [x Real] [y Real] [width Real] [height Real])               Void]
163 |   [clip                   (clip)                                                                 Void]
164 |   [clip/rule              (clip               [fillRule String])                                 Void]
165 |   [clip/path/rule         (clip [path Path2D] [fillRule String])                                 Void]
166 |   [close-path             (closePath)                                                            Void]
167 |   [create-image-data      (createImageData [width Real] [height Real])                      ImageData]
168 |   [create-image-data/img  (createImageData [imagedata ImageData])                           ImageData]
169 |   [create-linear-gradient (createLinearGradient [x0 Real] [y0 Real] [x1 Real] [y1 Real])         Void]
170 |   [create-pattern         (create-pattern [image Image] [repetition String])            CanvasPattern]
171 |   [create-radial-gradient (createRadialGradient [x0 Real] [y0 Real] [r0 Real]
172 |                                                 [x1 Real] [y1 Real] [r1 Real])         CanvasGradient]
173 |   [draw-focus-if-needed   (drawFocusIfNeeded               [element Element])                    Void]
174 |   [draw-focus-if-needed/path (drawFocusIfNeeded [path Path2D] [element Element])                 Void]
175 |   [draw-image             (drawImage [image Image] [dx Real] [dy Real])                          Void]
176 |   [draw-image/size        (drawImage [image Image] [dx Real] [dy Real]
177 |                                      [dWidth Real] [dHeight Real])                               Void]
178 |   [draw-image/sub         (drawImage [image Image] [sx Real] [sy Real]
179 |                                      [sWidth Real] [sHeight Real]
180 |                                      [dx Real] [dy Real] [dWidth Real] [dHeight Real])           Void]
181 |   [fill                   (fill)                                                                 Void]
182 |   [fill/rule              (fill               [fillRule String])                                 Void]
183 |   [fill/path/rule         (fill [path Path2D] [fillRule String])                                 Void]
184 |   [fill-rect              (fillRect [x Real] [y Real] [width Real] [height Real])                Void]
185 |   [fill-text              (fillText [text String] [x Real] [y Real] #:optional [maxWidth Real])  Void]
186 |   [get-image-data         (getImageData [sx Real] [sy Real] [sw Real] [sh Real])            ImageData]
187 |   [get-line-dash          (getLineDash) LineDashArray]
188 |   [is-point-in-path       (isPointInPath [x Real] [y Real] #:optional [fillRule String])      Boolean]
189 |   [is-point-in-path/path  (isPointInPath [path Path2D]     #:optional [fillRule String])      Boolean]
190 |   [is-point-in-stroke     (isPointInStroke [x Real] [y Real])                                 Boolean]
191 |   [is-point-in-stroke/path(isPointInStroke [path Path2D])                                     Boolean]
192 |   [line-to                (lineTo [x Real] [y Real])                                             Void]
193 |   [measure-text           (measureText [text String])                                     TextMetrics]
194 |   [move-to                (moveTo [x Real] [y Real])                                             Void]
195 |   [put-image-data         (putImageData [imagedata ImageData] [dx Real] [dy Real])               Void]
196 |   [put-image-data/dirty   (putImageData [imagedata ImageData] [dx Real] [dy Real]
197 |                                         [dirtyX Real] [dirtyY Real]
198 |                                         [dirtyWidth Real] [dirtyHeight Real])                    Void]
199 |   [quadratic-curve-to     (quadraticCurveTo [cpx Real] [cpy Real] [x Real] [y Real])             Void]
200 |   [rect                   (rect [x Real] [y Real] [width Real] [height Real])                    Void]
201 |   [restore                (restore)                                                              Void]
202 |   [rotate                 (rotate [angle Real])                                                  Void]
203 |   [save                   (save)                                                                 Void]
204 |   [scale                  (scale [x Real] [y Real])                                              Void]
205 |   [set-line-dash          (setLineDash [segments Segments])                                      Void]
206 |   [set-transform          (setTransform [a Real] [b Real] [c Real] [d Real] [e Real] [f Real])   Void]
207 |   [stroke                 (stroke #:optional [path Path2D])                                      Void]
208 |   [stroke-rect            (strokeRect [x Real] [y Real] [width Real] [height Real])              Void]
209 |   [stroke-text            (strokeText [text String] [x Real] [y Real]#:optional [maxWidth Real]) Void]
210 |   [transform              (transform [a Real] [b Real] [c Real] [d Real] [e Real] [f Real])      Void]
211 |   [translate              (translate [x Real] [y Real])                                         Void])
212 | 


--------------------------------------------------------------------------------
/compiler-rjs/info.rkt:
--------------------------------------------------------------------------------
 1 | #lang info
 2 | ;;; This file describes the contents of the Urlang package.
 3 | ;;; The information is used by the Racket package system.
 4 | 
 5 | ;;; The Urlang package contains multiple collections (urlang, urlang-doc, compiler etc)
 6 | (define collection "compiler-rjs")
 7 | 
 8 | ;;; Version number
 9 | (define version    "1.0")
10 | 
11 | ;;; Dependencies declared here will need source
12 | (define deps       '())
13 | 
14 | ;;; Dependencies here can be installed as binaries (i.e. zo-files)
15 | (define build-deps '("base"
16 |                      "nanopass"                     
17 |                      "at-exp-lib"
18 |                      "rackunit-lib"
19 |                      "scribble-lib"
20 |                      "racket-doc"))
21 | 
22 | (define compile-omit-paths '())
23 | 
24 | 


--------------------------------------------------------------------------------
/compiler-rjs/runtime.exports:
--------------------------------------------------------------------------------
1 | (PRIM/ make-string cos syntax? struct-type-descriptor-total-field-count make-bytes1 exn:break pseudo-random-generator-vector? extend-parameterization make-syntax-object car IMMUTABLE-BOX number? make-parameter raise exn:fail:contract:variable-message IMMUTABLE-VECTOR infinite? kernel:exn:break kernel:exn:fail:filesystem:missing-module foldr gcd symbol? PRIM_not vector->immutable-vector CHAR unsafe-fx< random-seed CURRENT-NAMESPACE make-struct-type-property raise-clos-arity-error* hash-ref make-pseudo-random-generator exn:fail:syntax:unbound unsafe-struct-set!* rkt box struct-type-descriptor-properties integer->char char? build-list floor ceiling string-set! string->list exn:fail:network:errno-errno exn:fail:filesystem:version? abs exn:fail:filesystem:missing-module-message js-do-send CMS js-set! exn:fail:syntax:missing-module-message exn:break-message exn:break-continuation kernel:exn:fail:contract:variable struct-type-descriptor-guard exn:fail:filesystem:errno-continuation-marks PRIM< string-append real->single-flonum uncaught-exception-handler string-downcase exn:break:hang-up-message raise-argument-error gensym-counter srcloc->string break-enabled-key exn:fail:contract-message STRUCT-TYPE-DESCRIPTOR new-continuation-mark-frame exn:fail:filesystem:exists? exn:fail:contract:divide-by-zero? js-window exn:fail:out-of-memory number->string odd? port-next-location vector->list SYMBOL call-with-values substring2 port-count-lines! PARAMETER error last-pair string->symbol VECTOR kernel:exn:fail:contract:continuation mutable-string? arity=? struct-type-property-accessor-procedure? PRIM> syntax-srclocs void? sixth unsafe-fx+ exn:fail:contract:variable? Void exn:fail:unsupported-message kernel:exn:break:hang-up unsafe-vector*-set! integer-sqrt exn:fail:filesystem:version inexact? exn:fail:syntax:missing-module-path exn:fail:network exn:fail:user-continuation-marks max zero? foldl fixnum? exn:fail:syntax:missing-module-exprs andmap exn:fail:filesystem:missing-module-continuation-marks string->keyword exn:fail:read:eof? rest STRING-PORT kernel:exn:fail:filesystem integer-sqrt/remainder symbol->string exn:fail:filesystem-continuation-marks kernel:exn:fail:contract:arity exn:fail:unsupported kernel:exn:fail:filesystem:exists pi list-ref raise-arity-error exn:break:terminate-message set-box! sin exn:fail:syntax:unbound-exprs exn:fail-continuation-marks exn:fail:filesystem:exists-continuation-marks vector exn:fail:user-message symbol-interned? NULL write unsafe-vector*-length gcd2 vector-copy! substring3 $/ filter make-struct-type js-import exn:fail:contract:arity-continuation-marks string->uninterned-symbol kernel:exn:fail:unsupported bytes-ref cons? exn:fail:contract-continuation-marks exn:fail:syntax-message str continuation-mark-set? continuation-mark-set->list namespace? kernel:exn:fail:network PRIM= PRIM- sqrt ninth newline exn:fail:filesystem:missing-module-path struct-type-descriptor-auto-field-values nan? values even? vector->pseudo-random-generator! inexact->exact kernel:exn:fail:filesystem:version list? append2 symbol->immutable-string immutable-box? exn:fail:user? struct-type-descriptor-inspector kernel:srcloc remove-continuation-mark-frame magnitude string-port? struct:keyword-procedure/arity-error box? exn:fail:filesystem-message image-part exact-integer? build-vector parameterization? exn:fail:read? for-each kernel:exn:fail:syntax current-parameterization PARAMETERIZATION keyword->string fourth unsafe-struct-ref* make-list string? sub1 exn:fail:contract? mutable-bytes? pseudo-random-generator->vector exn:fail:syntax:unbound-continuation-marks kernel:exn:fail:contract:non-fixnum-result seventh exn:fail:out-of-memory-message str-struct-type-descriptor array-end->list exn:fail:contract:variable exact-positive-integer? exact? rest-args->list list->vector eq? exn:fail:filesystem:missing-module modulo normalize-arity keyword=? make-string2 BOX immutable-vector? exn:fail:unsupported? exn:fail:read-message call-handled-body-label set-continuation-mark exn:fail-message immutable-string->string make-bytes2 raise-application-error object-name vector-ref namespace-undefine-variable! exn:fail:syntax:missing-module? exn:fail:filesystem? complex? exn:fail:syntax bytes-set! vector-fill! expt kernel:exn:fail:contract:divide-by-zero gensym PRIM>= eof select-handler/no-breaks pseudo-random-generator? subbytes exn:fail:contract:non-fixnum-result? unsafe-car eighth exn:fail:out-of-memory-continuation-marks single-flonum? empty exn:break:hang-up? exn:fail remainder make-base-namespace exn:fail:read:eof-continuation-marks exn:fail:network? exact-nonnegative-integer? string-append2 exn:fail:network:errno-continuation-marks make-empty-namespace Null unsafe-fx- exception-handler-key struct-type-property? kernel:exn:fail:out-of-memory struct-type-descriptor-immutables exn:fail:contract:variable-id bytes-copy exn:fail:user symbol=? raise-syntax-error exn-continuation-marks namespace-module-registry NAMESPACE vector-set! syntax-e new-apply-proc exn:fail:network:errno namespace-variable-value vector-immutable PRIM+ make-char exn:break:hang-up exn:fail:syntax-continuation-marks null? flonum? apply STRUCT exn:fail:contract KEYWORD unsafe-cdr parameter? exn:fail:filesystem:errno-message exn:fail:contract:arity string-upcase real->double-flonum exn:fail:filesystem:version-continuation-marks exn:break:terminate-continuation string>=? unsafe-vector-length closure? hash-set! exn-message $+ $- char=? exn:fail:filesystem:errno in-range vector->pseudo-random-generator struct-type-descriptor-super struct-type-descriptor-auto-field-indices keyword<? subbytes3 eof-object? struct? struct-type-descriptor-init-field-indices exn:fail:filesystem:missing-module? kernel:exn:break:terminate exn:fail:contract:arity-message acos integer? eqv? string<=? real? make-struct-type-descriptor arity-at-least-value asin vector-length make-primitive-string string->immutable-string exn:fail? exn:fail:contract:divide-by-zero-message str-struct bytes current-namespace substring exn:fail:filesystem:exists-message exn:fail:contract:arity? exn:fail:contract:non-fixnum-result-message first cdr exn bytes->Int8Array call-handled-body assoc->object MUTABLE-BYTES normalized-arity? kernel:exn:fail:syntax:unbound exn:fail:syntax:unbound? make-string1 immutable-bytes? exn:fail:read:eof-srclocs unbox js-call VOID make-hasheq namespace-mapped-symbols immutable-string? exn:fail:read:non-char-continuation-marks values? STRUCT-TYPE-PROPERTY-DESCRIPTOR exn:fail:read:non-char? exn:fail:out-of-memory? exn:fail:contract:continuation-continuation-marks positive? $* keyword? exn:fail:contract:divide-by-zero-continuation-marks list* exn:fail:syntax-exprs add1 fifth check-struct-type PAIR equal? cdar HASHEQ js-ref exn:break:terminate third select-handler/breaks-as-is exn:fail:network:errno? log make-struct-field-accessor namespace-base-phase pair? atan unsafe-struct-ref tenth raise-arity-error* list-tail angle current-inspector caar quotient/remainder unsafe-struct-set! arity-at-least? byte? exn:fail:read:non-char-srclocs reverse alt-reverse SYNTAX-OBJECT in-list exact->inexact boolean? bytes? js-date dispatch-case-lambda box-immutable exn:fail:read:non-char unsafe-fx> exn:break:hang-up-continuation VALUES current-pseudo-random-generator exn:fail:network-continuation-marks current-continuation-marks round negative? struct-type? rational? kernel:exn:fail:user exn:break? truncate EOF-OBJECT continuation-mark-set-first BYTES displayln string>? cadr exn:fail:read:eof PRIM<= string=? js-export js-import-from random arity-at-least CONTINUATION-MARK-SET bytes-length string<? array->list bytes=? inexact-real? match:error exn:fail:syntax? exn:fail:contract:continuation-message exn:break:terminate-continuation-marks kernel:exn:fail:syntax:missing-module kernel:exn:fail:read:non-char tan kernel:exn:fail:network:errno string-length exn:fail:syntax:missing-module box-cas! exn:fail:filesystem:errno? cons exn:fail:read-continuation-marks parameterization-key unsafe-vector-ref string->number exn:fail:filesystem:version-message namespace-set-variable-value! error-display-handler kernel:exn:fail:contract length unsafe-fx* quotient exn:break:terminate? exn:fail:read:non-char-message exn:fail:contract:variable-continuation-marks map console-log exn:fail:filesystem:exists bytes->immutable-bytes exn:fail:contract:divide-by-zero exn:break-continuation-marks make-vector exn:fail:filesystem make-arity-at-least min identifier? exn:fail:filesystem:errno-errno kernel:exn:fail:read exn:fail:read:eof-message list struct-type-descriptor-name ormap append string srcloc prop:named-keyword-procedure exn:fail:read display unsafe-vector*-ref list->array cddr js-document exp immutable? PRIM* exn:fail:syntax:missing-module-continuation-marks array? empty? exn:fail:syntax:unbound-message subbytes2 kernel:exn:fail exn:fail:network:errno-message exn:fail:contract:non-fixnum-result-continuation-marks kernel:exn exn:fail:network-message MUTABLE-STRING exn? make-bytes exn:fail:contract:continuation CLOS exn:break:hang-up-continuation-marks double-flonum? tag struct-type-descriptor-constructor-name exn:fail:contract:continuation? real-part kernel:exn:fail:read:eof procedure? second kernel:exn:fail:filesystem:errno char->integer immutable-bytes->bytes last string-ref vector? exn:fail:contract:non-fixnum-result unsafe-vector-set! symbol<? exn:fail:unsupported-continuation-marks mutable-vector? exn:fail:read-srclocs)
2 | 


--------------------------------------------------------------------------------
/compiler-test/letrec.tests:
--------------------------------------------------------------------------------
 1 | (test 4 'const (letrec ([x 5]) 5))
 2 | (test 5 'var-ref (letrec ([x 5]) x))
 3 | 
 4 | (test #t 'lambda (procedure? (letrec ([x (lambda () 5)]) x)))
 5 | (test #t 'lambda-rest-args (procedure? (letrec ([x (lambda l l)]) x)))
 6 | (test 5 'lambda-called (letrec ([x (lambda () 5)]) (x)))
 7 | (test (list 5) 'lambda-rest-args-called (letrec ([x (lambda l l)] [y (x 5)]) y))
 8 | 
 9 | 
10 | (test #t 'begin
11 |       (procedure?
12 |        (letrec ([x (begin (lambda () y)
13 |                           (lambda () z))]
14 |                 [y 5]
15 |                 [z 6])
16 |          x)))
17 | 
18 | 
19 | (test 5 'nested (letrec ([x (letrec ([y 6]) 5)]) x))
20 | (test 5 'nested-more (letrec ([x (letrec ([y 5]) y)]) x))
21 | (test 5 'nested-even-more (letrec ([x 5] [y (letrec ([z x]) z)]) y))
22 | 
23 | (test 5 'reordered (letrec ([s 5] [q (lambda () s)] [r (q)]) r))
24 | 
25 | (test 5 'set! (letrec ([x 0]
26 |                        [f (lambda (v) (set! x v))])
27 |                 (begin (f 5) x)))
28 | 
29 | 
30 | 
31 | (test #t 'checked-but-ok
32 |       (procedure?
33 |        (letrec ([y (lambda () (letrec ([x x]) x))])
34 |          y)))
35 | 
36 | 
37 | 
38 | (test #t 'checked-but-ok
39 |       (procedure?
40 |        (let ([proc (letrec ([x (letrec ([v (lambda () x)]) v)]) x)])
41 |          (proc))))
42 | 
43 | 
44 | 
45 | 
46 | (test '(1)
47 |       'complex-forcing-path
48 |       (let-values (((_tri)
49 |                     (letrec-values (((all-types) 1))
50 |                       (lambda (x) all-types))))
51 |         (letrec-values (((quad-super-type) _tri)
52 |                         ((offsets) (map quad-super-type (list 1))))
53 |           offsets)))
54 | 


--------------------------------------------------------------------------------
/compiler-test/numbers.tests:
--------------------------------------------------------------------------------
 1 | ;;;
 2 | ;;; NUMBERS
 3 | ;;;
 4 | 
 5 | ;; Note: Until the number tower is supported, fixnums and flonums are the same.
 6 | ;;       In most tests we use flonums to force Racket to produce flonums.
 7 | 
 8 | 1
 9 | 1.5
10 | (number? 0)
11 | (number? #t)
12 | (fixnum? 5)
13 | (fixnum? 5.4)
14 | (integer? 6)
15 | (integer? 6.4)
16 | (flonum? 7.4)
17 | (zero? 0)
18 | (zero? 2)
19 | (positive?  2)
20 | (positive? -2)
21 | (negative?  2)
22 | (negative? -2)
23 | (even? 4)
24 | (even? 0)
25 | (even? -2)
26 | (even? -3)
27 | (even? -1)
28 | (odd? 3)
29 | (odd? 5)
30 | (odd? -4)
31 | (odd? -2)
32 | (odd? 0)
33 | (exact? 5)
34 | (+)
35 | (+ 1)
36 | (+ 1 2)
37 | (+ 1 2 3)
38 | (+ 1 2 3 4)
39 | ; (-) should throw exception
40 | (- 1.)
41 | (- 1. 2)
42 | (- 1. 2 3)
43 | (- 1. 2 3 4)
44 | (*)
45 | (* 1.)
46 | (* 1. 2)
47 | (* 1. 2 3)
48 | (* 1. 2 3 4)
49 | (/ 2.)
50 | (/ 2. 3)
51 | (/ 2. 3 4)
52 | (/ 2. 3 4 5)
53 | 
54 | 
55 | 
56 | 
57 | 
58 | 
59 | 
60 | ;;;
61 | ;;; TODO
62 | ;;
63 | 
64 | ; 2/3


--------------------------------------------------------------------------------
/compiler-test/test-suite-compiler.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | (require (prefix-in compiler: (only-in compiler-rjs/compiler eval)))
 3 | 
 4 | (define (read+eval-expression line)
 5 |   (with-input-from-string
 6 |       (with-output-to-string
 7 |           (λ () (compiler:eval
 8 |                  (datum->syntax #'here
 9 |                                 `(displayln ,(syntax->datum line))))))
10 |     read))
11 | 
12 | 
13 | ;;;
14 | ;;; "tests-compiler/numbers.rkt"
15 | ;;;
16 | 
17 | ;; Each line contains one expression.
18 | ;; Check that the compiler and racket get the same result.
19 | 
20 | (define (test-numbers)
21 |   (define src "tests-compiler/numbers.tests")
22 |   (with-input-from-file src
23 |     (λ ()
24 |       (parameterize ([current-namespace (make-base-namespace)])
25 |         (for/list ([line (in-port (λ (port) (read-syntax src port)))] [i (in-naturals)])
26 |           (display (~a i " "))
27 |           (displayln line)
28 |           (define actual   (read+eval-expression line))
29 |           (define expected (eval line))
30 |           (list actual expected (equal? actual expected)))))))
31 | 
32 | ;;;
33 | ;;; "tests-compiler/letrec.rkt"
34 | ;;;
35 | 
36 | ;; Each expression is of the form (test expected test-name expression)
37 | 
38 | 
39 | (define (test-letrec)
40 |   (define src "tests-compiler/letrec.tests")
41 |   (define (test? stx) (and (syntax? stx) (eq? 'test (syntax-e stx))))
42 |   (define all
43 |     (with-input-from-file src
44 |       (λ ()
45 |         (parameterize ([current-namespace (make-base-namespace)])
46 |           (for/list ([line (in-port (λ (port) (read-syntax src port)))] [i (in-naturals)])
47 |             (match (syntax->list line)
48 |               [(list (? test?) expected name expression)
49 |                (display (~a i " "))
50 |                (displayln (syntax->datum expression))
51 |                (define actual   (read+eval-expression expression))
52 |                (define expected (eval expression))
53 |                (define results (list actual expected (equal? actual expected)))
54 |                (unless (equal? actual expected)
55 |                  (displayln "Problem:")
56 |                  (displayln results))
57 |                results]))))))
58 |   (define problems (filter (compose not third) all))
59 |   (unless (empty? problems) (displayln "Problems:") (displayln problems))    
60 |   all)
61 | 
62 | 
63 | ;(test-numbers)
64 | (test-letrec)
65 | 


--------------------------------------------------------------------------------
/info.rkt:
--------------------------------------------------------------------------------
 1 | #lang info
 2 | ;;; This file describes the contents of the Urlang package.
 3 | ;;; The information is used by the Racket package system.
 4 | 
 5 | ;;; The Urlang package contains multiple collections (urlang, urlang-doc, compiler etc)
 6 | (define collection 'multi)
 7 | 
 8 | ;;; Version number
 9 | (define version    "1.0")
10 | 
11 | (define deps       '("base"
12 |                      "html-parsing"
13 |                      "html-writing"
14 |                      "nanopass"
15 |                      "net-lib"
16 |                      "rackunit-lib"
17 |                      "scribble-html-lib"
18 |                      "scribble-text-lib"
19 |                      "srfi-lite-lib"
20 |                      "web-server-lib"))
21 | 
22 | (define build-deps '("base"
23 |                      "nanopass"                     
24 |                      "at-exp-lib"
25 |                      "rackunit-lib"
26 |                      "scribble-lib"
27 |                      "racket-doc"
28 |                      "html-writing"
29 |                      "html-parsing"))
30 | 
31 | (define compile-omit-paths (list "compiler-test"
32 |                                  ; ad hoc files
33 |                                  "urlang/html/tag-comparison.rkt"
34 |                                  "urlang/tmp/"
35 |                                  "urlang/urlang/tmp/"))
36 | 
37 | (define test-omit-paths (list
38 |                          "compiler-rjs"
39 |                          "compiler-test"
40 |                          "urlang-examples"
41 |                          "urlang-test"
42 |                          "urlang"
43 |                          "README.md"
44 |                          ; these are not commited to Github:
45 |                          "old"
46 |                          "untracked-experiments"
47 |                          "urlang-compiler-examples"))
48 | 
49 | 


--------------------------------------------------------------------------------
/urlang-examples/README.md:
--------------------------------------------------------------------------------
 1 | Urlang Examples
 2 | ===============
 3 | 
 4 | This collection contains a few examples of how to use Urlang.
 5 | 
 6 | "demo-fact.rkt"
 7 | ---------------
 8 |     - Produces a node program. Use node to run it.
 9 |     - It computes factorial 5 and prints it to standard out
10 | 
11 | raphael/browser.rkt
12 | -------------------
13 |     - Demonstrations how to use the graphics library Raphael
14 |     - Runs in a browser
15 |     - Demonstrates how to dynamically add nodes to the DOM of the browser   
16 | 
17 | Other examples
18 | ==============
19 | 
20 | The runtime library for a Racket to JavaScript implemented
21 | entirely in Urlang is available in  compiler-rjs/runtime.rkt
22 | 
23 | 
24 | /soegaard
25 | 
26 | 
27 | 
28 |    


--------------------------------------------------------------------------------
/urlang-examples/demo-fact.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | (require urlang)
 3 | 
 4 | (urlang
 5 |  (urmodule demo-fact                                           ; module name
 6 |    (export fact)                                          ; fact is exported
 7 |    (define (fact n) (if (= n 0) 1 (* n (fact (- n 1)))))
 8 |    (console.log (fact 5))))
 9 | 
10 | ;;; Running the program will create a file "demo-fact.js" containing:
11 | 
12 | ;  "use strict";
13 | ;  function fact(n){return (((n===0)===false)?(n*(fact((n-1)))):1);};
14 | ;  (console.log((fact(5))));
15 | ;  exports.fact=fact;
16 | 
17 | 


--------------------------------------------------------------------------------
/urlang-examples/info.rkt:
--------------------------------------------------------------------------------
 1 | #lang info
 2 | ;;; This file describes the contents of the Urlang package.
 3 | ;;; The information is used by the Racket package system.
 4 | 
 5 | ;;; The Urlang package contains multiple collections (urlang, urlang-doc, compiler etc)
 6 | (define collection "urlang-examples")
 7 | 
 8 | ;;; Version number
 9 | (define version    "1.0")
10 | 
11 | ;;; Dependencies declared here will need source
12 | (define deps       '())
13 | 
14 | ;;; Dependencies here can be installed as binaries (i.e. zo-files)
15 | (define build-deps '("base"
16 |                      "html-writing"
17 |                      "at-exp-lib"
18 |                      "rackunit-lib"
19 |                      "scribble-lib"
20 |                      "racket-doc"))
21 | 
22 | (define compile-omit-paths '())
23 | 
24 | 


--------------------------------------------------------------------------------
/urlang-examples/parabola/parabola.rkt:
--------------------------------------------------------------------------------
  1 | #lang at-exp racket
  2 | 
  3 | ;;;
  4 | ;;; INTRODUCTION
  5 | ;;;
  6 | 
  7 | ;; This examples shows:
  8 | ;;     - how to construct html using Scribble syntax
  9 | ;;     - use the Bootstrap HTML/CSS framework
 10 | ;;     - use Urlang to handle events
 11 | 
 12 | ;;;
 13 | ;;; HTML
 14 | ;;;
 15 | 
 16 | ;; There a lot of options available for constructing html from Racket.
 17 | ;;   - plain strings can represent html
 18 | ;;   - x-expressions (an s-expression representation of html)
 19 | ;;   - templates from web-server/templates
 20 | ;;   - xml using the representation from scribble/html
 21 | 
 22 | ;; Here we will give an example of the last option.
 23 | ;; The scriblle/html collection offers a nice was of writing html
 24 | ;; using the @-syntax.
 25 | 
 26 | ;; Example:
 27 | ;;           > @h1[class: "red" id: "my-title"]{A Title}
 28 | ;;           (element 'h1 '((class . "red") (id . "my-title")) '("A Title") #f)
 29 | 
 30 | ;; Those familiar with Scribble will notice that class: and id: are unbound
 31 | ;; identifiers, and therefore ought to give errors. The scribble/html
 32 | ;; library fortunately offers a way to turn these class: and id:
 33 | ;; into 'class and 'id automatically.
 34 | 
 35 | 
 36 | ;;; Use Scribble syntax to construct xml trees
 37 | 
 38 | (require urlang/html)
 39 | 
 40 | ;;; Conveniency
 41 | 
 42 | ; In DrRacket (send-url/contents some-html) will display the 
 43 | ; html in a browser - saves time.
 44 | 
 45 | (require net/sendurl)
 46 | 
 47 | ;;;
 48 | ;;; Urlang Configuration
 49 | ;;;
 50 | 
 51 | (require urlang)
 52 | 
 53 | (current-urlang-run?                           #f) ; run using Node?              No, use browser
 54 | (current-urlang-echo?                          #t) ; print generated JavaScript?  
 55 | (current-urlang-console.log-module-level-expr? #f) ; print top-level expression?  
 56 | 
 57 | 
 58 | ;;; Urls for JavaScript and CSS libraries used in this example.
 59 | 
 60 | (define bootstrap-css "https://maxcdn.bootstrapcdn.com/bootstrap/3.3.6/css/bootstrap.min.css")
 61 | (define bootstrap-js  "https://maxcdn.bootstrapcdn.com/bootstrap/3.3.6/js/bootstrap.min.js")
 62 | (define jquery-js     "https://ajax.googleapis.com/ajax/libs/jquery/1.12.0/jquery.min.js")
 63 | (define html5shiv-js  "https://oss.maxcdn.com/html5shiv/3.7.2/html5shiv.min.js")
 64 | (define respond-js    "https://oss.maxcdn.com/respond/1.4.2/respond.min.js")
 65 | 
 66 | (define (script url)   @~a{<script src=@url ></script>})    
 67 | (define (link-css url) @~a{<link href=@url rel="stylesheet">})
 68 | 
 69 | (define (generate-html body urlang-js-file)
 70 |   ;; Given a body (a string) wrap it in a basic html template
 71 |   ;; from the Bootstrap project:
 72 |   ;;     http://getbootstrap.com/getting-started/#template
 73 |   @~a{
 74 | <!DOCTYPE html>
 75 | <html lang="en">
 76 |   <head>
 77 |     <meta charset="utf-8">
 78 |     <meta http-equiv="X-UA-Compatible" content="IE=edge">
 79 |     <meta name="viewport" content="width=device-width, initial-scale=1">
 80 |     <!-- The above 3 meta tags *must* come first in the head;
 81 |          any other head content must come *after* these tags -->
 82 |     <title>Bootstrap 101 Template</title>
 83 | 
 84 |     <!-- Bootstrap -->
 85 |     @link-css[bootstrap-css]
 86 | 
 87 |     <!-- HTML5 shim and Respond.js for IE8 support of HTML5 elements and media queries -->
 88 |     <!-- WARNING: Respond.js doesn't work if you view the page via file:// -->
 89 |     <!--[if lt IE 9]>
 90 |     @script[html5shiv-js]
 91 |     @script[respond-js]
 92 |     <![endif]-->
 93 |   </head>
 94 |   <body>
 95 |     @body
 96 |     <!-- jQuery (necessary for Bootstrap's JavaScript plugins) -->
 97 |     @script[jquery-js]
 98 |     <!-- Include all compiled plugins (below), or include individual files as needed -->
 99 |     @script[bootstrap-js]
100 |     <script>@file->string[urlang-js-file]</script>
101 |   </body>
102 | </html>})
103 | 
104 | 
105 | ;;; Bootstrap conainers, fluid containers, and, rows.
106 | 
107 | ; A container has a fixed width
108 | (define (container . contents)       @div[class: "container"]{@contents})
109 | ; A fluid container can span the entire width of your viewport
110 | (define (fluid-container . contents) @div[class: "container-fluid"]{@contents})
111 | ; A row must be place in a (possibly fluids) container
112 | (define (row . columns)              @container[@div[class: "row"]{@columns}])
113 | 
114 | ;;; The navigation bar
115 | 
116 | ; This navigation is from the Bootstrap jumbotron example
117 | ;     http://getbootstrap.com/examples/jumbotron/
118 | (define (navigation-bar)
119 |   (list
120 |    @comment{NAVIGATION BAR}
121 |    @nav[class: "navbar navbar-inverse navbar-fixed-top"]{
122 |     @fluid-container[
123 |       @div[class: "navbar-header"]{
124 |        @comment{Bootstrap supports only button elements in a navbar}
125 |        @button[type:          "button"
126 |                class:         "navbar-toggle collapsed"
127 |                data-toggle:   "collapse"
128 |                data-target:   "#navbar"
129 |                aria-expanded: "false"
130 |                aria-controls: "navbar"]{
131 |          @span[class: "sr-only"]{Toggle navigation}
132 |          @comment{The following three spans will produce an hamburger on narrow screens}
133 |          @span[class: "icon-bar"]{}
134 |          @span[class: "icon-bar"]{}
135 |          @span[class: "icon-bar"]{}}
136 |        @a[class: "navbar-brand" href: "#"]{Urlang}}
137 |       @div[id: "navbar" class: "navbar-collapse collapse"]{}]}))
138 | 
139 | (define (sample-heading msg)
140 |   ; Here the 4 means: use 4/12 of the screen width. Since 4/12=1/3 we get 3 columns.
141 |   @div[class: "col-md-4"]{
142 |     @h2{@msg}
143 |     @p{Donec id elit non mi porta gravida at eget metus.
144 |        Fusce dapibus, tellus ac cursus commodo, tortor mauris condimentum nibh,
145 |        ut fermentum massa justo sit amet risus.
146 |        Etiam porta sem malesuada magna mollis euismod. Donec sed odio dui.}
147 |     @p{@a[class: "btn btn-default" href: "#" role: "button"]{View details}}})
148 | 
149 | (define (jumbotron)
150 |   (list
151 |    @comment{JUMBOTRON}
152 |    @comment{Main jumbotron for a primary marketing message or call to action}
153 |    @div[class: "jumbotron"]{
154 |      @container[@h1{Urlang!}
155 |                 @p[class: "lead"]{Use Bootstrap with Urlang.}
156 |                 @p{This example shows how to use Bootstrap. The html is generated using the at-syntax.
157 |                    Urlang is used to handle events: compute solutions and draw the grah}
158 |                 @p{@a[class: "btn btn-primary btn-lg" href: "#" role: "button"]{Learn more}}]}))
159 | 
160 | (define (the-footer)
161 |   (list @comment{FOOTER}
162 |         @hr[]
163 |         @footer{@p{The Urlang Team}}))
164 | 
165 | (define (enter-coeffecients)
166 |   @div[class: "col-md-4"]{
167 |     @h2{Coefficients}
168 |     @p{Enter a, b, and, c below.}
169 |     @p{a: @input[id: "input_a" type: "text" value:  "1"] @br[]
170 |        b: @input[id: "input_b" type: "text" value: " 0"] @br[]
171 |        c: @input[id: "input_c" type: "text" value: "-4"]}
172 |     
173 |     @comment{@p{@a[class: "btn btn-default" onclick: "handle_update()"]{Solve}}}})
174 | 
175 | (define (quadratics-solver)
176 |   @div[class: "col-md-4"]{
177 |     @h2{Roots}
178 |     @p{Equation: ax^2 + bx+c = 0}
179 |     @p{@span[id: "solutions"]}})
180 | 
181 | (define (graph)
182 |   @div[class: "col-md-4"]{
183 |     @h2{Graph}
184 |     @canvas[id: "graph-canvas" width: 200 height: 200
185 |             style: "border:1px solid"]})
186 | 
187 | (define (row-of-small-headers)
188 |   (list
189 |    @comment{ROW OF COLUMNS}
190 |    @row[(enter-coeffecients)
191 |         (quadratics-solver)
192 |         (graph)]))
193 | 
194 | 
195 | ;;; Generate JavaScript
196 | 
197 | ;; The urlang will generate a JavaScript file.
198 | ;; The JavaScript will be activated in then the user
199 | ;; clicks the compute button.
200 | 
201 | (require urlang/extra ; make cond  available in urlang
202 |          urlang/for)  ; make "for" available in urlang
203 | 
204 | (urlang
205 |  (urmodule parabola
206 |    (import $ val)                ; from jquery
207 |    (import parseInt isNaN Math)  ; from javascript
208 | 
209 |    ; get jquery objects referring to the input fields
210 |    (var [ia ($ "#input_a")] [ib ($ "#input_b")] [ic ($ "#input_c")])
211 |    ; and the span used to display the solutions
212 |    (var [out ($ "#solutions")])
213 | 
214 |    ; make keyup events in the input fields update solutions and graph
215 |    (ia.keyup handle-update)
216 |    (ib.keyup handle-update)
217 |    (ic.keyup handle-update)
218 |    
219 |    (define (get i) ; i is a jquery object referring to input field
220 |      (var [x (parseInt (i.val) 10)])
221 |      (if (isNaN x) 0 x)) ; handle non-numbers in text field
222 |    
223 |    (define (handle-update)
224 |      ; Use the JavaScript console in your browser to see the messages
225 |      (console.log "on-compute-clicked was clicked")
226 |      ; get the numerical values
227 |      (var [a (get ia)] [b (get ib)] [c (get ic)])
228 |      (out.text (render (solutions a b c)))
229 |      ; Alternative: Use dot notation to avoid storing the dom element:
230 |      ; (this is less efficient though)
231 |      ; (dot ($ "#solutions") (text (render (solutions a b c))))
232 |      (graph (ref ($ "#graph-canvas") 0) a b c))
233 | 
234 |    (define (set-keyup-handlers i)
235 |      ; i is a jquery object referring to input field
236 |      (i.keyup handle-update))
237 |    
238 |    (define (solutions a b c)
239 |      (var [d (- (* b b) (* 4 a c))])
240 |      (cond
241 |        [(< d 0) (array)]
242 |        [(= d 0) (array (/ (- b) (* 4 a)))]
243 |        [#t      (array (/ (+ (- b) (- (Math.sqrt d))) (* 2 a))
244 |                        (/ (+ (- b)    (Math.sqrt d))  (* 2 a)))]))
245 |    (define (render xs)
246 |      (var [n xs.length])
247 |      (cond
248 |        [(= n 0) "No solutions"]
249 |        [(= n 1) (+ "One solution:  x = " (ref xs 0))]
250 |        [(= n 2) (+ "Two solutions: x = " (ref xs 0) "  or  x = " (ref xs 1))]))
251 | 
252 |    (define (graph canvas a b c)
253 |      ; canvas:   0<x<200 and   0<y<200
254 |      ; math:   -10<x< 10 and -10<y< 10
255 |      (var [f (λ (x) (+ (* a x x) (* b x) c))]
256 |           [m (λ (x) (/ (- x 100) 10))]  ; m = to math coordinate
257 |           [w (λ (x) (+ (* x 10) 100))]) ; w = to window coordinate
258 |      ; get the drawing context
259 |      (var [ctx (canvas.getContext "2d")])
260 |      ; add 0.5 to avoid blurry lines (sigh)
261 |      (var [line-to (λ (x y) (ctx.lineTo (+ x 0.5) (+ (- 200 y) 0.5)))]
262 |           [move-to (λ (x y) (ctx.moveTo (+ x 0.5) (+ (- 200 y) 0.5)))])
263 |      ; clear
264 |      (ctx.beginPath)
265 |      (ctx.moveTo 0 0)
266 |      (:= ctx "fillStyle"   "#FFFFFF") ; white
267 |      (:= ctx "strokeStyle" "#FFFFFF")
268 |      
269 |      (ctx.clearRect 0 0 200 200)
270 |      (ctx.stroke)
271 |      ; axes
272 |      (ctx.beginPath)
273 |      (:= ctx "fillStyle"   "#000000") ; black
274 |      (:= ctx "strokeStyle" "#000000")
275 |      (move-to   0 100) (line-to 200 100)
276 |      (move-to 100   0) (line-to 100 200)
277 |      (ctx.stroke)
278 |      ; graph
279 |      (ctx.beginPath)
280 |      (:= ctx "fillStyle"   "#FF0000") ; red
281 |      (:= ctx "strokeStyle" "#FF0000")
282 |      (move-to 0 (w (f (m 0))))
283 |      (for ([x in-range 0 200])
284 |        (line-to x (w (f (m x)))))
285 |      (ctx.stroke))
286 |    ; call update when the script loads to refresh graphs
287 |    (handle-update)))
288 | 
289 | ;;; Test it in the browser
290 | 
291 | (send-url/contents
292 |  (generate-html
293 |   @~xs{ @navigation-bar[]
294 |         @jumbotron[]
295 |         @comment{Use a container to make the footer and the row the same width}
296 |         @container[@row-of-small-headers[]
297 |                    @the-footer[]]}
298 |   "parabola.js"))
299 | 


--------------------------------------------------------------------------------
/urlang-examples/quiz/quiz.rkt:
--------------------------------------------------------------------------------
  1 | #lang at-exp racket
  2 | ;;;
  3 | ;;; Quiz
  4 | ;;;
  5 | 
  6 | ;;;
  7 | ;;; INTRODUCTION
  8 | ;;;
  9 | 
 10 | ;; This examples shows:
 11 | ;;     - how to construct html using Scribble syntax
 12 | ;;     - use the Bootstrap HTML/CSS framework
 13 | ;;     - use Urlang to handle events
 14 | 
 15 | ;;;
 16 | ;;; HTML
 17 | ;;;
 18 | 
 19 | ;; There a lot of options available for constructing html from Racket.
 20 | ;;   - plain strings can represent html
 21 | ;;   - x-expressions (an s-expression representation of html)
 22 | ;;   - templates from web-server/templates
 23 | ;;   - xml using the representation from scribble/html
 24 | 
 25 | ;; Here we will give an example of the last option.
 26 | ;; The scriblle/html collection offers a nice was of writing html
 27 | ;; using the @-syntax.
 28 | 
 29 | ;; Example:
 30 | ;;           > @h1[class: "red" id: "my-title"]{A Title}
 31 | ;;           (element 'h1 '((class . "red") (id . "my-title")) '("A Title") #f)
 32 | 
 33 | ;; Those familiar with Scribble will notice that class: and id: are unbound
 34 | ;; identifiers, and therefore ought to give errors. The scribble/html
 35 | ;; library fortunately offers a way to turn these class: and id:
 36 | ;; into 'class and 'id automatically.
 37 | 
 38 | 
 39 | ;;; Use Scribble syntax to construct xml trees
 40 | 
 41 | (require urlang/html)
 42 | 
 43 | ;;; Conveniency
 44 | 
 45 | ; In DrRacket (send-url/contents some-html) will display the 
 46 | ; html in a browser - saves time.
 47 | 
 48 | (require net/sendurl)
 49 | 
 50 | ;;;
 51 | ;;; Urlang Configuration
 52 | ;;;
 53 | 
 54 | (require urlang)
 55 | 
 56 | (current-urlang-run?                           #f) ; run using Node?              No, use browser
 57 | (current-urlang-echo?                          #t) ; print generated JavaScript?  
 58 | (current-urlang-console.log-module-level-expr? #f) ; print top-level expression?  
 59 | (current-urlang-beautify?                       #t) ; invoke js-beautify 
 60 | 
 61 | ;;; Urls for JavaScript and CSS libraries used in this example.
 62 | 
 63 | ;(define bootstrap-css "https://maxcdn.bootstrapcdn.com/bootstrap/3.3.6/css/bootstrap.min.css")
 64 | (define bootstrap-css
 65 |   "https://cdnjs.cloudflare.com/ajax/libs/bootswatch/3.3.6/cerulean/bootstrap.min.css")
 66 | (define bootstrap-js  "https://maxcdn.bootstrapcdn.com/bootstrap/3.3.6/js/bootstrap.min.js")
 67 | (define jquery-js     "https://ajax.googleapis.com/ajax/libs/jquery/1.12.0/jquery.min.js")
 68 | (define html5shiv-js  "https://oss.maxcdn.com/html5shiv/3.7.2/html5shiv.min.js")
 69 | (define respond-js    "https://oss.maxcdn.com/respond/1.4.2/respond.min.js")
 70 | (define mathjax-js   "https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML")
 71 | 
 72 | (define (script url)   @~a{<script src=@url ></script>})    
 73 | (define (link-css url) @~a{<link href=@url rel="stylesheet">})
 74 | 
 75 | (define (generate-html body urlang-js-file)
 76 |   ;; Given a body (a string) wrap it in a basic html template
 77 |   ;; from the Bootstrap project:
 78 |   ;;     http://getbootstrap.com/getting-started/#template
 79 |   @~a{
 80 | <!DOCTYPE html>
 81 | <html lang="en">
 82 |   <head>
 83 |     <meta charset="utf-8">
 84 |     <meta http-equiv="X-UA-Compatible" content="IE=edge">
 85 |     <meta name="viewport" content="width=device-width, initial-scale=1">
 86 |     <!-- The above 3 meta tags *must* come first in the head;
 87 |          any other head content must come *after* these tags -->
 88 |     <title>The Racket Quiz</title>
 89 | 
 90 |     <!-- Bootstrap -->
 91 |     @link-css[bootstrap-css]
 92 |     <!-- Inline CSS -->
 93 |     <!-- The body padding-top rule fixes overlap between navigation bar and content -->
 94 |     <!-- See http://stackoverflow.com/a/13051843/23567 -->
 95 |     <style>
 96 |       body { padding-top: 70px; }
 97 |     </style>
 98 | 
 99 |     <!-- HTML5 shim and Respond.js for IE8 support of HTML5 elements and media queries -->
100 |     <!-- WARNING: Respond.js doesn't work if you view the page via file:// -->
101 |     <!--[if lt IE 9]>
102 |     @script[html5shiv-js]
103 |     @script[respond-js]
104 |     <![endif]-->
105 |   </head>
106 |   <body>
107 |     @body
108 |     <!-- jQuery (necessary for Bootstrap's JavaScript plugins) -->
109 |     @script[jquery-js]
110 |     <!-- Include all compiled plugins (below), or include individual files as needed -->
111 |     @script[bootstrap-js]
112 |     <script>@file->string[urlang-js-file]</script>
113 |     @script[mathjax-js]    
114 |   </body>
115 | </html>})
116 | 
117 | 
118 | ;;; Bootstrap containers, fluid containers, and, rows.
119 | 
120 | ; A container has a fixed width
121 | (define (container . contents)       @div[class: "container"]{@contents})
122 | ; A fluid container can span the entire width of your viewport
123 | (define (fluid-container . contents) @div[class: "container-fluid"]{@contents})
124 | ; A row must be place in a (possibly fluids) container
125 | (define (row . columns)              @container[@div[class: "row"]{@columns}])
126 | 
127 | ;;; The navigation bar
128 | 
129 | ; This navigation is from the Bootstrap jumbotron example
130 | ;     http://getbootstrap.com/examples/jumbotron/
131 | (define (navigation-bar)
132 |   (list
133 |    @comment{NAVIGATION BAR}
134 |    @nav[class: "navbar navbar-inverse navbar-fixed-top"]{
135 |     @fluid-container[
136 |       @div[class: "navbar-header"]{
137 |        @comment{Bootstrap supports only button elements in a navbar}
138 |        @button[type:          "button"
139 |                class:         "navbar-toggle collapsed"
140 |                data-toggle:   "collapse"
141 |                data-target:   "#navbar"
142 |                aria-expanded: "false"
143 |                aria-controls: "navbar"]{
144 |          @span[class: "sr-only"]{Toggle navigation}
145 |          @comment{The following three spans will produce an hamburger on narrow screens}
146 |          @span[class: "icon-bar"]{}
147 |          @span[class: "icon-bar"]{}
148 |          @span[class: "icon-bar"]{}}
149 |        @a[class: "navbar-brand" href: "#"]{The Racket Quiz}}
150 |       @div[id: "navbar" class: "navbar-collapse collapse"]{}]}))
151 | 
152 | 
153 | (define (html-the-footer)
154 |   (list @comment{FOOTER}
155 |         @hr[]
156 |         @footer{@p{Jens Axel Søgaard, 2016}}))
157 | 
158 | (define cards
159 |   '(("Short name for: How to Design Books"              "HtDP")
160 |     ("Racket lists are ______ linked lists"             "singly")
161 |     ("The Racket IRC is on ________"                    "freenode")
162 |     ("Racket was formerly known as ___ Scheme"          "PLT")
163 |     ("A list with no elements is called the _____ list" "empty")
164 |     ("Are lists mutable?"                               "no")
165 |     ))
166 | 
167 | (define  (card->html card)
168 |   (match card
169 |     [(list question answer)
170 |      @div[@div[@h2{Question} @p[question]]
171 |           @div[answer]]]))
172 | 
173 | (define (html-flash-card)
174 |   ; style: "border:1px solid black"
175 |   @div[class: "col-md-6" ]{
176 |     @div[id: "flash-card-content"]{
177 |       @div[id: "flash-card-question-container"]{
178 |         @div[id: "flash-card-question"]{
179 |           @h2{Flash Card}
180 |           @p{The name of the mathematical exponentiation operator?}
181 |           @p{ $$ c = \sqrt{a^2+b^2} $$}}}
182 |       @html-answer-box[]}})
183 | 
184 | (define (html-answer-box)
185 |   (list
186 |     @h3{Answer}
187 |     @p{ @input[id: "answer-input" type: "text" value: "" placeholder: "Type here" tabindex: "1"]}))
188 | 
189 | (define (html-flash-card-row)
190 |   (list @comment{FLASH CARD ROW}
191 |         @div[class: "col-md-3"]{ }
192 |         @html-flash-card
193 |         @div[class: "col-md-3"]{ }))
194 | 
195 | ;;; Generate JavaScript
196 | 
197 | ;; The urlang will generate a JavaScript file.
198 | ;; The JavaScript will be activated in then the user
199 | ;; clicks the compute button.
200 | 
201 | (require urlang/extra ; make cond  available in urlang
202 |          urlang/for)  ; make "for" available in urlang
203 | 
204 | 
205 | (urlang
206 |  (urmodule quiz
207 |    (import $        ; from jQuery
208 |            window)  ; from the browser
209 | 
210 |    ; A state is one of:
211 |    ;   "wait-for-answer"
212 |    ;   "answer-was-correct"
213 |    ;   "answer-was-incorrect"
214 |    (define state "wait-for-answer")
215 |    (define current-card 0)
216 | 
217 |    ;;; The static dom elements
218 |    (define $answer-input       ($ "#answer-input"))    ; with jQuery wrapper
219 |    (define  answer-input       (ref $answer-input 0))  ; without
220 |    (define $question-container ($ "#flash-card-question-container"))
221 |    (define  question-container (ref $question-container 0))
222 |    
223 |    (define (on-next-question)
224 |      (:= current-card (% (+ current-card 1) the-cards.length))
225 |      (render-flash-card current-card)
226 |      ($answer-input.css "background-color" "white"))
227 | 
228 |    (define (on-answer-input-enter e)
229 |      ; called when user hits enter
230 |      (var [got      answer-input.value])
231 |      (var [expected (card-number->answer current-card)])
232 |      (cond
233 |        [(= (dot (got.trim) (toLowerCase)) (expected.toLowerCase))
234 |         ;; signal correct answer: background green, then continue
235 |         ($answer-input.css "background-color" "#dff0d8")
236 |         (window.setTimeout on-next-question 500)
237 |         ($answer-input.attr "placeholder" "type here")]
238 |        [else
239 |         ;; signal incorrect answer: background red, reveal answer
240 |         ($answer-input.css "background-color" "#f2dede")
241 |         ($answer-input.val "")
242 |         ($answer-input.attr "placeholder" expected)]))
243 |    
244 |    ;;; Render Flash Card
245 |    (define (render-flash-card card-number)
246 |      (var [$card  ($ (card-number->question card-number))])
247 |      ;; replace the question 
248 |      ($question-container.empty)
249 |      ($question-container.prepend ($card.clone))
250 |      ;; clear the answer input
251 |      ($answer-input.val ""))
252 | 
253 |    (define (card-number->answer n)
254 |      (var [card-div    (ref the-cards n)])
255 |      (var [answer-node (ref (dot ($ card-div) (children)) 1)])
256 |      (var [answer-text (dot ($ answer-node) (text))])
257 |      answer-text)
258 | 
259 |    (define (card-number->question n)
260 |      (var [card-div (ref the-cards n)])
261 |      (ref (dot ($ card-div) (children)) 0))   
262 | 
263 |    ;; Register input handlers
264 |    (dot ($ "#answer-input")
265 |         (keyup (λ (e) (when (= e.keyCode 13) ; enter key
266 |                         (on-answer-input-enter e)))))
267 | 
268 |    ;; Set focus to input
269 |    (dot ($ "#answer-input") (focus))
270 | 
271 |    ;; Cards
272 |    (var [the-cards (dot ($ "#card-db") (children))])
273 |    
274 |    ;; Render initial card
275 |    (render-flash-card current-card)
276 |    ))
277 | 
278 | ;;; Test it in the browser
279 | 
280 | (send-url/contents
281 |  (generate-html
282 |   @~xs{ @navigation-bar[]
283 |         @comment{Use a container to make the footer and the row the same width}
284 |         @container[@html-flash-card-row]
285 |         @container[@html-the-footer]
286 |         @comment{This div has a hidden list of all question-answer pairs}
287 |         @div[id: "card-db" style: "display: none"
288 |              (map card->html cards)]}
289 |   "quiz.js"))
290 | 


--------------------------------------------------------------------------------
/urlang-examples/ractive/README.md:
--------------------------------------------------------------------------------
 1 | Use Ractive with Urlang
 2 | =======================
 3 | 
 4 | Ractive is a template-driven UI library.
 5 | The simple idea is to give Ractive a template and some data.
 6 | Ractive then generates HTML that can replace an existing DOM node.
 7 | 
 8 | These examples show how to use the Ractive JS library from Urlang.
 9 | Ractive is a lightweight alternative to Angular, React, etc.
10 | 
11 | The examples are based on  http://www.ractivejs.org/60-second-setup
12 | Thanks to Daniel Prager for the original Racket versions.
13 | 
14 | ractive-bootstrap-example.rkt
15 | -----------------------------
16 | - uses x-expressions and html-writing to generate html
17 | - uses Urlang to generate JavaScript
18 | - uses Bootstrap for css
19 | 
20 | ractive-bootstrap-example.html
21 | ------------------------------
22 | Pretty-printed output (using js-beautify --html) of ractive-bootstrap-example.rkt
23 | 
24 | ractive-original.rkt
25 | --------------------
26 | - uses x-expressions and html-writing to generate html
27 | - uses Urlang to generate JavaScript
28 | 
29 | ractive.rkt
30 | -----------
31 | - uses web-server/templates  to generate html
32 | - uses Urlang to generate JavaScript
33 | 
34 | 
35 |     


--------------------------------------------------------------------------------
/urlang-examples/ractive/ractive-bootstrap-example.html:
--------------------------------------------------------------------------------
 1 | <html>
 2 | 
 3 | <head>
 4 |     <title>Ractive button example</title>
 5 |     <script src="https://ajax.googleapis.com/ajax/libs/jquery/1.12.0/jquery.min.js"></script>
 6 |     <link rel="stylesheet" href="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.6/css/bootstrap.min.css">
 7 |     <script src="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.6/js/bootstrap.min.js"></script>
 8 |     <script src="http://cdn.ractivejs.org/latest/ractive.min.js"></script>
 9 | </head>
10 | 
11 | <body>
12 |     <div id="container"></div>
13 |     <script id="template" type="text/ractive">
14 |         <div class="container" style="margin-top: 30px">
15 |             <div class="row">
16 |                 <div class="col-md-6">
17 |                     <div class="panel panel-default">
18 |                         <div class="panel-heading">
19 |                             <h1>Press a button</h1></div>
20 |                         <div class="panel-body"><button on-click="grow" class="btn btn-primary btn-lg">Grow</button> <button on-click="shrink" class="btn btn-primary">Shrink</button>{{#keep_pressing}} Now, keep pressing!{{/keep_pressing}}
21 |                             <h2>Statistics</h2>
22 |                             <table class="table table-bordered table-condensed">
23 |                                 <tbody>
24 |                                     <tr>
25 |                                         <td><b>Clicks</b></td>
26 |                                         <td>{{clicks}}</td>
27 |                                     </tr>
28 |                                     <tr>
29 |                                         <td><b>Size</b></td>
30 |                                         <td>{{size}} pixels</td>
31 |                                     </tr>
32 |                                 </tbody>
33 |                             </table>
34 |                         </div>
35 |                     </div>
36 |                 </div>
37 |                 <div class="col-md-6">
38 |                     <div class="panel panel-default">
39 |                         <div class="panel-body">
40 |                             <p>This totally client-side example was written in <a href="https://racket-lang.org/">Racket</a> using </p>
41 |                             <ul>
42 |                                 <li><a href="https://github.com/soegaard/urlang"> Urlang</a> as a Racket-ish stand-in for JavaScript</li>
43 |                                 <li><a href="http://ractivejs.org">ractive</a> as the key JavaScript framework to interact with the DOM</li>
44 |                                 <li><a href="https://docs.racket-lang.org/html-writing/index.html">sxml / x-expressions</a> instead of html</li>
45 |                                 <li><a href="http://getbootstrap.com">Bootstrap</a> for CSS styling</li>
46 |                             </ul>
47 |                             <p style="color:{{color}}; font-size:{{size}}px; font-family:{{font}}">Hello, {{name}}!</p>
48 |                         </div>
49 |                     </div>
50 |                 </div>
51 |             </div>
52 |         </div>
53 |     </script>
54 |     <script>
55 |         "use strict";
56 |         var model = {
57 |                 name: "Racket",
58 |                 color: "purple",
59 |                 font: "Georgia",
60 |                 clicks: 0,
61 |                 size: 60,
62 |                 keep_pressing: false
63 |             },
64 |             ractive = new Ractive({
65 |                 el: "#container",
66 |                 template: "#template",
67 |                 data: model
68 |             });
69 | 
70 |         function inc_by(s, amount) {
71 |             return (ractive.set(s, ((ractive.get(s)) + amount)));
72 |         };
73 | 
74 |         function resize(n) {
75 |             (inc_by("size", n));
76 |             (inc_by("clicks", 1));
77 |             return (ractive.set("keep_pressing", true));
78 |         };
79 |         (ractive.on({
80 |             grow: (function(e) {
81 |                 return (resize(5));
82 |             }),
83 |             shrink: (function(e) {
84 |                 return (resize(-5));
85 |             })
86 |         }));
87 |     </script>
88 | </body>
89 | 
90 | </html>


--------------------------------------------------------------------------------
/urlang-examples/ractive/ractive-bootstrap-example.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | 
  3 | (require html-writing urlang net/sendurl)
  4 | 
  5 | (current-urlang-run?                           #f) ; run using Node?
  6 | (current-urlang-echo?                          #f) ; print generated JavaScript?
  7 | (current-urlang-console.log-module-level-expr? #f) ; print top-level expression?
  8 | 
  9 | (define jquery "https://ajax.googleapis.com/ajax/libs/jquery/1.12.0/jquery.min.js")
 10 | (define bootstrap-css "https://maxcdn.bootstrapcdn.com/bootstrap/3.3.6/css/bootstrap.min.css")
 11 | (define bootstrap-js "https://maxcdn.bootstrapcdn.com/bootstrap/3.3.6/js/bootstrap.min.js")
 12 | (define ractive-js "http://cdn.ractivejs.org/latest/ractive.min.js")
 13 | 
 14 | (define (ractive title template js-file)
 15 |   (xexp->html
 16 |    `((html (head (title ,title)
 17 |                  (script (@ (src ,jquery)))
 18 |                  (link (@ (rel "stylesheet") (href ,bootstrap-css)))
 19 |                  (script (@ (src ,bootstrap-js)))
 20 |                  (script (@ (src ,ractive-js))))
 21 |            (body
 22 |             (div (@ (id "container")))
 23 |             (script (@ (id "template") (type "text/ractive"))
 24 |                     ,@template)
 25 |             (script ,(file->string js-file)))))))
 26 | 
 27 | (define (make-style xs)
 28 |   (string-join
 29 |    (for/list ([x xs])
 30 |      (match-define (list key val) x)
 31 |      (~a key ":" val))
 32 |    "; "))
 33 | 
 34 | (define template
 35 |   `((div (@ (class "container") (style "margin-top: 30px"))
 36 |          (div (@ (class "row"))
 37 |               (div (@ (class "col-md-6"))
 38 |                    (div (@ (class "panel panel-default"))
 39 |                         (div (@ (class "panel-heading"))
 40 |                              (h1 "Press a button"))
 41 |                         (div (@ (class "panel-body"))
 42 |                              (button (@ (on-click "grow") (class "btn btn-primary btn-lg"))
 43 |                                      "Grow")
 44 |                              " "
 45 |                              (button (@ (on-click "shrink") (class "btn btn-primary"))
 46 |                                      "Shrink")
 47 |                              "{{#keep_pressing}}"
 48 |                              " Now, keep pressing!"
 49 |                              "{{/keep_pressing}}"
 50 |                              (h2 "Statistics")
 51 |                              (table (@ (class "table table-bordered table-condensed"))
 52 |                                     (tbody
 53 |                                      (tr (td (b "Clicks")) (td "{{clicks}}"))
 54 |                                      (tr (td (b "Size")) (td "{{size}} pixels")))))))
 55 |               (div (@ (class "col-md-6"))
 56 |                    (div (@ (class "panel panel-default"))
 57 |                         (div (@ (class "panel-body"))
 58 |                              (p "This totally client-side example was written in "
 59 |                                 (a (@ (href "https://racket-lang.org/")) "Racket") " using ")
 60 |                              (ul
 61 |                               (li (a (@ (href "https://github.com/soegaard/urlang")) " Urlang")
 62 |                                   " as a Racket-ish stand-in for JavaScript")
 63 |                               (li (a (@ (href "http://ractivejs.org")) "ractive")
 64 |                                   " as the key JavaScript framework to interact with the DOM")
 65 |                               (li (a (@ (href
 66 |                                          "https://docs.racket-lang.org/html-writing/index.html"))
 67 |                                      "sxml / x-expressions") " instead of html")
 68 |                               (li (a (@ (href "http://getbootstrap.com")) "Bootstrap")
 69 |                                   " for CSS styling"))
 70 |                              (p (@ (style ,(make-style '((color "{{color}}")
 71 |                                                          (font-size "{{size}}px")
 72 |                                                          (font-family "{{font}}")))))
 73 |                                 "Hello, {{name}}!"))))))))
 74 | 
 75 | (urlang
 76 |  (urmodule ractive
 77 |            (import Ractive)
 78 |            (var [model (object [name "Racket"]
 79 |                                [color "purple"]
 80 |                                [font "Georgia"]
 81 |                                [clicks 0]
 82 |                                [size 60]
 83 |                                [keep_pressing #f])]
 84 |                 [ractive (new Ractive
 85 |                               (object [el "#container"]
 86 |                                       [template "#template"]
 87 |                                       [data model]))])
 88 |            
 89 |            (define (inc-by s amount) (ractive.set s (+ (ractive.get s) amount)))
 90 |            (define (resize n)
 91 |              (inc-by "size" n)
 92 |              (inc-by "clicks" 1)
 93 |              (ractive.set "keep_pressing" #t))
 94 |            
 95 |            (ractive.on (object [grow (λ (e) (resize 5))]
 96 |                                [shrink (λ (e) (resize -5))]))))
 97 | 
 98 | (send-url/contents
 99 |  (ractive "Ractive button example"
100 |           template
101 |           "ractive.js"))


--------------------------------------------------------------------------------
/urlang-examples/ractive/ractive-original.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | ;;; Original Ractive Example
 4 | 
 5 | ;; This example by Daniel Prager shows how to use the Ractive
 6 | ;; framework with Urlang. This version uses x-expressions
 7 | ;; and the html-writing package to generate the html.
 8 | ;; Compare with the version in "ractive.rkt"
 9 | 
10 | (require html-writing urlang net/sendurl)
11 | 
12 | (current-urlang-run?                           #f) ; run using Node?
13 | (current-urlang-echo?                          #f) ; print generated JavaScript?
14 | (current-urlang-console.log-module-level-expr? #f) ; print top-level expression?
15 | 
16 | (define (ractive template js-file)
17 |   (xexp->html
18 |    `((html (head (title "Ractive test")
19 |                  (script (@ (src "http://cdn.ractivejs.org/latest/ractive.min.js"))))
20 |           (body
21 |            (div (@ (id "container")))
22 |            (script (@ (id "template") (type "text/ractive"))
23 |                    ,@template)
24 |            (script ,(file->string js-file)))))))
25 | 
26 | (urlang
27 |  (urmodule ractive
28 |            (import Ractive)
29 |            (var [ractive (new Ractive
30 |                               (object [el "#container"]
31 |                                       [template "#template"]
32 |                                       [data (object [name "Racket"])]))])))
33 | 
34 | (send-url/contents
35 |  (ractive '((h1 "Ractive test")
36 |             (p "Hello, {{name}}!"))
37 |           "ractive.js"))
38 | 


--------------------------------------------------------------------------------
/urlang-examples/ractive/ractive.js:
--------------------------------------------------------------------------------
1 | "use strict";
2 | var ractive=new Ractive({el :"#container",template :"#template",data :{name :"Racket"}});
3 | 


--------------------------------------------------------------------------------
/urlang-examples/ractive/ractive.rkt:
--------------------------------------------------------------------------------
 1 | #lang at-exp racket
 2 | 
 3 | ;;;
 4 | ;;; Ractive 
 5 | ;;; 
 6 | 
 7 | ;;; Ractive is a template-driven UI library.
 8 | ;;; The simple idea is to give Ractive a template and some data.
 9 | ;;; Ractive then generates HTML that can replace an existing DOM node.
10 | 
11 | ;;; This example shows how to use the Ractive JS library from Urlang.
12 | ;;; Ractive is a lightweight alternative to Angular, React, etc.
13 | ;;; The example is based on  http://www.ractivejs.org/60-second-setup
14 | ;;; Thanks to Daniel Prager for the original Racket version.
15 | 
16 | 
17 | ;;; The following Racket libraries are needed
18 | (require urlang                ; to generate JavaScript
19 |          web-server/templates  ; to generate html
20 |          net/sendurl)          ; to send the html to the browser
21 | 
22 | ;;; First, configure Urlang:
23 | (current-urlang-run?                           #f) ; run using Node? no (we are using a browser)
24 | (current-urlang-echo?                          #t) ; print generated JavaScript? yes
25 | (current-urlang-console.log-module-level-expr? #f) ; print top-level expression? no need
26 | 
27 | ;;;
28 | ;;; HTML
29 | ;;;
30 | 
31 | ; Consider the html file below.
32 | ; The contents of  <div id="container"/>  will be replaced
33 | ; by the result of combining a template and some data at runtime.
34 | 
35 | ; The Ractive template needs to be stored somewhere in the DOM.
36 | ; Here it is stored in the id=template node.
37 | 
38 | ; The Ractive template could be:
39 | ;    <p>Hello, {{name}}!</p>
40 | ; If the data object given to Ractive contains a name field,
41 | ; then the {{name}} will be filled in with the corresponding value.
42 | 
43 | (define (generate-html ractive-template)
44 |   @~a{<!doctype html>
45 |       <html lang="en-US">
46 |         <head> <meta charset="utf-8"/>
47 |                <title>Ractive Test</title>
48 |                <script src="http://cdn.ractivejs.org/latest/ractive.min.js"></script>
49 |         </head>
50 |         <body>  <h1>Hello Racketeers!</h1>
51 |                 <div id="container"/>
52 |                 <script id="template" type="text/ractive">
53 |                     @ractive-template
54 |                 </script>
55 |                 <script>@ractive.js </script>
56 |         </body>
57 |       </html>})
58 | 
59 | ;;;
60 | ;;; Urlang / JavaScript
61 | ;;;
62 | 
63 | ; In order for Ractive to fill in the template,
64 | ; Ractive needs to be activated. This small script,
65 | ; will create an Ractive object and pass on the data object:
66 | ;   {name: "Racket"}
67 | ; The effect will be that "Racket" wil replace {{name}} in the template.
68 | 
69 | 
70 | ;; The form (urlang ...) compiles all urmodules into JavaScript files.
71 | (urlang
72 |  (urmodule ractive    ; save to ractive.js
73 |    (import Ractive)   ; declare Ractive
74 |    (var [ractive (new Ractive                            ; call Ractive constructor
75 |                       (object [el       "#container"]    ; el can be a node, an ID, or a CSS selector
76 |                               [template "#template"]     ; id of the <script> tag above
77 |                               [data     (object
78 |                                          [name "Racket"])]))])))
79 | 
80 | ;; Read JavaScript from file.
81 | ;; Note: Normally one would use <script src="ractive.js"/> in the html.
82 | ;;       Here we want an example, that can run without a web-server.
83 | ;;       So we simply read in the JavaScript from disk.
84 | (define ractive.js (file->string "ractive.js"))
85 | 
86 | ;; It is not time to call generate-html.
87 | ;; The html could be saved to a file and then manually opened in a browser.
88 | ;; Under development it is convenient to use send-url/contents to send
89 | ;; the web-page directly to the browser.
90 | 
91 | (send-url/contents
92 |  (generate-html
93 |   @~a{<p>Hello, {{name}}!</p>}))
94 | 
95 | 


--------------------------------------------------------------------------------
/urlang-examples/raphael/browser.exports:
--------------------------------------------------------------------------------
1 | ()
2 | 


--------------------------------------------------------------------------------
/urlang-examples/raphael/browser.html:
--------------------------------------------------------------------------------
 1 | <html>
 2 |   <head>
 3 |     <script src="browser.js"></script>
 4 |     <script src="https://cdnjs.cloudflare.com/ajax/libs/raphael/2.1.4/raphael-min.js"></script>
 5 |   </head>
 6 |   <body>
 7 |      <div id="holder"></div>
 8 |      <div id="intro"></div>
 9 |   </body>
10 | </html>


--------------------------------------------------------------------------------
/urlang-examples/raphael/browser.js:
--------------------------------------------------------------------------------
 1 | "use strict";
 2 | console.log((window.module=(window.module||[])));
 3 | {var _lh1_g=(function(t){var e=(document.createElement("h1"));(e.appendChild(t));return e;}),_lp_g=(function(t){var e=(document.createElement("p"));(e.appendChild(t));return e;}),_lp_g=(function(t){var e=(document.createElement("p"));(e.appendChild(t));return e;}),_ldiv_g=(function(t){var e=(document.createElement("div"));(e.appendChild(t));return e;});}
 4 | var intro=false;
 5 | function insert(t){return (intro.appendChild(t));};
 6 | function text(t){return (document.createTextNode(t));};
 7 | function draw(){var r=(Raphael("holder",720,520));{var i=0,t=360;while((true&&true&&(i<t))){((function(angle){((function(t_1,c){return ((function(v){return ((function(v_2){return ((function(v_3){return ((function(v_4){return ((function(v_5){return ((function(){return v_5;})());})((v_4.mouseout((function(){return (this.animate({"fill-opacity":0.4},500));})))));})((v_3.mouseover((function(){return (this.animate({"fill-opacity":0.75},500));})))));})((v_2.click((function(){return (s.animate({stroke:c,transform:t_1},2000,"bounce"));})))));})((v.attr({stroke:c,fill:c,transform:t_1,"fill-opacity":0.4}))));})((r.circle(320,450,20))));})(("r"+angle+" 320 240"),(Raphael.getColor())));return (i+=30);})(i));};undefined;}((Raphael.getColor.reset)());var no_fill=(function(w){return {fill:"none","stroke-width":w};});var s=(r.set());(((s.push((r.path("M320,240c-50,100,50,110,0,190")))).attr)((no_fill(2))));(((s.push((r.circle(320,450,20)))).attr)((no_fill(2))));(((s.push((r.circle(320,240,5)))).attr)((no_fill(10))));return (s.attr({stroke:(Raphael.getColor())}));};
 8 | function run_on_load(){(intro=(document.getElementById("intro")));(insert((_lh1_g((text("Welcome to Urlang"))))));(insert((_lp_g((text("This example illustrates how to use Raphael."))))));(insert((_lp_g((text("Click one of the circles."))))));return (draw());};
 9 | console.log((window.addEventListener("load",run_on_load)));
10 | 


--------------------------------------------------------------------------------
/urlang-examples/raphael/browser.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | ;;;
 3 | ;;; Browser
 4 | ;;;
 5 | 
 6 | ;; This module contains an example of a small web page using RaphaelJS,
 7 | ;; a JavaScript graphics library.
 8 | 
 9 | ;; The html page consists of two parts:
10 | ;;  <div id="holder"></div>  will hold a canvas on which a clock is drawn
11 | ;;  <div id="intro"></div>   is used to write a small text on screen
12 | 
13 | (require urlang urlang/extra urlang/for syntax/parse)
14 | 
15 | (current-urlang-run?                           #f) ; don't use node to run this 
16 | (current-urlang-echo?                          #t) ; print output JavaScript
17 | (current-urlang-console.log-module-level-expr? #t) ; print result of top level expressions
18 | ;                                                  ; to the JavaScript console
19 | 
20 | (define-urlang-macro define-html-tags
21 |   (λ (stx)
22 |     (syntax-parse stx
23 |       [(_define-tags [<tag> tag] ...)
24 |        (with-syntax ([(tag ...) (map ~a (map syntax->datum (syntax->list #'(tag ...))))])
25 |          (syntax/loc stx
26 |            (block
27 |             (var [<tag> (λ (t)
28 |                           (var [e (document.createElement tag)])
29 |                           (e.appendChild t)
30 |                           e)]
31 |                  ...))))])))
32 | 
33 | (display
34 |  (urlang
35 |   (urmodule browser    
36 |     (import string-append str) 
37 |     
38 |     ;; These identifier are available in a browser (but not declared in the source)
39 |     (import document window window.module prompt alert window.document.body.onload )
40 |     ;; The following types should be supported by urlang.rkt eventually
41 |     (import Array Int8Array Number String this)
42 |     ;; Import Raphael.js
43 |     (import Raphael)
44 | 
45 |     ;; Keep the JavaScript "module system" happy in the browser
46 |     ;; window.module = window.module || [];
47 |     (:= window.module (or window.module (array)))
48 |     
49 |     ;; Define constructors for elements of various types.
50 |     (define-html-tags [<h1> h1] [<p> p] [<p> p] [<div> div])
51 |     ;; (insert t) inserts a dom element into the body    
52 |     (define intro #f)
53 |     (define (insert t) (intro.appendChild t))
54 |     ;; text nodes
55 |     (define (text t)   (document.createTextNode t))
56 | 
57 |     (define (draw)
58 |       ;; The html has a <div id="holder"></div>. Put a canvas there.
59 |       (var [r (Raphael "holder" 720 520)])
60 |       ;; Draw circles 30 degrees apart
61 |       (for ([angle in-range 0 360 30])
62 |         (let ([t (+ "r" angle " 320 240")]  ; transformation : rotate angle around point
63 |               [c (Raphael.getColor)])       ; each call returns new color in spectrum
64 |           (let* ([v (r.circle 320 450 20)]  ; a circle with these attributes:
65 |                  [v (v.attr (object [stroke c] [fill c] [transform t] ["fill-opacity" .4]))]
66 |                  ;; The click handler moves the hand to the circle
67 |                  [v (v.click     (λ()(s.animate    (object [stroke c] [transform t]) 2000 "bounce")))]
68 |                  ;; the mouse over handler darkens the circle
69 |                  [v (v.mouseover (λ()(this.animate (object ["fill-opacity" 0.75]) 500)))]
70 |                  ;; the mouse out handler brightens the circle
71 |                  [v (v.mouseout  (λ()(this.animate (object ["fill-opacity" 0.4])  500)))])
72 |             v)))
73 |       (Raphael.getColor.reset)
74 |       (var [no-fill (λ (w) (object [fill "none"] ["stroke-width" w]))])
75 |       (var [s (r.set)]) ; set to keep the elements of the "hand" (of the "clock")
76 |       ((ref (s.push (r.path "M320,240c-50,100,50,110,0,190")) "attr") (no-fill  2)) 
77 |       ((ref (s.push (r.circle 320 450 20))                    "attr") (no-fill  2))
78 |       ((ref (s.push (r.circle 320 240 5))                     "attr") (no-fill 10))
79 |       (s.attr (object [stroke (Raphael.getColor)]))) ; all elements of the hand get the same color
80 |     
81 |     ;; entry point called by browser
82 |     (define (run-on-load)
83 |       (:= intro (document.getElementById "intro")) ; register the body element (used by insert)
84 |       (insert (<h1> (text "Welcome to Urlang")))   ; make header
85 |       (insert (<p>  (text "This example illustrates how to use Raphael.")))
86 |       (insert (<p>  (text "Click one of the circles.")))
87 |       (draw))
88 | 
89 |     ;; Instruct the browser to run run-on-load when the page has loaded and the DOM is created.
90 |     (window.addEventListener "load" run-on-load))))
91 | 


--------------------------------------------------------------------------------
/urlang-examples/react/urx.rkt:
--------------------------------------------------------------------------------
  1 | #lang at-exp racket
  2 | ;;;
  3 | ;;; URX
  4 | ;;;
  5 | 
  6 | ; This implements urx expressions.
  7 | ; What jsx expressions are to JavaScript, urx expressions are to Urlang.
  8 | ; JSX expressions are an extension to JavaScript that makes it easy
  9 | ; to generate React elements (representing dom elements) at runtime.
 10 | 
 11 | ; This file (for now) contains both urx expressions.
 12 | 
 13 | (require urlang urlang/html
 14 |          ; (except-in xml make-element entity element comment cdata attribute? attribute)
 15 |          syntax/parse (for-syntax syntax/parse))
 16 | (require (for-syntax scribble/html/xml racket/match))
 17 | 
 18 | ;;; JSX                        URX (AT-expression)    S-EXPR                 Urlang
 19 | ;;; <div>Foo</div>             @div{Foo}              (div "foo")            (React.createElement "div" null (array "Foo"))
 20 | ;;; <div foo="bar">Foo</div>   @div[foo: "bar"]{Foo}  (div foo: bar "foo")   (React.createElement "div" (object [foo "bar"]) (array "Foo"))
 21 | ;;; <Input />                  @Input[]               (Input)                (React.createElement "Input" null)
 22 | 
 23 | ;;  Note that jsx/urx expressions are allowed in the body too.
 24 | 
 25 | 
 26 | ;; @list[foo: "foo" bar: "bar"]{baz @42 qux}
 27 | ;; (foo: "foo" bar: "bar" "baz " 42 " qux")
 28 | 
 29 | ;; An easy way to see that an urx-expressions reads as:
 30 | 
 31 | (define-syntax (urx-test stx)
 32 |   (syntax-parse stx
 33 |     [(_ urx-expr)
 34 |      (syntax/loc stx
 35 |        'urx-expr)]))
 36 | 
 37 | 
 38 | ;; (urx-test @div[foo: "bar" Foo])
 39 | ;; '(div foo: "bar" Foo)
 40 | 
 41 | ;; The library scribble/html/xml provides a few tools that will help us.
 42 | (require scribble/html/xml
 43 |          )
 44 | 
 45 | ;; First The attribute names are represented as symbols that end with a colon.
 46 | 
 47 | ;; > (attribute? 'foo:)
 48 | ;; foo
 49 | ;; > (attribute? 'foo)
 50 | ;; #f
 51 | 
 52 | ;; To make things clearer, we will use `attribute->symbol` when we need
 53 | ;; to remove a colon.
 54 | 
 55 | (define attribute->symbol attribute?)
 56 | 
 57 | ;; We will need to split a form into the attributes and the body.
 58 | ;; The functions `attributes+body` and `split-attributes+body` will help
 59 | ;; us with this.
 60 | 
 61 | ;; > (attributes+body '(foo: "bar" Foo))
 62 | ;; '((foo . "bar"))
 63 | ;; '(Foo)
 64 | 
 65 | ;; > (split-attributes+body '(foo: "bar" Foo))
 66 | ;; '(foo: "bar")
 67 | ;; '(Foo)
 68 | 
 69 | (require racket/syntax)
 70 | (define-urlang-macro urx
 71 |   (λ (stx)
 72 |     ; attributes+body : syntax-list -> ...
 73 |     (define attribute->symbol attribute?)    
 74 |     (define (attributes+body xs) 
 75 |       (let loop ([xs xs] [as '()])
 76 |         (define a (and (pair? xs)
 77 |                        (identifier? (car xs))
 78 |                        (attribute->symbol (syntax-e (car xs)))))
 79 |         (define a-id (and a (datum->syntax (car xs) a (car xs))))
 80 |         ; if a is #f we have seen the last attribute,
 81 |         ; otherwise a is the attribute name (without colon).
 82 |         (cond [(not a)              (values (reverse as) xs)]
 83 |               [(null? (cdr xs))     (error 'attributes+body
 84 |                                            "missing attribute value for `~s:'" a)]
 85 |               [else (loop (cddr xs)
 86 |                           (cons (cons a-id (cadr xs)) as))])))    
 87 |     (define (convert urx-expr)
 88 |       ; (displayln (list 'urx-convert urx-expr))
 89 |       (syntax-parse urx-expr
 90 |         #:datum-literals (ur)
 91 |         [s:string   #'s]
 92 |         [n:number   #'n]
 93 |         [i:id       #'i]
 94 |         [b:boolean  #'b]
 95 |         [(ur more)  #'more]   ; "unquote" for urx expressions (called mustaches in jsx)
 96 |         [(tag:id (~optional (~seq #:spread props:id) #:defaults ([props #f]))
 97 |                  atts+body ...)
 98 |          (define ps (attribute props))
 99 |          (define-values (atts body)
100 |            (attributes+body (syntax->list #'(atts+body ...))))
101 |          (define tag-str (symbol->string (syntax-e #'tag)))
102 |          (with-syntax* ([tag              (if (char-lower-case? (string-ref tag-str 0))
103 |                                               tag-str
104 |                                               #'tag)]
105 |                         [((id . val) ...) atts]
106 |                         [(val ...)        (map convert (syntax->list #'(val ...)))]
107 |                         [(content ...)    (map convert body)])
108 |            (with-syntax
109 |              ([atts-expr
110 |                (cond [(and (zero? (length atts)) (not ps)) #'null]
111 |                      [(and (zero? (length atts))      ps)  ps]
112 |                      [(not ps)                             #'(object [id val] ...)]
113 |                      [else
114 |                       (with-syntax ([props ps])
115 |                         ; TODO change assign here to something that works ...
116 |                         #'(Object.assign (object) (object [id val] ...) props))])])
117 |                                
118 |              (match body
119 |                ['() (syntax/loc urx-expr
120 |                       (React.createElement tag atts-expr))]
121 |                [_   (syntax/loc urx-expr
122 |                       (React.createElement tag atts-expr (array content ...)))])))]))
123 |     (syntax-parse stx
124 |       [(_urx urx-expr)
125 |        (define out (convert #'urx-expr))
126 |        ; (displayln (syntax->datum out))
127 |        out])))
128 | 


--------------------------------------------------------------------------------
/urlang-examples/space-invaders/space-invaders.rkt:
--------------------------------------------------------------------------------
  1 | #lang at-exp racket
  2 | ;;;
  3 | ;;; SPACE INVADERS
  4 | ;;;
  5 | 
  6 | ; Jens Axel Søgaard, Feb 2016
  7 | ;     https://github.com/soegaard/urlang/urlang-examples/space-invaders
  8 | 
  9 | ; An Urlang remake of a HtDP Space Invader game:
 10 | ;     https://github.com/soegaard/space-invaders
 11 | 
 12 | ; Which were inspired by Mary Rose Cook's JavaScript version of Space Invaders.
 13 | ;     https://github.com/maryrosecook/annotated-code
 14 | 
 15 | ; The intention of this program is to show how close you can get to the
 16 | ; original HtDP program using a few macros to implement struct and struct-copy.
 17 | ; The intention is not to port the JavaScript version by Mary Rose line by line.
 18 | 
 19 | ; Try it here:
 20 | ;     http://soegaard.github.io/urlang/space-invaders.html
 21 | 
 22 | ; Have fun!
 23 | 
 24 | ;;;
 25 | ;;; Urlang Configuration
 26 | ;;;
 27 | 
 28 | (require urlang urlang/for urlang/extra syntax/parse syntax/stx racket/syntax)
 29 | 
 30 | (current-urlang-run?                           #f) ; run using Node?              No: use browser
 31 | (current-urlang-echo?                          #t) ; print generated JavaScript?  Yes
 32 | (current-urlang-console.log-module-level-expr? #t) ; print top-level expression?  Yes (see console)
 33 | (current-urlang-beautify?                      #t) ; invoke js-beautify           
 34 | 
 35 | ;;;
 36 | ;;; Implementation in Urlang
 37 | ;;;
 38 | 
 39 | ; hash table from struct name to list of fields
 40 | (define structs (make-hash))
 41 | (define (register-struct name fields) (hash-set! structs (syntax-e name) fields))
 42 | (define (get-fields name)             (hash-ref  structs (syntax-e name) #f))
 43 | 
 44 | (define-urlang-macro struct
 45 |   (λ (stx)
 46 |     (syntax-parse stx
 47 |       [(_ name (field ...))
 48 |        (define (mangle-id x) (format-id x (mangle x) #:source x))
 49 |        (register-struct #'name (syntax->datum #'(field ...)))
 50 |        (with-syntax* ([(mfield ...)     (map mangle-id (syntax->list #'(field ...)))]
 51 |                       [(pn ...)         (map ~a (syntax->datum #'(mfield ...)))]
 52 |                       [(name-field ...) (map (λ (f) (format-id f "~a-~a" #'name f))
 53 |                                              (syntax->list #'(field ...)))]
 54 |                       [name?            (format-id #'name "~a?" #'name)]
 55 |                       [Name             (format-id #'hane (string-upcase (~a (syntax-e #'name))))])
 56 |          (syntax/loc stx
 57 |            (topblock
 58 |             (define (Name field ...) (:= this pn field) ... this)
 59 |             (define (name field ...) (new Name field ...))
 60 |             (define (name-field x)   (dot x field)) ...
 61 |             (define (name? o)        (= o.constructor Name)))))]
 62 |       [(_ name parent (field ...))
 63 |        (define parent-fields (get-fields #'parent))
 64 |        (cond
 65 |          [parent-fields
 66 |           (with-syntax ([(parent-field ...) parent-fields])
 67 |             (syntax/loc stx
 68 |               (struct name (parent-field ... field ...))))]
 69 |          [else
 70 |           (raise-syntax-error 'struct "parent struct not defined" stx)])])))
 71 | 
 72 | (define-urlang-macro match-define
 73 |   (λ (stx)
 74 |     (syntax-parse stx
 75 |       [(_ (name field ...) expr)
 76 |        (define orig-fields (get-fields #'name))
 77 |        (unless orig-fields
 78 |          (raise-syntax-error 'match-define "struct name not recognized" stx))
 79 |        (with-syntax ([(orig-field ...) orig-fields])
 80 |          ; todo: check that the number of fields match          
 81 |          (syntax/loc stx
 82 |            (var [tmp expr]
 83 |                 [field (dot tmp orig-field)] ...)))])))
 84 | 
 85 | (define-urlang-macro struct-copy
 86 |   (λ (stx)
 87 |     (syntax-parse stx
 88 |       [(_ name struct-expr [field-to-change field-expr] ...)
 89 |        (displayln stx)
 90 |        (define orig-fields (get-fields #'name))
 91 |        (unless orig-fields
 92 |          (raise-syntax-error 'match-define "struct name not recognized" stx))
 93 |        (with-syntax ([(field-to-change ...) (map ~a (syntax->datum #'(field-to-change ...)))]
 94 |                      [(field ...)     orig-fields]
 95 |                      [(field-str ...) (map ~a orig-fields)])
 96 |          (syntax/loc stx
 97 |            (let ()
 98 |              (var [copy (Object.create struct-expr)])
 99 |              (:= copy field-to-change field-expr) ...
100 |              copy)))])))
101 | 
102 | (urlang
103 |  (urmodule space-invaders
104 |    (import this Math isFinite Object window document Date)
105 |    ;;;
106 |    ;;; General purpose functions available in Racket
107 |    ;;;
108 |    (define (remainder x y) (% x y))
109 |    (define (filter pred xs)
110 |      (var [j 0] [ys (array)])
111 |      (for ([x in-array xs])
112 |        (when (pred x)
113 |          (:= ys j x)
114 |          (:= j (+ j 1))))
115 |      ys)
116 |    (define (filter-map proc xs)
117 |      (var [j 0] [ys (array)] [t #f])
118 |      (for ([x in-array xs])
119 |        (:= t (proc x))
120 |        (when t
121 |          (:= ys j t)
122 |          (:= j (+ j 1))))
123 |      ys)
124 |    (define (append xs ys)
125 |      (var [zs (array)] [j 0])
126 |      (for ([x in-array xs])
127 |        (:= zs j x)
128 |        (:= j (+ j 1)))
129 |      (for ([y in-array ys])
130 |        (:= zs j y)
131 |        (:= j (+ j 1)))
132 |      zs)
133 |    (define (map f xs)
134 |      (for/array ([x in-array xs]) (f x)))
135 |    ;;;
136 |    ;;; Data Representation
137 |    ;;;
138 |    (struct world        (player invaders bullets))
139 |    (struct body         (x y size))
140 |    (struct invader body (patrol-x speed-x))
141 |    (struct bullet  body (velocity-x velocity-y))
142 |    (struct player  body (dead?))
143 |    ; A world represents the state of the game.
144 |    ; A world consists of a player, a list of invaders and a list of bullets.
145 |    ; The invaders, the bullets and the player are all bodies.
146 |    ; All bodies are drawn as little squares.
147 |    ; A body contains the x and y coordinate og its upper left corner as well as its size.
148 |    ; Invaders move back and forth horisontally - this is called patrolling.
149 |    ; The field patrol-x determines how far the invader has moved from its original position.
150 |    ; A positive speed-x means rightward movement, and a negative sign leftward movement.
151 |    
152 |    ;;; Configuration
153 |    (define width           350)
154 |    (define height          400)
155 |    (define the-player-size  15)
156 |    (define the-bullet-size   3)
157 |    (define the-invader-size 15)
158 |    
159 |    ;;; Smart Constructors
160 |    
161 |    (define (new-bullet x y vx vy)
162 |      (bullet x y the-bullet-size vx vy))
163 |    
164 |    (define (new-invader x y)
165 |      (var [patrol-x 0] [speed-x 0.3])
166 |      (invader x y the-invader-size patrol-x speed-x))
167 |    
168 |    (define (new-player x y)
169 |      (var [size 15] [dead? #f])
170 |      (player x y size dead?))
171 |    
172 |    ;;;
173 |    ;;; MODEL
174 |    ;;;
175 | 
176 |    ;;; Creation
177 |    
178 |    ; create-world : -> world
179 |    ;  the initial world contains the player and a bunch of invaders
180 |    (define (create-world)
181 |      (world (create-player) (create-invaders) (array)))
182 |    
183 |    ; create-invaders : -> (list body)
184 |    ;   create array of twenty-four invaders
185 |    (define (create-invaders)
186 |      (for/array ([i in-range 0 24])
187 |        (var [x (+ 30 (* 30 (remainder i 8)))]) ; 8 columns
188 |        (var [y (+ 30 (* 30 (remainder i 3)))]) ; 3 rows
189 |        (new-invader x y)))
190 |    
191 |    ; create-player : -> player
192 |    (define (create-player)
193 |      (var [x (/ width 2.)]
194 |           [y (- height (* 2. the-player-size))])
195 |      (new-player x y))
196 |    
197 |    ;;; Updaters
198 |    
199 |    ; update-invader : invader -> invader
200 |    (define (update-invader i)
201 |      (match-define (invader x y size patrol-x speed-x) i)
202 |      ; If the invader is outside the patrol bound, we flip the speed
203 |      (var [speed-x-factor (if (and (<= 0 patrol-x) (<= patrol-x 29)) 1 -1)])
204 |      (var [new-speed-x    (* speed-x-factor speed-x)])
205 |      (var [new-x          (+        x new-speed-x)])
206 |      (var [new-patrol-x   (+ patrol-x new-speed-x)])
207 |      (invader new-x y size new-patrol-x new-speed-x))
208 |    
209 |    ; update-bullet : bullet -> bullet
210 |    (define (update-bullet b)
211 |      (match-define (bullet x y size vx vy) b)
212 |      (bullet (+ x vx) (+ y vy) size vx vy))
213 |    
214 |    ; update-player : world -> world
215 |    (define (update-player w)
216 |      (match-define (world p is bs) w)
217 |      (match-define (player x y size d) p)
218 |      (var [dead? (or d (collisions? p bs))])
219 |      (var [moved-player
220 |            (cond [d                   p]
221 |                  [(key-down? "left")  (player (- x 2.) y size dead?)]
222 |                  [(key-down? "right") (player (+ x 2.) y size dead?)]
223 |                  [else                (player x y size dead?)])])
224 |      (world moved-player is bs))
225 |    
226 |    ; spawn-invader-bullets : world -> world
227 |    ;   maybe create new bullets below an invader
228 |    (define (spawn-invader-bullets w)
229 |      (match-define (world p is bs) w)
230 |      (var [harder (/ (- 24 is.length) 1000)]) ; increases as invaders die
231 |      (var [maybe-spawn-bullet
232 |            (λ (i)
233 |              (match-define (invader x y size _ _) i)
234 |              ; once in a while, if no friends below, create a bullet
235 |              (if (and (> (Math.random) (- 0.995 harder))
236 |                       (not (invader-below? i is)))
237 |                  (bullet x (+ y size 1) 3 (- (Math.random) 0.5) 2.)
238 |                  #f))])
239 |      (var [new-bullets (filter-map maybe-spawn-bullet is)])
240 |      (world p is (append new-bullets bs)))
241 |    
242 |    (define (invader-below? i is)
243 |      (match-define (body x y size) i)
244 |      (for/or ([b in-array is])
245 |        (and (<= x b.x) (<= b.x (+ x size))
246 |             (> b.y (+ y size)))))
247 |    
248 |    ; spawn-player-bullet : world -> world
249 |    ;   a non-dead player shoots when space is pressed
250 |    (define (spawn-player-bullet w)
251 |      (match-define (world p is bs) w)
252 |      (cond
253 |        [(player-dead? p) w] ; no shooting, when dead
254 |        [(key-just-down? "space") ; space => new bullet
255 |         (match-define (player x y size d) p)
256 |         (var [b (new-bullet (+ x (/ size 2.)) y 0 -7)])
257 |         (bs.push b) ; sigh: not functional
258 |         (world p is bs)]
259 |        [else w]))
260 |    
261 |    ;;; UPDATES
262 |    
263 |    (define (update w)
264 |      (restart-on-r
265 |       (remove-colliding-bodies
266 |        (spawn-player-bullet
267 |         (spawn-invader-bullets
268 |          (update-player
269 |           (update-invaders
270 |            (update-bullets w))))))))
271 | 
272 |    (define (update-invaders w)
273 |      (var [is (world-invaders w)])
274 |      (struct-copy world w [invaders (map update-invader is)]))
275 |    
276 |    (define (update-bullets w)
277 |      (struct-copy world w [bullets (map update-bullet (world-bullets w))]))
278 |    
279 |    (define (restart-on-r w)
280 |      (if (key-down? "r")
281 |          (create-world)
282 |          w))
283 | 
284 |    ;;; Collision
285 |    
286 |    (define (colliding? b1 b2)
287 |      (match-define (body x1 y1 s1) b1)
288 |      (match-define (body x2 y2 s2) b2)
289 |      (not (or (= b1 b2)
290 |               (< (+ x1 s1) x2) (> x1 (+ x2 s2))
291 |               (< (+ y1 s1) y2) (> y1 (+ y2 s2)))))
292 |    
293 |    (define (collisions? x bs)
294 |      (for/or ([b in-array bs]) (colliding? x b)))
295 |    
296 |    (define (inside-screen? b)
297 |      (match-define (body x y size) b)
298 |      (and (< -40 x) (< x (+ width  40))
299 |           (< -40 y) (< y (+ height 40))))
300 |    
301 |    (define (remove-colliding-bodies w)
302 |      (match-define (world p is bs) w)
303 |      (var [no-bullet-collisons?  (λ (x) (not (collisions? x bs)))]
304 |           [no-invader-collisons? (λ (x) (not (collisions? x is)))])
305 |      (world p 
306 |             (filter no-bullet-collisons? is)
307 |             (filter inside-screen? ; remove non-visible bullets
308 |                     (filter no-invader-collisons? bs))))
309 | 
310 |    ;;; DRAWING
311 | 
312 |    ; draw-bodies : (list body) drawing-context -> void
313 |    ;   draw the bodies in the world w to the drawing context dc
314 |    (define (draw-bodies bs dc)
315 |      (for ([b in-array bs])
316 |        (match-define (body x y s) b)
317 |        (var [c (cond [(and (player? b) (player-dead? b)) "purple"]
318 |                      [(player? b)                        "blue"]
319 |                      [(invader? b)                       "red"]
320 |                      [else                               "black"])])
321 |        (:= dc "strokeStyle" c)
322 |        (:= dc "fillStyle" c)
323 |        (fill-rect dc x y s s)))
324 | 
325 |    (define (fill-rect dc x y w h)
326 |      (dot dc (fillRect (+ x 0.5) (+ y 0.5) w h)))
327 |    
328 |    (define (clear-all dc)
329 |      (:= dc "fillStyle" "white")
330 |      (fill-rect dc 0 0 width height))
331 |    
332 |    (define (draw-world w dc)
333 |      (match-define (world p is bs) w)
334 |      (clear-all dc)
335 |      (draw-bodies (append (array p) (append is bs)) dc))
336 |    
337 |    ;;; GUI STATE
338 | 
339 |    (define the-world (create-world))
340 | 
341 |    ;;; Keyboard
342 |    ; The keyboard state is kept in a hash table. 
343 |    ; Use key-down? to find out, whether a key is pressed or not.
344 |    (define the-keyboard  (array))
345 |    (define (key-up! k)   (:= the-keyboard k #f))
346 |    (define (key-down? k) (not (key-up? k)))
347 |    (define (key-up? k)
348 |      (var [state (ref the-keyboard k)])
349 |      (or (= state #f)          ; was released
350 |          (= state undefined))) ; never pressed     
351 |    (define (key-down! k)
352 |      (when (key-up? k) ; prevent two keydowns without a keyup inbetween
353 |        (:= the-keyboard k (Date.now))))
354 |    (define (key-just-down? k)
355 |      (var [old-ts (ref the-keyboard k)])
356 |      (var [new-ts (Date.now)])
357 |      (and (key-down? k)
358 |           (< (- new-ts old-ts) 20)))
359 | 
360 |    ;;;
361 |    ;;; BIG BANG FRAMEWORK
362 |    ;;;
363 | 
364 |    ;;; Canvas
365 | 
366 |    ; Key events sent to the canvas updates the information in the-keyboard.
367 |    ; Paint events calls draw-world. To prevent flicker we suspend flushing
368 |    ; while drawing commences.
369 |    (define (on-keydown event)
370 |      (key-down! (keycode->key event.keyCode)))
371 | 
372 |    (define (on-keyup event)
373 |      (key-up! (keycode->key event.keyCode)))
374 | 
375 |    (define (keycode->key k)
376 |      (cond
377 |        [(= k 38) "up"]
378 |        [(= k 40) "down"]
379 |        [(= k 37) "left"]
380 |        [(= k 39) "right"]
381 |        [(= k 32) "space"]
382 |        [(= k 65) "left"]  ; a
383 |        [(= k 83) "down"]  ; s
384 |        [(= k 87) "up"]    ; w
385 |        [(= k 68) "right"] ; d
386 |        [(= k 82) "r"]     ; r
387 |        [else     #f]))
388 | 
389 |    ;; Attach on-keydown and on-keyup to the canvas
390 |    (var [the-canvas          (document.getElementById "the-canvas")])
391 |    (var [the-drawing-context (the-canvas.getContext "2d")])
392 |    (dot the-canvas (addEventListener "keydown" on-keydown))
393 |    (dot the-canvas (addEventListener "keyup"   on-keyup))
394 |    ;;; Timer
395 |    
396 |    (define (on-timer)
397 |      (:= the-world (update the-world))
398 |      (draw-world the-world the-drawing-context))
399 |    
400 |    ; Start a timer. Each time the timer triggers, the world is updated.
401 |    (var [interval-id (window.setInterval on-timer 20)]) ; in milliseconds
402 |    
403 | 
404 |    ;;; Keyboard
405 |    ; Let the canvas grab the keyboard focus from the start.
406 |    ; Note: This requires a tabindex attribute in the html.
407 |    (the-canvas.focus)
408 |    ))
409 | 
410 | ;;; Urls for JavaScript and CSS libraries used in this example.
411 | 
412 | (define (generate-html)
413 |   @~a{
414 |  <!DOCTYPE html>
415 |  <html lang="en">
416 |    <head> <meta charset="utf-8">
417 |           <title>Space Invaders</title>
418 |   </head>
419 |   <body>   
420 |      <h1>Space Invaders in Urlang</h1>
421 |      <p>Use <tt>left</tt> or <tt>right</tt> to move</p>
422 |      <p>Use <tt>space</tt> to shoot.</p>
423 |      <p>Use <tt>r</tt> to restart</p>
424 |      <p>See source code on Github:
425 |         <a href=
426 |    "https://github.com/soegaard/urlang/blob/master/urlang-examples/space-invaders/space-invaders.rkt">
427 |         space-invaders.rkt</a>
428 |      <p><canvas id="the-canvas" width="350" height="400" tabindex="1"/></p>
429 |      <script>@file->string{space-invaders.js}</script>
430 |  </body>
431 |  </html>})
432 | 
433 | 
434 | ;;; Conveniency
435 | 
436 | ; In DrRacket (send-url/contents some-html) will display the 
437 | ; html in a browser - saves time.
438 | 
439 | (require net/sendurl)
440 | 
441 | (send-url/contents (generate-html))
442 | 


--------------------------------------------------------------------------------
/urlang-test/test-extra.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (require rackunit urlang urlang/extra)
 4 | 
 5 | (current-urlang-run?                           #t) ; run using Node?
 6 | (current-urlang-echo?                          #t) ; print generated JavaScript?
 7 | (current-urlang-console.log-module-level-expr? #t) ; print top-level expression?
 8 | 
 9 | (define (rs s) (read (open-input-string s)))
10 | 
11 | ;;;
12 | ;;; SCOND
13 | ;;;
14 | 
15 | (current-urlang-console.log-module-level-expr? #f)
16 | (check-equal? (rs (urlang (urmodule scond
17 |                             (var [a 0] [b 0])
18 |                             (scond [#f (:= a 10)] [0 (:= a 1)] [#t (:= a 10)]) ; a=1
19 |                             (scond [#f 4] [else (:= b 10)])                    ; b=10
20 |                             (scond)
21 |                             (console.log (+ a b)))))
22 |               11)
23 | 
24 | (current-urlang-console.log-module-level-expr? #t)
25 | 
26 | ;;;
27 | ;;; COND
28 | ;;;
29 | 
30 | (check-equal? (rs (urlang (urmodule scond
31 |                             (+ (cond [#f 10] [0 1] [#t 10])    ;   1
32 |                                (cond [#f 4] [else 10])         ;  10
33 |                                (cond [else 100])))))           ; 100                 
34 |               111)
35 | 


--------------------------------------------------------------------------------
/urlang-test/urlang-tests.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | ;;;
  3 | ;;; URLANG BASE TESTS
  4 | ;;;
  5 | 
  6 | ;; Run this file to test urlang.rkt.
  7 | ;; No output means no errors.
  8 | 
  9 | (require rackunit urlang)
 10 | 
 11 | (current-urlang-run?                           #t) ; run using Node?
 12 | (current-urlang-echo?                          #t) ; print generated JavaScript?
 13 | (current-urlang-console.log-module-level-expr? #t) ; print top-level expression?
 14 | 
 15 | (define (rs s) (read (open-input-string s)))
 16 | 
 17 | ;;;
 18 | ;;; DATUMS
 19 | ;;;
 20 | 
 21 | (check-equal? (rs (urlang (urmodule test1 5)))     5)
 22 | (check-equal? (rs (urlang (urmodule test1 "foo"))) 'foo)
 23 | 
 24 | ;;;
 25 | ;;; EXPRESSIONS
 26 | ;;;
 27 | 
 28 | ;; Application of infix operator
 29 | (check-equal? (rs (urlang (urmodule t1 (+ 5 1))))  6)
 30 | ;; Application of unary operator
 31 | (check-equal? (rs (urlang (urmodule t2 (- 5))))   -5)
 32 | ;; Application of defined function
 33 | (check-equal? (rs (urlang (urmodule t3 (define (add x y) (+ x y)) (add 1 2)))) 3)
 34 | ;; Application of array
 35 | (check-equal? (urlang (urmodule t4 (array 1 2 3))) "[ 1, 2, 3 ]\n")
 36 | ;; Application of ref (array reference)
 37 | (check-equal? (rs (urlang (urmodule t5 (ref (array 1 2 3) 0)))) 1)
 38 | ;; Application of abstraction
 39 | (check-equal? (rs (urlang (urmodule t6 ((lambda (a b) (+ a b)) 1 2)))) 3)
 40 | ;; Assignments
 41 | (check-equal? (rs (urlang (urmodule t7 (var v) (:= v 3) v))) 3)
 42 | (check-equal? (rs (urlang (urmodule t8 (var (v 4)) (+= v 3) v))) 7)
 43 | ;; If (ternary)
 44 | (check-equal? (rs (urlang (urmodule t9 (if (= 3 3) 1 2)))) 1)
 45 | (check-equal? (rs (urlang (urmodule t10 (if (= 3 4) 1 2)))) 2)
 46 | ;; Begin
 47 | (check-equal? (rs (urlang (urmodule t11 (begin 1 2)))) 2)
 48 | (check-equal? (rs (urlang (urmodule t12 (+ 3 (begin 1 2))))) 5)
 49 | ;; Let
 50 | (check-equal? (rs (urlang (urmodule t13 (let ((x 5)) (+ x 1))))) 6)
 51 | (check-equal? (rs (urlang (urmodule t14 (let ((x 5)) (let ((x 2)) (+ x 1)))))) 3)
 52 | ;; Lambda
 53 | (check-equal? (rs (urlang (urmodule t15 ((lambda (x) (+ x 1)) 2)))) 3)
 54 | (check-equal? (rs (urlang (urmodule t16 ((lambda () 4)))))          4)
 55 | ; Lambda with optional arguments
 56 | (check-equal? (rs (urlang (urmodule t17 ((lambda (x [y 2]) (+ x y)) 3)))) 5)
 57 | (check-equal? (rs (urlang (urmodule t18 ((lambda (x [y 2]) (+ x y)) 3 4)))) 7)
 58 | ; Object literals
 59 | ;(check-equal? (rs (urlang (urmodule t19 (ref (object [foo 10] [11 12] ["bar" 13]) "foo")))) 10)
 60 | ;(check-equal? (rs (urlang (urmodule t20 (ref (object [foo 10] [11 12] ["bar" 13]) 11))))    12)
 61 | ;(check-equal? (rs (urlang (urmodule t21 (ref (object [foo 10] [11 12] ["bar" 13]) "bar")))) 13)
 62 | ;; Defined functions with optional arguments
 63 | (check-equal? (rs (urlang (urmodule t22 (define (add x [y 1]) (+ x y)) (add 3)))) 4)
 64 | ;; Dot notation
 65 | (check-equal? (rs (urlang (urmodule t23
 66 |                             (define t (object [n 1]
 67 |                                               [o (object [m 10]
 68 |                                                          [f (λ (y) (+ y 97))])]
 69 |                                               [g (λ (x)
 70 |                                                    (object [m (+ x 996)]
 71 |                                                            [o (object [h (λ (y) (+ x y 9991))])]))]))
 72 |                             (+ (dot t n)              ;     1
 73 |                                (dot t o m)            ;    10
 74 |                                (dot t o (f 3))        ;   100
 75 |                                (dot t (g 4) m)        ;  1000
 76 |                                (dot t (g 4) o (h 5))) ; 10000
 77 |                             )))
 78 |               11111)
 79 | (check-equal? (rs (urlang (urmodule t24 (var [o (object [foo-bar 3])]) o.foo-bar))) 3)
 80 |                                               
 81 | 
 82 | ;;;
 83 | ;;; EXPORT AND IMPORT
 84 | ;;;
 85 | 
 86 | (check-equal? (urlang       ; test export
 87 |                (urmodule factorial
 88 |                  (export fact)
 89 |                  (define (fact n) (if (= n 0) 1 (* n (fact (- n 1)))))))
 90 |               "")
 91 | 
 92 | ; TODO this example doesn't run due to (require ...) used as an expression.
 93 | ; Introduce a require specification such that (require (node F "./factorial.js")) is possible.
 94 | #;(check-equal? (rs
 95 |                (urlang ; test import and require generated module
 96 |                 (urmodule test-factorial
 97 |                   (import require)
 98 |                   (define F (require "./factorial.js"))
 99 |                   (F.fact 5))))
100 |               120)
101 | 
102 | ;;;
103 | ;;; STATEMENTS
104 | ;;;
105 | 
106 | ;; #26 - This should emit a warning in the console
107 | (check-equal? (rs (urlang (urmodule test-duplicate (define a (object [foo 1] [foo 2]))
108 |         (dot a foo)))) 1)
109 | 
110 | ;; While
111 | (check-equal? (rs ; test while
112 |                (urlang (urmodule test-while
113 |                          (define a (array 1 2 3 4 5))
114 |                          (var (sum 0) (i 0) (n a.length))
115 |                          (while (< i n)
116 |                                 (+= sum (ref a i))
117 |                                 (+= i 1))
118 |                          sum)))
119 |               15)
120 | ;; DoWhile
121 | (check-equal? (rs ; test do-while
122 |                (urlang (urmodule test-do-while
123 |                          (define a (array 1 2 3 4 5))
124 |                          (var (sum 0) (i 0) (n a.length))
125 |                          (do-while (< i n)
126 |                                    (+= sum (ref a i))
127 |                                    (+= i 1))
128 |                          sum)))
129 |               15)
130 | ;; Block
131 | (check-equal? (rs (urlang (urmodule test-block
132 |                             (var (a 1) (b 2))
133 |                             (block (:= a 11) (:= b 12))
134 |                             (+ a b))))
135 |               23)
136 | 
137 | ;;;
138 | ;;; MACROS
139 | ;;;
140 | 
141 | (require syntax/parse)
142 | 
143 | ;; SYNTAX
144 | ;;  As expression: (when <expr> <expr> ...)
145 | ;;  As statement:  (when <expr> <statement> ...)
146 | (define-urlang-macro when
147 |   (λ (stx)
148 |     (syntax-parse stx
149 |       [(_when e0 e ...)
150 |        ; (displayln (list 'when 'context: (macro-expansion-context)))
151 |        (match (macro-expansion-context) ; one of 'module-level, 'statement, 'expression
152 |          ['expression (syntax/loc stx (if  e0 (begin e ...) undefined))]
153 |          [_           (syntax/loc stx (sif e0 (block e ...) (sempty)))])])))
154 | 
155 | (check-equal? (rs (urlang (urmodule test-when-macro
156 |                             (var (a 1))
157 |                             (when #t (:= a 2) (:= a 3))  ; module-level context
158 |                             (block (when #f (:= a 4)))   ; statement context
159 |                             (:= a (+ a (when #t 4)))     ; expression context
160 |                             a)))
161 |               7)
162 | 
163 | #;(urlang
164 |    (urmodule label-break
165 |      (var i j)
166 |      (:= i 0)
167 |      (label loop1
168 |             (while (< i 3)
169 |                    (label loop2
170 |                           (block
171 |                            (:= j 0)
172 |                            (while (< j 3)
173 |                                   (sif (and (= i 1) (= j 1))
174 |                                        (break loop1)
175 |                                        (block))
176 |                                   (console.log (+ "i = " i ", j = " j))
177 |                                   (+= j 1))))
178 |                    (+= i 1)))))
179 | 
180 | #;(urlang
181 |  (urmodule label-continue
182 |    (var (i 0) (n 0))
183 |    (while (< i 5)
184 |           (+= i 1)
185 |           (sif (= i 3) (continue) (block))
186 |           (+= n i))
187 |    n))
188 | 
189 | 
190 | #;(urlang
191 |    (urmodule label-continue
192 |      (define (foo x)
193 |        (sif (= x 42) (return 43) 44)
194 |        45)
195 |      (foo 42)))
196 |  ; 43 is expected
197 | 
198 | (urlang (urmodule variadic
199 |           (define (f y . ys)
200 |             ys)
201 |           (f 1 2 3 4)))
202 | ; => "[ 2, 3, 4 ]\n"
203 | 
204 | (urlang (urmodule variadic
205 |           ((lambda (y . ys) ys)
206 |            1 2 3 4)))
207 | ; => "[ 2, 3, 4 ]\n"
208 | 
209 | (urlang (urmodule variadic
210 |           ((lambda y y)
211 |            1 2 3 4)))
212 | ; => "[ 1, 2, 3, 4 ]\n"
213 | 
214 | 


--------------------------------------------------------------------------------
/urlang/README.md:
--------------------------------------------------------------------------------
 1 | Urlang
 2 | ======
 3 | Urlang is a language that compiles to strict JavaScript (ES5 aka EcmaScript 5).
 4 | The core constructs of Urlang matches the constructs in JavaScript almost one-to-one.
 5 | 
 6 | Here are the differences:
 7 |   - References to undeclared identifiers signal an error at compile time
 8 |     (use DrRacket and you can jump directly to the error)
 9 |   - The names identifiers are free to use:  -, *, + etc.
10 |     Names are "mangled" to produce legal JavaScript names in the output.
11 |     For example:  foo-bar becomes foo_bar.
12 |     See the definition of mangle in main.rkt for details.
13 |   - Functions allow optional arguments.
14 |   - Comparisions with = produces === in the JavaScript code.
15 |   - if counts 0 as a true value
16 | 
17 | The output of an Urlang program should always be a legal JavaScript program.
18 | If you encounter a program that produces an illformed JavaScript program,
19 | please file a bug.
20 | 
21 | Besides the core constructs, you have the option of adding your own
22 | constructs with define-urlang-macro. See "extra.rkt" for examples.
23 | 
24 | ES6
25 | ---
26 | The construct  import-from  produces ES6 import commands.
27 | If you use it, run Babel afterwards to produce ES5 code.
28 | 
29 | main.rkt
30 | --------
31 | Usage: (require urlang)
32 | 
33 | This contains the implementation of the urlang form.
34 | All core urlang forms are implemented here - so look
35 | here for the exact syntax of forms.
36 | 
37 | The urlang form compiles urmodule forms into JavaScript.
38 | The compiler uses the Nanopass framework.
39 | 
40 | extra.rkt
41 | ---------
42 | Usage: (require urlang/extra)
43 | 
44 | Contains a few extra urlang forms implemented as macros.
45 | These include the expressions:
46 |   begin0, when, unless, cond, case, letrec, let*
47 | And the statements:
48 |   swhen, sunless, scond
49 | 
50 | for.rkt
51 | -------
52 | Usage: (require urlang/for)
53 | 
54 | This implements a racket-like for construct.
55 | Parallel loops:
56 |   for, for/array, for/or for/and, for/sum, for/product
57 | Nested loops:
58 |   for*, ...
59 | Clauses include:
60 |   in-range, in-naturals, in-value, in-array, in-string
61 | See for.rkt for precise syntax
62 |   
63 | html.rkt
64 | --------
65 | Usage: (require urlang/html)
66 | 
67 | Create html using @-syntax.
68 | Purpose orthogonal to Urlang as such.
69 | Feel free to use whatever way of producing html as you like.
70 | 
71 | 
72 | 
73 | 


--------------------------------------------------------------------------------
/urlang/extra.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | (require urlang syntax/parse racket/syntax)
  3 | (provide else)
  4 | ;;;
  5 | ;;; URLANG EXTRA
  6 | ;;;
  7 | 
  8 | ;; This module provide a few constructs which are simple to 
  9 | ;; translate to JavaScript.
 10 | 
 11 | ;; These constructs can be used as expressions:
 12 | 
 13 | ;     (begin0 expr statement ...)
 14 | ;     (when   test statement ... expr)
 15 | ;     (unless test statement ... expr)
 16 | 
 17 | ;     (cond [test statement ... expr] ...)
 18 | ;     (case val-expr clause ...)
 19 | ;          where clause is  [(datum ...) statement ... expr]
 20 | ;                       or  [else        statement ... expr]
 21 | ;     (letrec ([id val-expr] ...) statement ... expr)
 22 | ;     (let*   ([id val-expr] ...) statement ... expr)
 23 | 
 24 | ;; These constructs can be used as statements:
 25 | ;;     (swhen   test statement ...)
 26 | ;;     (sunless test statement ...)
 27 | ;;     (scond  [test statement ...] ...)
 28 | 
 29 | 
 30 | ;; SYNTAX  (cond [test statement ... expr] ...)
 31 | ;;         The last clause can be an else clause
 32 | ;;   Like cond in Racket. The right hand sides are in a new scope.
 33 | 
 34 | (define-urlang-macro cond
 35 |   (λ (stx)
 36 |     (syntax-parse stx
 37 |       #:datum-literals (else)
 38 |       [(_cond)
 39 |        (syntax/loc stx
 40 |          undefined)]
 41 |       [(_cond [else then-body ...])
 42 |        (syntax/loc stx
 43 |          (let () then-body ...))]
 44 |       [(_cond [test] clause ...)
 45 |        (syntax/loc stx
 46 |          (let ([t test]) (if t t (let () clause ...))))]
 47 |       [(_cond [test statement ... expr] clause ...)
 48 |        (syntax/loc stx
 49 |          (if test
 50 |              (let () statement ... expr)
 51 |              (cond clause ...)))])))
 52 | 
 53 | ;; SYNTAX  (scond [test statement ...] ...)
 54 | ;;   Like cond in Racket. Return values of rhs not used.
 55 | ;;         The last clause can be an else clause
 56 | (define-urlang-macro else (λ (stx) (raise-syntax-error 'else "used out of context")))
 57 | 
 58 | (define-urlang-macro scond
 59 |   (λ (stx)
 60 |     (syntax-parse stx
 61 |       #:datum-literals (else)
 62 |       [(_scond)
 63 |        (syntax/loc stx
 64 |          undefined)]
 65 |       [(_scond [else then-body ...])
 66 |        (syntax/loc stx
 67 |          (let () then-body ...))]
 68 |       [(_scond [test] clause ...)
 69 |        (syntax/loc stx
 70 |          (sif t undefined (scond clause ...)))]
 71 |       [(_scond [test statement ...] clause ...)
 72 |        (syntax/loc stx
 73 |          (sif test
 74 |               (let () statement ...)
 75 |               (scond clause ...)))])))
 76 | 
 77 | ;;; 3.15 Sequencing
 78 | 
 79 | ;; SYNTAX (begin0 expr statement ...)
 80 | ;;   Expression evalues expr, statement, ... in order.
 81 | ;;   Returns the result of evaluating expr as result.
 82 | (define-urlang-macro begin0
 83 |   (λ (stx)
 84 |     (syntax-parse stx
 85 |       [(_begin0 expr statement ...)
 86 |        (syntax/loc stx
 87 |          (let ([t expr]) statement ... t))])))
 88 | 
 89 | 
 90 | ;;; 3.16 Guarded Evaluation
 91 | 
 92 | ;; SYNTAX (when test-expr statement ... expr)
 93 | ;;   This form expands to an expression.
 94 | (define-urlang-macro when
 95 |   (λ (stx)
 96 |     (syntax-parse stx
 97 |       [(_when test statement ... expr)
 98 |        (syntax/loc stx
 99 |          (if test
100 |              (let () statement ... expr)
101 |              undefined))])))
102 | 
103 | ;; SYNTAX (swhen test-expr statement ...)
104 | ;;   This form expands to a statment (Statement when).
105 | (define-urlang-macro swhen
106 |   (λ (stx)
107 |     (syntax-parse stx
108 |       [(_swhen test statement ...)
109 |        (syntax/loc stx
110 |          (sif test
111 |               (block statement ...)
112 |               (sempty)))])))
113 | 
114 | ;; SYNTAX (unless test-expr statement ... expr)
115 | ;;   This form expands to an expression.
116 | (define-urlang-macro unless
117 |   (λ (stx)
118 |     (syntax-parse stx
119 |       [(_unless test statement ... expr)
120 |        (syntax/loc stx
121 |          (when (not test) statement ... expr))])))
122 | 
123 | ;; SYNTAX (sunless test-expr statement ...)
124 | ;;   This form expands to a statment (Statement unless).
125 | (define-urlang-macro sunless
126 |   (λ (stx)
127 |     (syntax-parse stx
128 |       [(_sunless test statement ...)
129 |        (syntax/loc stx
130 |          (swhen (not test) statement ...))])))
131 | 
132 | ;;; 3.9 Local Binding
133 | 
134 | ;; SYNTAX (letrec ([id val-expr] ...) statement ... expr)
135 | 
136 | (define-urlang-macro letrec
137 |   (λ (stx)
138 |     (syntax-parse stx
139 |       [(_letrec ([id val-expr] ...) statement ... expr)
140 |        (with-syntax ([(t ...) (generate-temporaries (syntax (id ...)))])
141 |           (syntax (let ([id #f] ...)
142 |                     (let ([t val-expr] ...)
143 |                       (:= id t) ...
144 |                       (let () statement ... expr)))))])))
145 | 
146 | 
147 | (define-urlang-macro let*
148 |   (λ (stx)
149 |     (syntax-parse stx
150 |       [(_let* () statement ... expr)
151 |        (syntax/loc stx
152 |          (let () statement ... expr))]
153 |       [(_let* ([id val-expr] clause ...) statement ... expr)
154 |        (syntax/loc stx
155 |          (let ([id val-expr])
156 |            (let* (clause ...) statement ... expr)))])))
157 | 
158 | (define-urlang-macro case
159 |   (λ (stx)
160 |     (syntax-parse stx
161 |       #:literals (else)
162 |       [(_case val-expr clause ...)
163 |        (syntax/loc stx
164 |          (let ([t val-expr])
165 |            (case-helper t clause ...)))])))
166 | 
167 | (define-urlang-macro case-helper
168 |   (λ (stx)
169 |     (syntax-parse stx
170 |       #:literals (else)
171 |       [(_case-helper t [else statement ... expr] clause ...)
172 |        (syntax/loc stx
173 |          (let () statement ... expr))]
174 |       [(_case-helper t [(datum ...) statement ... expr] clause ...)
175 |        (syntax/loc stx
176 |          (if (or #f (= t datum) ...)
177 |              (let () statement ... expr)
178 |              (case-helper t clause ...)))]
179 |       [(_case-helper t)
180 |        (syntax/loc stx
181 |          undefined)])))
182 | 
183 | ; SYNTAX (class* heritage [(pn a ...) #:super b0 b ...] ...)
184 | ; SYNTAX (class* heritage [(pn a ...)            b ...] ...)
185 | ;   like (class heritage [(pn a ...) b ...] ...)
186 | ;   but in b ... _this is bound to this.
187 | ; Note: the keyword  this  does not have lexical scope in JavaScript,
188 | ;       so it is convenient to have an identifier _this that does
189 | ;       have lexical scope.
190 | (define-urlang-macro class*
191 |   (λ (stx)        
192 |     (syntax-parse stx
193 |       [(_class heritage clauses ...) ; heritage is either x or (x x)
194 |        (define clauses-list (syntax->list #'(clauses ...)))       
195 |        (define (constructor-clause? clause)
196 |          (syntax-parse clause
197 |            [ [(pn . args) #:constructor b ... bn] #t]
198 |            [ _                                    #f]))
199 |        ; the constructor needs special handling
200 |        (define the-constructor-clause (findf          constructor-clause?  clauses-list))
201 |        (define the-other-clauses      (filter (negate constructor-clause?) clauses-list))
202 |        ; the normal method clauses is wrappen in (let ([this this]) ...)
203 |        ; in order to make this have lexical scope in the body
204 |        (define transformed-other-clauses
205 |          (for/list ([clause (or the-other-clauses '())])
206 |            (syntax-parse clause
207 |              [ [(pn . args) #:super statement . b]
208 |                (with-syntax ([this (format-id #'b (mangle #' this))])
209 |                  #'[(pn . args) statement (let ([this this]) . b)])]
210 |              [ [(pn . args) . b]
211 |                (with-syntax ([this (format-id #'b (mangle #' this))])
212 |                  #'[(pn . args)           (let ([this this]) . b)])]
213 |              [_ (raise-syntax-error 'class* "huh" clause)])))
214 |        ; The constructor needs to call super, and since this can't be referenced
215 |        ; before super has been called, we don't change the binding of this except
216 |        ; in the last expression. (If there is only one expression, we dont bind this.
217 |        ; Furthermore we bind this to the instance in all the other methods.
218 |        (define transformed-constructor-clause
219 |          (syntax-parse the-constructor-clause
220 |            [ [(pn . args) #:constructor b ... bn]
221 |              (define the-methods-names
222 |                (for/list ([clause the-other-clauses])
223 |                  (syntax-parse clause [ [(pn . _) . _] #'pn])))
224 |              (with-syntax ([(method-str ...) (map mangle the-methods-names)]
225 |                            [(method     ...)             the-methods-names]
226 |                            [this         (format-id #'bn (mangle #'this))])
227 |                #'[(pn . args)
228 |                   b ...
229 |                   (:= this method-str ((dot this method bind) this)) ...
230 |                   (let ([this this]) bn)])]))
231 |          (with-syntax ([(tc ...) transformed-other-clauses]
232 |                        [cc       transformed-constructor-clause])
233 |            (syntax/loc stx
234 |              (class heritage cc tc ...)))])))
235 | 


--------------------------------------------------------------------------------
/urlang/for.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | 
  3 | (require urlang)
  4 | (require syntax/parse syntax/stx)
  5 | (provide add-clause-handler!)
  6 | (provide in-array in-naturals in-range in-string in-value)
  7 | 
  8 | (define-syntax in-array    (λ (stx) (raise-syntax-error 'in-array    "used out of context" stx)))
  9 | (define-syntax in-naturals (λ (stx) (raise-syntax-error 'in-naturals "used out of context" stx)))
 10 | (define-syntax in-range    (λ (stx) (raise-syntax-error 'in-range    "used out of context" stx)))
 11 | (define-syntax in-string   (λ (stx) (raise-syntax-error 'in-string   "used out of context" stx)))
 12 | (define-syntax in-value    (λ (stx) (raise-syntax-error 'in-value    "used out of context" stx)))
 13 | (define-syntax in-racket-string
 14 |                            (λ (stx) (raise-syntax-error 'in-racket-string "used out of context" stx)))
 15 | 
 16 | 
 17 | (define-literal-set for-keywords (in-array in-range in-naturals in-string in-value))
 18 | (define for-keyword? (literal-set->predicate for-keywords))
 19 | (define-syntax-class ForKeyword #:opaque (pattern x #:fail-unless (for-keyword? #'x) #f))
 20 | 
 21 | ;;; Tests
 22 | ; See tests/test-for.rkt for tests.
 23 | 
 24 | ;;;
 25 | ;;; Racket for-loops for Urlang.
 26 | ;;;
 27 | 
 28 | ; The standard JavaScript for-loops aren't as enjoyable to use
 29 | ; as the Racket counterpart. This module implement Racket style
 30 | ; for-loops for Urlang (which compiles to JavaScript).
 31 | 
 32 | ; SYNTAX
 33 | ; Parallel loops:
 34 | ;   (for         (clause ...) <statement-or-break> ...)
 35 | ;   (for/array   (clause ...) <statement-or-break> ... <expression>)
 36 | ;   (for/or      (clause ...) <statement-or-break> ... <expression>)
 37 | ;   (for/and     (clause ...) <statement-or-break> ... <expression>)
 38 | ;   (for/sum     (clause ...) <statement-or-break> ... <expression>)
 39 | ;   (for/product (clause ...) <statement-or-break> ... <expression>)
 40 | ; Nested loops:
 41 | ;   (for* (clause ...) <statement-or-break> ...)
 42 | ;   ...
 43 | 
 44 | ; <statement-or-break> is a either
 45 | ;    a statement
 46 | ;    #:break <guard-expression>
 47 | ; If the guard expression evaluates to true, the loop is done.
 48 | ; Any statements after the #:break <guard> are not evaluated.
 49 | 
 50 | ; CLAUSES
 51 | 
 52 | ;  [x in-range from to]
 53 | ;  [x in-range from to step]
 54 | ;                       evaluates the expressions from and to
 55 | ;                       binds x to from, from+1, ..., to-1
 56 | ;                       Note: from and to are only evaluated once.
 57 | ;                       If step is present the sequence is from, from+step, ...
 58 | ;  [x in-naturals from]
 59 | ;                       binds x to from, from+1, ...
 60 | ;  [x in-value expr]
 61 | ;                       binds x to the result of expr
 62 | ;  [x in-array expr]
 63 | ;                       evaluates expr
 64 | ;                       if the result is not an array, an error is thrown
 65 | ;                       binds x to the elements of the array one at a time
 66 | ;  [x in-string expr]
 67 | ;                       evaluates expr
 68 | ;                       if the result is not a string, an error is thrown
 69 | ;                       binds x to one character at a time
 70 | 
 71 | 
 72 | 
 73 | ; The main idea is best illustrated with an example.
 74 | ; When I write this:
 75 | 
 76 | #;(for ([x in-range 3 7]    ; the x and y loop run in parallel
 77 |         [y in-array ys])
 78 |     (console.log (+ x y)))
 79 | 
 80 | ; I mean:
 81 | 
 82 | #;(block/let
 83 |    ;; initial states and helper variables
 84 |    (var [i 3]                                 ; index i counts from 3
 85 |         [t 7]                                 ; to 7 (exclusive)
 86 |         [a ys]                                ; store the array in a
 87 |         [n a.length]                          ; used by array condition test         
 88 |         [t 0])                                ; index into the array (counts from 0 to n (exclusive))
 89 |    (while
 90 |     ;; if any of the clauses are exhausted the loop ends
 91 |     (and (< i 7)
 92 |          (< t n))
 93 |     ;; state to value
 94 |     (let ([x i]               
 95 |           [y (ref a t)])
 96 |       ;; statements from for body
 97 |       (console.log (+ x y))
 98 |       ;; step states forward
 99 |       (+= i 1)                
100 |       (+= t 1))))
101 | 
102 | ; The JavaScript becomes:
103 | ;    {var i=3,t=7,a=ys,n=a.length,i_4=0;
104 | ;     while( (true && (i<t) && (i_4<n) )){
105 | ;       ((function(x,y){                    // let x=i, y=a[i_4]
106 | ;           (console.log((x+y)));
107 | ;           (i+=1);
108 | ;           return (i_4+=1);
109 | ;           })(i,a[i_4]));
110 | ;       };
111 | ;     undefined;                           // due to expression context
112 | ;     }
113 | 
114 | 
115 | (define-urlang-macro block/let
116 |   ; expand to (let () ... undefined) in an expresion context
117 |   ; and to    (block  ...)           otherwise
118 |   (λ (stx)
119 |     (syntax-parse stx
120 |       [(_block/let more ...)
121 |        (match (macro-expansion-context)
122 |          ['expression (syntax/loc stx (let () more ... undefined))]
123 |          [_           (syntax/loc stx (block  more ...))])])))
124 | 
125 | (define (handle-in-value clause) ; generates a single value
126 |   (syntax-parse clause
127 |     #:literal-sets (for-keywords)
128 |     [[x in-value expr]
129 |      #'(([t #t])           ; list of var clauses to create initial state
130 |         t                  ; termination condition (#t = never terminate)
131 |         ([x expr])         ; let bindings (needs to bind x)
132 |         ((:= t #f)))]))
133 | 
134 | (define (handle-in-naturals clause)
135 |   (syntax-parse clause
136 |     #:literal-sets (for-keywords)
137 |     [[x in-naturals from]
138 |      #'(([i from])      ; list of var clauses to create initial state
139 |         #t              ; termination condition (#f means terminate)
140 |         ([x i])         ; let bindings (needs to bind x)
141 |         ((+= i 1)))]))
142 | 
143 | (define (handle-in-range clause)
144 |   (syntax-parse clause
145 |     #:literal-sets (for-keywords)
146 |     [[x in-range from]
147 |      (raise-syntax-error 'in-range "expected: in-range from to  or  in-range from to step")]
148 |     [[x in-range from to]
149 |      #'(([i_ from]          ; list of var clauses to create initial state
150 |          [t_ to])
151 |         (< i_ t_)            ; termination condition
152 |         ([x i_])            ; let bindings (needs to bind x)
153 |         ((+= i_ 1)))]       ; statements to step state forward
154 |     [[x in-range from to step]
155 |      #'(([i_ from]          ; list of var clauses to create initial state
156 |          [t_ to])
157 |         (< i_ t_)            ; termination condition
158 |         ([x i_])            ; let bindings (needs to bind x)
159 |         ((+= i_ step)))]))  ; statements to step state forward
160 | 
161 | (define (handle-in-array clause)
162 |   (syntax-parse clause
163 |     #:literal-sets (for-keywords)
164 |     [[x in-array array-expr]
165 |      #'(([a array-expr]       ; list of var clauses to create initial state
166 |          [n a.length]
167 |          [i 0])
168 |         (< i n)              ; termination condition
169 |         ([x (ref a i)]) ; let bindings (needs to bind x)
170 |         ((+= i 1)))]))  ; statements to step state forward
171 | 
172 | 
173 | ;; This handles "Racket strings" not JavaScript strings (see compiler-rjs)
174 | (define (handle-in-racket-string clause)
175 |   (syntax-parse clause
176 |     #:literal-sets (for-keywords)
177 |     [[x in-racket-string string-expr]
178 |      #'(([s string-expr]       ; list of var clauses to create initial state
179 |          [n s.length]
180 |          [i 0])
181 |         (< i n)                ; termination condition
182 |         ([x (string-ref s i)]) ; let bindings (needs to bind x) +1 to skip tag
183 |         ((+= i 1)))]))
184 | 
185 | (define (handle-in-string clause)
186 |   (syntax-parse clause
187 |     #:literal-sets (for-keywords)
188 |     [[x in-string array-expr]
189 |      #'(([a array-expr]       ; list of var clauses to create initial state
190 |          [n a.length]
191 |          [i 0])
192 |         (< i n)              ; termination condition
193 |         ([x (ref a i)]) ; let bindings (needs to bind x)
194 |         ((+= i 1)))]))  ; statements to step state forward
195 | 
196 | 
197 | (define clause-handlers-ht (make-hasheq)) ; symbol -> handler
198 | (define (add-clause-handler! name handler)
199 |   (hash-set! clause-handlers-ht name handler))
200 | 
201 | (define (get-clause-handler-from-ht name)
202 |   (hash-ref clause-handlers-ht name #f))
203 | 
204 | (define (clause->handler-name clause-stx)
205 |   (define (starts-with-in-? x)
206 |     (regexp-match #rx"^in-" (symbol->string x)))
207 |   (for/first ([name (map syntax-e (syntax->list clause-stx))]
208 |               #:when (starts-with-in-? name))
209 |     name))
210 |     
211 | (define (get-clause-handler clause-stx)
212 |   (match (clause->handler-name clause-stx)
213 |     [#f   (raise-syntax-error 'for "unknown clause" clause-stx)]
214 |     [name (get-clause-handler-from-ht name)]))
215 | 
216 | (add-clause-handler! 'in-range           handle-in-range)
217 | (add-clause-handler! 'in-array           handle-in-array)
218 | (add-clause-handler! 'in-naturals        handle-in-naturals)
219 | (add-clause-handler! 'in-value           handle-in-value)
220 | (add-clause-handler! 'in-string          handle-in-string)
221 | (add-clause-handler! 'in-racket-string   handle-in-racket-string)
222 | 
223 | (define (expand-for stx)   ; parallel for
224 |   (define (is-break? x) (or (eq? x '#:break) (and (syntax? x) (is-break? (syntax-e x)))))
225 |   (define (rewrite-breaks statement-or-breaks)
226 |     (match statement-or-breaks
227 |       ['()                                   '()]
228 |       [(list  (? is-break? b))               (raise-syntax-error
229 |                                               'foo "missing guard expression after #:break" b)]
230 |       [(list* (? is-break? b) guard more)    (cons #`(sif #,guard
231 |                                                           (block (:= cont #f) (break skip))
232 |                                                           (sempty))
233 |                                                    (rewrite-breaks more))]
234 |       [(list* statement more)                (cons statement
235 |                                                    (rewrite-breaks more))]))
236 |   (syntax-parse stx
237 |     [(_for () statement-or-break ...)
238 |      (define break-used? (ormap is-break? (syntax->list #'(statement-or-break ...))))
239 |      (with-syntax ([(stat ...) (rewrite-breaks (syntax->list #'(statement-or-break ...)))])
240 |        (if break-used?
241 |            (syntax/loc stx
242 |              (let ([cont #t]) (label skip (while cont stat ... (:= cont #f))) undefined))
243 |            (syntax/loc stx (block stat ...))))]
244 |     [(_for (clause ...) statement-or-break ...)
245 |      ;; Note: The idea is to call (map handle-clause clauses) and then
246 |      ;;       combine the pieces to one large while-loop.
247 |      ;;       Since the same handler can be called multiple times.
248 |      ;;       any variables introduced by a handler needs α-renaming.
249 |      ;;       This is handled by marking the clause before and after
250 |      ;;       calling handle-clause.
251 |      (define clauses                (syntax->list #'(clause ...)))
252 |      (define handlers               (map get-clause-handler clauses))
253 |      (define marks                  (map make-syntax-introducer clauses))
254 |      (define marked-handled-clauses (for/list ([clause clauses] [handle handlers] [mark marks])
255 |                                       (mark (handle (mark clause)))))
256 |      (define (is-break? x)          (or (eq? x '#:break) (and (syntax? x) (is-break? (syntax-e x)))))
257 |      (define break-used?            (ormap is-break? (syntax->list #'(statement-or-break ...))))
258 |      (define (maybe-wrap-in-loop-label loop-label statement)
259 |        (if break-used? #`(label #,loop-label #,statement) statement))
260 |      
261 |      (match (map syntax->list marked-handled-clauses)
262 |        [(list (list var-bindings termination-expr let-bindings step-statements) ...)
263 |         (let* ([var-bindings    (append* (map syntax->list var-bindings))]
264 |                [let-bindings    (append* (map syntax->list let-bindings))]
265 |                [step-statements (append* (map syntax->list step-statements))]          
266 |                [statements      (rewrite-breaks (syntax->list #'(statement-or-break ...)))])
267 |           (with-syntax ([(vb ...)   var-bindings]
268 |                         [(te ...)   termination-expr]
269 |                         [(lb ...)   let-bindings]
270 |                         [(step ...) step-statements]
271 |                         [(stat ...) statements])
272 |             (cond
273 |               [(not break-used?)  (syntax/loc stx
274 |                                     (block/let
275 |                                      (var vb ...)
276 |                                      (while (and #t #t te ...)
277 |                                             (let (lb ...)
278 |                                               stat ...
279 |                                               step ...))
280 |                                      undefined))]
281 |               [else               (syntax/loc stx
282 |                                     (block/let
283 |                                      (var vb ... (cont #t))
284 |                                      (while (and #t cont te ...)
285 |                                             (let (lb ...)
286 |                                               ; break does not work across function boundaries
287 |                                               ; and the let introduces one, so we need
288 |                                               ; a fake while here.
289 |                                               (label skip (while #t
290 |                                                                  stat ...
291 |                                                                  step ...
292 |                                                                  (break skip)))
293 |                                               undefined))
294 |                                      undefined))])))])]))
295 | 
296 | (define (expand-for* stx)
297 |   ; The basic idea is to rewrite for* into nested fors"
298 |   ;      (for* (clause0 clause1 ...) body)
299 |   ;   => (for (clause 0) (for (clause1) ... body))       
300 |   ; Only problem is that #:break <guard> needs to break out to the outer loop,
301 |   ; and since the JavaScript break statement doesn't work across function boundaries,
302 |   ; we need to introduce a try-catch. We only do this if #:break is used though.
303 |   (define (is-break? x)
304 |     (or (eq? x '#:break) (and (syntax? x) (is-break? (syntax-e x)))))
305 |   (define (rewrite-breaks statement-or-breaks)
306 |     (match statement-or-breaks
307 |       ['()                                   '()]
308 |       [(list  (? is-break? b))               (raise-syntax-error
309 |                                               'for* "missing guard expression after #:break" b)]
310 |       [(list* (? is-break? b) guard more)    (cons #`(sif #,guard
311 |                                                           (throw "break: for*")
312 |                                                           (sempty))
313 |                                                    (rewrite-breaks more))]
314 |       [(list* statement more)                (cons statement
315 |                                                    (rewrite-breaks more))]))
316 |   (syntax-parse stx
317 |     ;[(_for* () statement ...)                   (syntax/loc stx (for () statement ...))]
318 |     ;[(_for* (clause0) statement ...)            (syntax/loc stx (for (clause0) statement ...))]
319 |     [(_for* (clause ...) statement-or-break ...)
320 |      (define (for*->for reverse-clauses body)
321 |        ; rewrite for* to nested fors. 
322 |        ;    (for* (clause0 clause1 ...) body)
323 |        ; => (for (clause 0) (for (clause1) ... body))       
324 |        (match reverse-clauses
325 |          ['()                           body]
326 |          [(list clause0)                (with-syntax ([body body] [clause0 clause0])
327 |                                         #'(for (clause0) body))]
328 |          [(list last-clause clause ...) (for*->for
329 |                                          clause
330 |                                          (with-syntax ([body body] [last-clause last-clause])
331 |                                            (syntax/loc stx (for (last-clause) body))))]))
332 |      ; rewrite breaks to break out of the (other) loop
333 |      (define statements (rewrite-breaks (syntax->list #'(statement-or-break ...))))
334 |      ; rewrite for* to nested fors
335 |      (with-syntax ([(statement ...) statements])
336 |        (define body #'(block statement ...))
337 |        (define fors (for*->for (reverse (syntax->list #'(clause ...))) body))
338 |        ; determine if #:break <guard> is used
339 |        (define break-used? (ormap is-break? (syntax->list #'(statement-or-break ...))))
340 |        ; if #:break is used setup a try-catch
341 |        (with-syntax ([fors fors])
342 |          (cond
343 |            [break-used?    (syntax/loc stx
344 |                              (try {fors}
345 |                                   (catch msg
346 |                                     (sif (= msg "break: for*")
347 |                                          (sempty)
348 |                                          (throw msg)))))]
349 |            [else           #'fors])))]))
350 | 
351 | (define (expand-for/array stx)
352 |   (syntax-parse stx
353 |     [(_for/array #:length length-expr (clause ...) statement-or-break ... expr)
354 |      ; Allocate array of length length-expr and fill in the values afterwards.
355 |      ; This is faster than pushing repeatedly.
356 |      (syntax/loc stx
357 |        (let ()
358 |          (var [n length-expr] [a (array n)] [i 0])
359 |          (for (clause ...)
360 |            statement-or-break ...
361 |            (:= a i expr)
362 |            (+= i 1))
363 |          ; fill in remaining elements with 0
364 |          (sif (< i n)
365 |               (for ([j in-range i n]) (array! a j 0))
366 |               (sempty))
367 |          a))]
368 |     [(_for/array (clause ...) statement-or-break ... expr)
369 |      (syntax/loc stx
370 |        (let ([a (array)])
371 |          (for (clause ...)
372 |            statement-or-break ...
373 |            (a.push expr))
374 |          a))]
375 |     [_ (error 'urlang:for/array "got" stx)]))
376 | 
377 | (define (expand-for*/array stx)
378 |   (syntax-parse stx
379 |     [(_for*/array (clause ...) statement-or-break ... expr)
380 |      (syntax/loc stx
381 |        (let ([a (array)])
382 |          (for* (clause ...)
383 |            statement-or-break ...
384 |            (a.push expr))
385 |          a))]))
386 | 
387 | (define (expand-for/and stx)
388 |   (syntax-parse stx
389 |     [(_for/and (clause ...) statement-or-break ... expr)
390 |      (syntax/loc stx
391 |        (let ([b #t])
392 |          (for (clause ...)
393 |            statement-or-break ...
394 |            (:= b (and b expr))
395 |            #:break (not b))
396 |          b))]))
397 | 
398 | (define (expand-for*/and stx)
399 |   (syntax-parse stx
400 |     [(_for*/and (clause ...) statement-or-break ... expr)
401 |      (syntax/loc stx
402 |        (let ([b #t])
403 |          (for* (clause ...)
404 |            statement-or-break ...
405 |            (:= b (and b expr))
406 |            #:break (not b))
407 |          b))]))
408 | 
409 | (define (expand-for/or stx)
410 |   (syntax-parse stx
411 |     [(_for/or (clause ...) statement-or-break ... expr)
412 |      (syntax/loc stx
413 |        (let ([b #f])
414 |          (for (clause ...)
415 |            statement-or-break ...
416 |            (:= b (or b expr))
417 |            #:break b)
418 |          b))]))
419 | 
420 | (define (expand-for*/or stx)
421 |   (syntax-parse stx
422 |     [(_for*/or (clause ...) statement-or-break ... expr)
423 |      (syntax/loc stx
424 |        (let ([b #f])
425 |          (for* (clause ...)
426 |            statement-or-break ...
427 |            (:= b (or b expr))
428 |            #:break b)
429 |          b))]))
430 | 
431 | (define (expand-for/sum stx)
432 |   (syntax-parse stx
433 |     [(_for/sum (clause ...) statement-or-break ... expr)
434 |      (syntax/loc stx
435 |        (let ([s 0])
436 |          (for (clause ...)
437 |            statement-or-break ...
438 |            (+= s expr))
439 |          s))]))
440 | 
441 | (define (expand-for*/sum stx)
442 |   (syntax-parse stx
443 |     [(_for*/sum (clause ...) statement-or-break ... expr)
444 |      (syntax/loc stx
445 |        (let ([s 0])
446 |          (for* (clause ...)
447 |            statement-or-break ...
448 |            (+= s expr))
449 |          s))]))
450 | 
451 | (define (expand-for/product stx)
452 |   (syntax-parse stx
453 |     [(_for/product (clause ...) statement-or-break ... expr)
454 |      (syntax/loc stx
455 |        (let ([p 1])
456 |          (for (clause ...)
457 |            statement-or-break ...
458 |            (*= p expr))
459 |          p))]))
460 | 
461 | (define (expand-for*/product stx)
462 |   (syntax-parse stx
463 |     [(_for*/product (clause ...) statement-or-break ... expr)
464 |      (syntax/loc stx
465 |        (let ([p 1])
466 |          (for* (clause ...)
467 |            statement-or-break ...
468 |            (*= p expr))
469 |          p))]))
470 | 
471 | (define-urlang-macro for          expand-for)
472 | (define-urlang-macro for*         expand-for*)
473 | (define-urlang-macro for/array    expand-for/array)
474 | (define-urlang-macro for*/array   expand-for*/array)
475 | (define-urlang-macro for/and      expand-for/and)
476 | (define-urlang-macro for*/and     expand-for*/and)
477 | (define-urlang-macro for/or       expand-for/or)
478 | (define-urlang-macro for*/or      expand-for*/or)
479 | (define-urlang-macro for/sum      expand-for/sum)
480 | (define-urlang-macro for*/sum     expand-for*/sum)
481 | (define-urlang-macro for/product  expand-for/product)
482 | (define-urlang-macro for*/product expand-for*/product)
483 | 
484 | 


--------------------------------------------------------------------------------
/urlang/globals.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 | 
3 | (provide global-variables macro-introduced-identifiers)
4 | 
5 | (define global-variables             (make-parameter '()))
6 | (define macro-introduced-identifiers (make-parameter '()))
7 | 
8 | 


--------------------------------------------------------------------------------
/urlang/html.rkt:
--------------------------------------------------------------------------------
1 | #lang racket
2 | ;; This file is intended to be use as
3 | ;;     (require urlang/html)
4 | ;; and will import all html related utilities in urlang/html/
5 | 
6 | (require "html/all.rkt")
7 | (provide (all-from-out "html/all.rkt"))


--------------------------------------------------------------------------------
/urlang/html/README.md:
--------------------------------------------------------------------------------
 1 | HTML related utilities
 2 | ======================
 3 | 
 4 | This folder contains a bunch of utilities for creating html-files.
 5 | If you want to use all of them at once, use
 6 | 
 7 |     (require urlang/html)
 8 | 
 9 | otherwise just use, say, (require urlang/html/at-html).
10 | 
11 | main.rkt
12 | --------
13 | Imports and reexports all other utilies in this folder.
14 | 
15 | at-html.rkt
16 | -----------
17 | This file makes it possible to construct xml and html
18 | using the scrible at-syntax.
19 | 
20 | Example:    @h1[class: "red"]{A Title}
21 |          will produce an xml value representing
22 |             <h1 class="red">A Title</h1>
23 | 
24 | Use ~x  to turn a single  xml value  into a string.
25 | Use ~xs to turn a list of xml values into a string.
26 | 
27 | 


--------------------------------------------------------------------------------
/urlang/html/all.rkt:
--------------------------------------------------------------------------------
1 | #lang racket
2 | ;;; This file imports and exports every utility in this folder.
3 | ;;; It contains what you get if you include urlang/html.
4 | 
5 | (require "at-html.rkt")
6 | 
7 | (provide (all-from-out "at-html.rkt"))
8 | 


--------------------------------------------------------------------------------
/urlang/html/at-html.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket/base
 2 | ;; The #lang scribble/html language offers a nice solution for
 3 | ;; constructing html using at-expressions (aka @-syntax).
 4 | 
 5 | ;; This file makes it possible to use the machinery without using
 6 | ;; the #lang scribble/html language.
 7 | 
 8 | ;; Use (require urlang/html) in your #lang racket  program to get:
 9 | 
10 | 
11 | ;;; Self-quote identifiers that end with colon.
12 | 
13 | ; Example:  class: turns into 'class
14 | (require (only-in scribble/html/main #%top)
15 |          (only-in scribble/text/output special?))
16 | (provide special?) ; specials are used to represent entities such as nbsp
17 | 
18 | 
19 | ;;; Constructors for all standard html tags: h1, p, ...
20 | 
21 | (require  (except-in scribble/html var object label block))
22 | (require  (only-in  scribble/html/extra figcaption))
23 | (require  (prefix-in html: scribble/html))
24 | 
25 | ; A few of the constructors have names that clash with Urlang.
26 | ; If you need them, then use
27 | ;     (require (prefix-in your-favorite-prefix var object label block))
28 | 
29 | ; Two standard constructors is missing from scribble/html
30 | (define/provide-elements/not-empty footer nav canvas)
31 | 
32 | 
33 | ;;; A way to turn the xml into strings
34 | 
35 | (require scribble/html/xml)
36 | 
37 | 
38 | ;;; A few utilies that turns xml(s) into a string
39 | 
40 | (define ~x xml->string)
41 | (define (~xs . xs) (string-append* (map ~x xs)))
42 | 
43 | ;;; Easy conversion from html or xexps to at-notation
44 | (require "to-at-exp.rkt")
45 | 
46 | ;;; No name clashes
47 | 
48 | ; To prevent and discover name clashes with urlang, we require urlang
49 | ; here even though we don't use it for anything.
50 | (require urlang)
51 | 
52 | (provide ~x ~xs
53 |          #%top
54 |          nav footer canvas
55 |          (all-from-out scribble/html
56 |                        scribble/html/xml
57 |                        "to-at-exp.rkt"))
58 | 


--------------------------------------------------------------------------------
/urlang/html/tag-comparison.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | ;;; This is an ad-hoc file used to find the tags missing in scribble/html/html.rkt
  3 | 
  4 | 
  5 | (define non-empty-xhtml-tags
  6 |   '(a
  7 |     abbr
  8 |     acronym
  9 |     address
 10 |     applet
 11 |     b
 12 |     bdo
 13 |     big
 14 |     blockquote
 15 |     body
 16 |     button
 17 |     caption
 18 |     center
 19 |     cite
 20 |     code
 21 |     colgroup
 22 |     dd
 23 |     del
 24 |     dfn
 25 |     dir
 26 |     div
 27 |     dl
 28 |     dt
 29 |     em
 30 |     fieldset
 31 |     font
 32 |     form
 33 |     frame
 34 |     frameset
 35 |     h1
 36 |     h2
 37 |     h3
 38 |     h4
 39 |     h5
 40 |     h6
 41 |     head
 42 |     html
 43 |     i
 44 |     iframe
 45 |     ins
 46 |     kbd
 47 |     label
 48 |     legend
 49 |     li
 50 |     menu
 51 |     noframes
 52 |     noscript
 53 |     object
 54 |     ol
 55 |     optgroup
 56 |     option
 57 |     p
 58 |     pre
 59 |     q
 60 |     s
 61 |     samp
 62 |     script
 63 |     select
 64 |     small
 65 |     span
 66 |     strike
 67 |     strong
 68 |     style
 69 |     sub
 70 |     sup
 71 |     table
 72 |     tbody
 73 |     td
 74 |     textarea
 75 |     tfoot
 76 |     th
 77 |     thead
 78 |     title
 79 |     tr
 80 |     tt
 81 |     u
 82 |     ul
 83 |     var))
 84 | 
 85 | (define empty-xhtml-tags
 86 |   '(base meta link hr br basefont param img area input isindex col))
 87 | 
 88 | (define xhtml-tags
 89 |   (append non-empty-xhtml-tags
 90 |           empty-xhtml-tags))
 91 | 
 92 | (define html5-tags
 93 |   '(a
 94 |     abbr
 95 |     address
 96 |     area
 97 |     article
 98 |     aside
 99 |     audio
100 |     b
101 |     base
102 |     bdi
103 |     bdo
104 |     blockquote
105 |     body
106 |     br
107 |     button
108 |     canvas
109 |     caption
110 |     cite
111 |     code
112 |     col
113 |     colgroup
114 |     data
115 |     datalist
116 |     dd
117 |     del
118 |     dfn
119 |     div
120 |     dl
121 |     dt
122 |     em
123 |     embed
124 |     fieldset
125 |     figcaption
126 |     figure
127 |     footer
128 |     form
129 |     h6
130 |     head
131 |     header
132 |     hr
133 |     html
134 |     i
135 |     iframe
136 |     img
137 |     input
138 |     ins
139 |     kbd
140 |     keygen
141 |     label
142 |     legend
143 |     li
144 |     link
145 |     main
146 |     map
147 |     mark
148 |     meta
149 |     meter
150 |     nav
151 |     noscript
152 |     object
153 |     ol
154 |     optgroup
155 |     option
156 |     output
157 |     p
158 |     param
159 |     pre
160 |     progress
161 |     q
162 |     rb
163 |     rp
164 |     rt
165 |     rtc
166 |     ruby
167 |     s
168 |     samp
169 |     script
170 |     section
171 |     select
172 |     small
173 |     source
174 |     span
175 |     strong
176 |     style
177 |     sub
178 |     sup
179 |     table
180 |     tbody
181 |     td
182 |     template
183 |     textarea
184 |     tfoot
185 |     th
186 |     thead
187 |     time
188 |     title
189 |     tr
190 |     track
191 |     u
192 |     ul
193 |     var
194 |     video
195 |     wbr))
196 | 
197 | (define A (list->set xhtml-tags))
198 | (define B (list->set html5-tags))
199 | (set->list (set-subtract B A))
200 | (length (set->list (set-subtract B A)))
201 | 
202 | (define new-tags
203 |   '(rb          ; Ruby base
204 |     nav         ; Section with navigational links
205 |     meter       ; Gauge
206 |     data        ; Machine-readable equivalent
207 |     footer      ; Footer for a page or section
208 |     figure      ; Figure with optional caption
209 |     template    ; Template  
210 |     figcaption  ; Caption for figure
211 |     progress    ; Progress bar
212 |     datalist    ; Container for options for combo box control
213 |     output      ; Calculated output value
214 |     bdi         ; Text directionality isolation
215 |     audio       ; Audio player
216 |     time        ; Machine-readable equivalent of date- or time-related data
217 |     aside       ; Sidebar for tangentially related content
218 |     article     ; Contact information for a page or article element
219 |     ruby        ; Ruby annotation(s)
220 |     main        ;
221 |     rt          ; Ruby annotation text
222 |     header      ; Introductory or navigational aids for a page or section
223 |     canvas      ; Scriptable bitmap canvas
224 |     mark        ; Highlight
225 |     video       ; Video player
226 |     rtc         ; Ruby annotation text container 
227 |     rp          ; Parenthesis for ruby annotation text
228 |     section     ; Generic document or application section
229 |     map))
230 |   
231 | (define new-empty-tags
232 |   '(keygen ; Cryptographic key-pair generator form control
233 |     track  ; Timed text track
234 |     wbr    ; Line breaking opportunity
235 |     source ; Media source for video or audio
236 |     embed  ; Plugin
237 |     ))
238 | 


--------------------------------------------------------------------------------
/urlang/html/to-at-exp.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | (provide xexp->at-exp    ; convert an xexp into an at-exp
  3 |          html->at-exp)   ; convert a string with html into an at-exp
  4 | 
  5 | ;;; This file implements two utilities that output at-expressions representing html.
  6 | ;;; Example:
  7 | ;;;    > (displayln (html->at-exp "<div id='foo' color='red'><h1>Bar</h1> Baz</div>") )
  8 | ;;;    @div[id: "foo" color: "red"]{@h1{Bar} Baz}
  9 | 
 10 | ;;; The intended usage is to convert snippets of html examples found on the web
 11 | ;;; to at-expressions which work with urlang/html (or Pollen for that matter).
 12 | 
 13 | (require html-parsing)
 14 | 
 15 | ; xexp->at-exp : xexp -> string
 16 | ;  convert an xexp to an at-exp
 17 | (define (xexp->at-exp x)
 18 |   (emit (xexp->at-exp-tree x)))
 19 | 
 20 | ; html->at-exp : string -> string
 21 | ;  convert a string containing html to an at-exp string
 22 | (define (html->at-exp x)
 23 |   (xexp->at-exp (html->xexp x)))
 24 | 
 25 | 
 26 | ; emit : tree -> string
 27 | ;   display all elements of the tree x into a string, and return it
 28 | (define (emit x)
 29 |   (define (loop x)
 30 |     (match x
 31 |       [(list x ...) (map loop x)]
 32 |       [x            (display x)]))
 33 |   (with-output-to-string
 34 |       (λ () (loop x))))
 35 | 
 36 | 
 37 | ; xexp->at-exp-tree : xexp -> tree
 38 | ;   build a tree that when emitted will give an at-exp that is equivalent to the xexp
 39 | (define (xexp->at-exp-tree x)
 40 |   (match x
 41 |     [(list '*TOP* more ...) (unparse-top x)]
 42 |     [_ (error 'xexp->at-exp "expected (*TOP* <annotation>? <PI>* <comment>* <Element>)")]))
 43 | 
 44 | ; unparse-top : xexp -> tree
 45 | (define (unparse-top x)
 46 |   ; <TOP> ::= ( *TOP* <annotations>? <PI>* <comment>* <Element> )
 47 |   ; NOTE: <PI> are ignored
 48 |   (match x
 49 |     [(list '*TOP* (? annotation? a*) ... comment* ... element)
 50 |      (list (map unparse-annotation a*)
 51 |            ; (map unparse-comment comment*)
 52 |            (cond
 53 |              [(element? element) (unparse-element element)]
 54 |              [else               (unparse-child-of-element element)]))]))
 55 | 
 56 | (define (annotation? x)
 57 |   ; Note: Annotations beside DECL are ignored.
 58 |   (match x [(list '*DECL* _ ...) #t] [_ #f]))
 59 | 
 60 | (define (unparse-annotation x)
 61 |   (match x
 62 |     [(list '*DECL* more ...)
 63 |      (list "<!" (add-between more " ") ">\n")]))
 64 | 
 65 | (define (comment? x)
 66 |   (match x [(list '*COMMENT* _ ...) #t] [_ #f]))
 67 | 
 68 | (define (unparse-comment x)
 69 |   (match x
 70 |     [(list '*COMMENT* comment-string)
 71 |      (list "@comment{" comment-string "}")]))
 72 | 
 73 | (define (entity? x)
 74 |   (match x [(list '*ENTITY* public-id system-id) #t] [_ #f]))
 75 | 
 76 | (define (unparse-entity x)
 77 |   (match x
 78 |     [(list '*ENTITY* public-id system-id)
 79 |      (error 'todo-entity)]))
 80 | 
 81 | (define (element? x)
 82 |   (match x [(list name more ...) #t] [_ #f]))
 83 | 
 84 | (define (unparse-element x)
 85 |   ; <Element> ::= ( <name> <annot-attributes>? <child-of-element>* )
 86 |   (match x
 87 |     [(list name {list '@ attribute* ...} child ...)
 88 |      (define atts*  (unparse-attributes attribute*))
 89 |      (define child* (map unparse-child-of-element child))
 90 |      (if (null? child)
 91 |          (list "@" name "[" atts* "]")
 92 |          (list "@" name "[" atts* "]" "{" child* "}"))]
 93 |     ; no annotated attributes:
 94 |     [(list name child ...)
 95 |      (define child* (map unparse-child-of-element child))
 96 |      (list "@" name "{" child* "}")]    
 97 |     ))
 98 | 
 99 | (define (unparse-attributes xs)
100 |   (add-between (map unparse-attribute xs) " "))
101 | 
102 | (define (unparse-attribute x)
103 |   (match x
104 |     [(list name)       (list name ":")]
105 |     [(list name value) (list name ": \"" value "\"")]))
106 | 
107 | (define (unparse-child-of-element x)
108 |   ; <Element> | "character data" | <PI> | <comment> | <entity>
109 |   (match x
110 |     [(? string? ) x] ; "character data"
111 |     [(? comment?) (unparse-comment x)]
112 |     [(? entity?)  (unparse-entity x)]
113 |     [(list '*PI* pi-target annotation ... prossing-instruction-content-string)
114 |      (error 'todo-pi)]
115 |     [_ (unparse-element x)]))
116 | 


--------------------------------------------------------------------------------
/urlang/info.rkt:
--------------------------------------------------------------------------------
 1 | #lang info
 2 | ;;; This file describes the contents of "urlang" collection in the "urlang" package.
 3 | 
 4 | ;;; The name of the collection is simply "urlang".
 5 | (define collection "urlang")
 6 | 
 7 | ;;; Version number
 8 | (define version    "1.0")
 9 | 
10 | ;;; Dependencies needed for runtime.
11 | (define deps       '("base"
12 |                      "html-parsing"
13 |                      "html-writing"
14 |                      "nanopass"
15 |                      "net-lib"
16 |                      "rackunit-lib"
17 |                      "scribble-html-lib"
18 |                      "srfi-lite-lib"
19 |                      "web-server-lib"))
20 | 
21 | ;;; Dependencies needed for compile time"
22 | (define build-deps '("base"               
23 |                      "html-writing"          ; for example in urlang-exampes
24 |                      "nanopass"              ; for urlang and urlang-compiler
25 |                      "net-lib"               ; ? detected on build-server
26 |                      "rackunit-lib"          ; for tests
27 |                      "scribble-html-lib"     ; for urlang/html
28 |                      "srfi-lite-lib"         ; ? detected on build-server
29 |                      "web-server-lib"))      ; for urlang/html
30 | 
31 | 
32 | (define compile-omit-paths '())
33 | 
34 | 


--------------------------------------------------------------------------------
/urlang/react/urx.rkt:
--------------------------------------------------------------------------------
  1 | #lang at-exp racket
  2 | ;;;
  3 | ;;; URX
  4 | ;;;
  5 | 
  6 | ; This implements urx expressions.
  7 | ; What jsx expressions are to JavaScript, urx expressions are to Urlang.
  8 | ; JSX expressions are an extension to JavaScript that makes it easy
  9 | ; to generate React elements (representing dom elements) at runtime.
 10 | 
 11 | ; This file (for now) contains both urx expressions.
 12 | 
 13 | (require urlang urlang/html
 14 |          ; (except-in xml make-element entity element comment cdata attribute? attribute)
 15 |          syntax/parse (for-syntax syntax/parse))
 16 | (require (for-syntax scribble/html/xml racket/match))
 17 | 
 18 | ;;; JSX                        URX (AT-expression)    S-EXPR                 Urlang
 19 | ;;; <div>Foo</div>             @div{Foo}              (div "foo")            (React.createElement "div" null (array "Foo"))
 20 | ;;; <div foo="bar">Foo</div>   @div[foo: "bar"]{Foo}  (div foo: bar "foo")   (React.createElement "div" (object [foo "bar"]) (array "Foo"))
 21 | ;;; <Input />                  @Input[]               (Input)                (React.createElement "Input" null)
 22 | 
 23 | ;;  Note that jsx/urx expressions are allowed in the body too.
 24 | 
 25 | 
 26 | ;; @list[foo: "foo" bar: "bar"]{baz @42 qux}
 27 | ;; (foo: "foo" bar: "bar" "baz " 42 " qux")
 28 | 
 29 | ;; An easy way to see that an urx-expressions reads as:
 30 | 
 31 | (define-syntax (urx-test stx)
 32 |   (syntax-parse stx
 33 |     [(_ urx-expr)
 34 |      (syntax/loc stx
 35 |        'urx-expr)]))
 36 | 
 37 | 
 38 | ;; (urx-test @div[foo: "bar" Foo])
 39 | ;; '(div foo: "bar" Foo)
 40 | 
 41 | ;; The library scribble/html/xml provides a few tools that will help us.
 42 | (require scribble/html/xml
 43 |          )
 44 | 
 45 | ;; First The attribute names are represented as symbols that end with a colon.
 46 | 
 47 | ;; > (attribute? 'foo:)
 48 | ;; foo
 49 | ;; > (attribute? 'foo)
 50 | ;; #f
 51 | 
 52 | ;; To make things clearer, we will use `attribute->symbol` when we need
 53 | ;; to remove a colon.
 54 | 
 55 | (define attribute->symbol attribute?)
 56 | 
 57 | ;; We will need to split a form into the attributes and the body.
 58 | ;; The functions `attributes+body` and `split-attributes+body` will help
 59 | ;; us with this.
 60 | 
 61 | ;; > (attributes+body '(foo: "bar" Foo))
 62 | ;; '((foo . "bar"))
 63 | ;; '(Foo)
 64 | 
 65 | ;; > (split-attributes+body '(foo: "bar" Foo))
 66 | ;; '(foo: "bar")
 67 | ;; '(Foo)
 68 | 
 69 | (require racket/syntax)
 70 | (define-urlang-macro urx
 71 |   (λ (stx)
 72 |     ; attributes+body : syntax-list -> ...
 73 |     (define attribute->symbol attribute?)    
 74 |     (define (attributes+body xs) 
 75 |       (let loop ([xs xs] [as '()])
 76 |         (define a (and (pair? xs)
 77 |                        (identifier? (car xs))
 78 |                        (attribute->symbol (syntax-e (car xs)))))
 79 |         (define a-id (and a (datum->syntax (car xs) a (car xs))))
 80 |         ; if a is #f we have seen the last attribute,
 81 |         ; otherwise a is the attribute name (without colon).
 82 |         (cond [(not a)              (values (reverse as) xs)]
 83 |               [(null? (cdr xs))     (error 'attributes+body
 84 |                                            "missing attribute value for `~s:'" a)]
 85 |               [else (loop (cddr xs)
 86 |                           (cons (cons a-id (cadr xs)) as))])))    
 87 |     (define (convert urx-expr)
 88 |       ; (displayln (list 'urx-convert urx-expr))
 89 |       (syntax-parse urx-expr
 90 |         #:datum-literals (ur)
 91 |         [s:string   #'s]
 92 |         [n:number   #'n]
 93 |         [i:id       #'i]
 94 |         [b:boolean  #'b]
 95 |         [(ur more)  #'more]   ; "unquote" for urx expressions (called mustaches in jsx)
 96 |         [(tag:id (~optional (~seq #:spread props:id) #:defaults ([props #f]))
 97 |                  atts+body ...)
 98 |          (define ps (attribute props))
 99 |          (define-values (atts body)
100 |            (attributes+body (syntax->list #'(atts+body ...))))
101 |          (define tag-str (symbol->string (syntax-e #'tag)))
102 |          (with-syntax* ([tag              (if (char-lower-case? (string-ref tag-str 0))
103 |                                               tag-str
104 |                                               #'tag)]
105 |                         [((id . val) ...) atts]
106 |                         [(val ...)        (map convert (syntax->list #'(val ...)))]
107 |                         [(content ...)    (map convert body)])
108 |            (with-syntax
109 |              ([atts-expr
110 |                (cond [(and (zero? (length atts)) (not ps)) #'null]
111 |                      [(and (zero? (length atts))      ps)  ps]
112 |                      [(not ps)                             #'(object [id val] ...)]
113 |                      [else
114 |                       (with-syntax ([props ps])
115 |                         ; TODO change assign here to something that works ...
116 |                         #'(Object.assign (object) (object [id val] ...) props))])])
117 |                                
118 |              (match body
119 |                ['() (syntax/loc urx-expr
120 |                       (React.createElement tag atts-expr))]
121 |                [_   (syntax/loc urx-expr
122 |                       (React.createElement tag atts-expr content ...))])))]))
123 |     (syntax-parse stx
124 |       [(_urx urx-expr)
125 |        (define out (convert #'urx-expr))
126 |        ; (displayln (syntax->datum out))
127 |        out])))
128 | 


--------------------------------------------------------------------------------
/urlang/symbol-table.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | (provide define-symbol-table)
 3 | ;;;
 4 | ;;; SYMBOL TABLE
 5 | ;;
 6 | 
 7 | ; This file contains a symbol table in the style of free-id-table and bound-id-table.
 8 | ; Symbols are used instead of identifiers.
 9 | ; Identifiers are accepted as input - but represent the corresponding symbol.
10 | 
11 | (require (for-syntax racket/syntax syntax/parse))
12 | 
13 | (struct symbol-table (ht) #:transparent)
14 | 
15 | (define (make-symbol-table)
16 |   (symbol-table (make-hasheq)))
17 | 
18 | (define (symbol-table-set! st sym val)
19 |   (hash-set! (symbol-table-ht st) sym val))
20 | 
21 | (define (symbol-table-symbols st)
22 |   (hash-keys (symbol-table-ht st)))
23 | 
24 | (define (symbol-table-ref st sym [default #f])
25 |   (hash-ref (symbol-table-ht st) sym #f))
26 | 
27 | (define (strip x)
28 |   (cond
29 |     [(symbol? x) x]
30 |     [(syntax? x) (strip (syntax->datum x))]
31 |     [else (error 'strip "expected a symbol or an identifier, got ~a" x)]))
32 | 
33 | (define-syntax (define-symbol-table stx)
34 |   (syntax-parse stx
35 |     [(_define-symbol-table id)
36 |      (with-syntax ([id-st (format-id #'id "~a-st" #'id #:source #'id)]
37 |                    [ids   (format-id #'id "~as"   #'id #:source #'id)]
38 |                    [id!   (format-id #'id "~a!"   #'id #:source #'id)]
39 |                    [id?   (format-id #'id "~a?"   #'id #:source #'id)])
40 |        (syntax/loc stx
41 |          (begin
42 |            (define id-st                (make-symbol-table))
43 |            (define (id! x [v #t])       (symbol-table-set! id-st (strip x) v))
44 |            (define (ids)                (symbol-table-symbols id-st))
45 |            (define (id? x [default #f]) (symbol-table-ref id-st (strip x) default)))))]))
46 | 
47 | (define-symbol-table foo)
48 | 
49 | 
50 | 
51 | 
52 | 
53 | 
54 | 
55 | 
56 | 


--------------------------------------------------------------------------------
/urlang/tests/test-async-and-await.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | (require urlang urlang/extra)
 3 | 
 4 | ;;;
 5 | ;;; TEST
 6 | ;;;
 7 | 
 8 | ; This file contains tests for the async and await.
 9 | ; Note: the keyword for ES6 let declarations is   let-decl.
10 | ;       we have used the keyword  let  for Racket-like let-expressions.
11 | 
12 | ;;; Note: No output means all tests ran successfully.
13 | 
14 | ;;; Note: You need to install  node  in order to run these tests.
15 | ;;;            https://nodejs.org/en/
16 | 
17 | ;;; Running these tests will for each module produce
18 | ;;; both a JavaScript file and a file containing names of exports.
19 | 
20 | ;;; Then node (a command line version of the JavaScript engine
21 | ;;; used in Chrome) is invoked on the JavaScript file, and the
22 | ;;; output is compared with the expected output.
23 | 
24 | (current-urlang-run?                           #t) ; run using Node?
25 | (current-urlang-echo?                          #f) ; print generated JavaScript?
26 | (current-urlang-console.log-module-level-expr? #f)
27 | 
28 | (require rackunit)
29 | (define (rs s) (read (open-input-string s))) ; note: only reads FIRST value
30 | 
31 | 
32 | (check-equal? (rs (urlang (urmodule test-async-and-await
33 |                             (import this setTimeout Promise)
34 |                             (define (pause value milliseconds)
35 |                               (new Promise
36 |                                    (λ (resolve reject)
37 |                                      (setTimeout (λ() (resolve value)) milliseconds))))
38 |                             (var [result 0])
39 |                             (define/async (f)
40 |                                 (var [promise (await (pause "done" 1000))])
41 |                                 (:= result promise))
42 |                             (f)
43 |                             ; don't exit before output
44 |                             (setTimeout (λ () (console.log result)) 2000))))
45 |               'done)
46 | 
47 | 


--------------------------------------------------------------------------------
/urlang/tests/test-const-and-let.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | (require urlang urlang/extra)
 3 | 
 4 | ;;;
 5 | ;;; TEST
 6 | ;;;
 7 | 
 8 | ; This file contains tests for the constant and let variable bindings.
 9 | ; Note: the keyword for ES6 let declarations is   let-decl.
10 | ;       we have used the keyword  let  for Racket-like let-expressions.
11 | 
12 | ;;; Note: No output means all tests ran successfully.
13 | 
14 | ;;; Note: You need to install  node  in order to run these tests.
15 | ;;;            https://nodejs.org/en/
16 | 
17 | ;;; Running these tests will for each module produce
18 | ;;; both a JavaScript file and a file containing names of exports.
19 | 
20 | ;;; Then node (a command line version of the JavaScript engine
21 | ;;; used in Chrome) is invoked on the JavaScript file, and the
22 | ;;; output is compared with the expected output.
23 | 
24 | (current-urlang-run?                           #t) ; run using Node?
25 | (current-urlang-echo?                          #t) ; print generated JavaScript?
26 | (current-urlang-console.log-module-level-expr? #t)
27 | 
28 | (require rackunit)
29 | (define (rs s) (read (open-input-string s))) ; note: only reads FIRST value
30 | 
31 | 
32 | (check-equal? (rs (urlang (urmodule test-new1
33 |                             (import this)
34 |                             (const [x 1])
35 |                             ; (const [x 43]) ; TODO: Should be caught by Urlang
36 |                             (const [y 20] [z 300])
37 |                             (let-decl [a 4000] [b 50000])
38 |                             ; (let-decl [a 600000]) ; TODO: catch redeclaration
39 |                             (+ x y z a b))))
40 |               54321)
41 | 
42 | 


--------------------------------------------------------------------------------
/urlang/tests/test-extra.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | (require urlang urlang/extra)
  3 | 
  4 | ;;;
  5 | ;;; TEST
  6 | ;;;
  7 | 
  8 | ;;; Note: No output means all tests ran successfully.
  9 | 
 10 | ;;; Note: You need to install  node  in order to run these tests.
 11 | ;;;            https://nodejs.org/en/
 12 | 
 13 | ;;; Running these tests will for each module produce
 14 | ;;; both a JavaScript file and a file containing names of exports.
 15 | 
 16 | ;;; Then node (a command line version of the JavaScript engine
 17 | ;;; used in Chrome) is invoked on the JavaScript file, and the
 18 | ;;; output is compared with the expected output.
 19 | 
 20 | (current-urlang-run?                           #t) ; run using Node?
 21 | (current-urlang-echo?                          #f) ; print generated JavaScript?
 22 | (current-urlang-console.log-module-level-expr? #t)
 23 | 
 24 | (require rackunit)
 25 | (define (rs s) (read (open-input-string s))) ; note: only reads FIRST value
 26 | 
 27 | (check-equal? (rs (urlang (urmodule test-cond
 28 |                             (define x 3)
 29 |                             (cond
 30 |                               [(= x 1) "one"]
 31 |                               [(= x 2) "two"]
 32 |                               [(= x 3) "three"]
 33 |                               [#t      "huh"]))))
 34 |               'three)
 35 | 
 36 | (check-equal? (rs (urlang (urmodule test-sconf
 37 |                             (var r [n 3])
 38 |                             (scond
 39 |                               [(= n 2) (:= r "fail")]
 40 |                               [(= n 3) (:= r "success")])
 41 |                             r)))
 42 |               'success)
 43 | 
 44 | (check-equal? (rs (urlang (urmodule test-begin0
 45 |                             (begin0 1 2 3 4))))
 46 |               1)
 47 | 
 48 | (check-equal? (rs (urlang (urmodule test-when1
 49 |                             (let ([x 3] [y 4])
 50 |                               (when (= x 3) (:= y 5))
 51 |                               y))))
 52 |               5)
 53 | (check-equal? (rs (urlang (urmodule test-when2
 54 |                             (let ([x 3] [y 4])
 55 |                               (when (= x 2) (:= y 5))
 56 |                               y))))
 57 |               4)
 58 | 
 59 | (check-equal? (rs (urlang (urmodule test-unless1
 60 |                             (let ([x 3] [y 4])
 61 |                               (unless (= x 3) (:= y 5))
 62 |                               y))))
 63 |               4)
 64 | (check-equal? (rs (urlang (urmodule test-unless2
 65 |                             (let ([x 3] [y 4])
 66 |                               (unless (= x 2) (:= y 5))
 67 |                               y))))
 68 |               5)
 69 | 
 70 | 
 71 | (check-equal? (rs (urlang (urmodule test-unless3
 72 |                             (define msg "")
 73 |                             (sunless (> 5 0)
 74 |                                      (:= msg "hi"))
 75 |                             (sunless (< 5 0)
 76 |                                      (:= msg "hi-there"))
 77 |                             msg)))
 78 |                   'hi-there)
 79 | 
 80 | 
 81 | (check-equal? (rs (urlang (urmodule test-letrec
 82 |                             (define (zero? x) (= x 0))
 83 |                             (define (sub1 x) (- x 1))
 84 |                             (letrec ([is-even? (lambda (n)
 85 |                                                  (or (zero? n)
 86 |                                                      (is-odd? (sub1 n))))]
 87 |                                      [is-odd? (lambda (n)
 88 |                                                 (and (not (zero? n))
 89 |                                                      (is-even? (sub1 n))))])
 90 |                               (is-odd? 11)))))
 91 |               'true)
 92 | 
 93 | (check-equal? (rs (urlang (urmodule test-let*
 94 |                             (let* ([x 1]
 95 |                                    [y (+ x 1)])
 96 |                               (+ (* 100 x) y)))))
 97 |               102)
 98 | 
 99 | (check-equal? (rs (urlang (urmodule test-case1
100 |                             (case (+ 7 5)
101 |                               [(1 2 3)    "small"]
102 |                               [(10 11 12) "big"]))))
103 |               'big)
104 | 
105 | (check-equal? (rs (urlang (urmodule test-case1
106 |                             (case (- 7 5)
107 |                               [(1 2 3)    "small"]
108 |                               [(10 11 12) "big"]))))
109 |               'small)
110 | 


--------------------------------------------------------------------------------
/urlang/tests/test-for.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | (require urlang        ; Urlang
  3 |          urlang/for    ; for-loop extesion
  4 |          rackunit)     ; tests library
  5 | 
  6 | ;;;
  7 | ;;; TEST
  8 | ;;;
  9 | 
 10 | ;;; Note: No output means all tests ran successfully.
 11 | ;;;       (Set current-urlang-echo? to #f if you don't want
 12 | ;;;        to the generated JavaScript).
 13 | 
 14 | ;;; Note: You need to install  node  in order to run these tests.
 15 | ;;;            https://nodejs.org/en/
 16 | 
 17 | ;;; Running these tests will for each module produce
 18 | ;;; both a JavaScript file and a file containing names of exports.
 19 | 
 20 | ;;; Then node (a command line version of the JavaScript engine
 21 | ;;; used in Chrome) is invoked on the JavaScript file, and the
 22 | ;;; output is compared with the expected output.
 23 | 
 24 | 
 25 | (current-urlang-run?                           #t) ; run using Node?
 26 | (current-urlang-echo?                          #t) ; print generated JavaScript?
 27 | (current-urlang-console.log-module-level-expr? #t) ; print top-level expression?
 28 | 
 29 | (define (rs s) (read (open-input-string s)))
 30 | 
 31 | ; test for with single clause and in-range
 32 | (check-equal? (rs (urlang
 33 |                    (urmodule test-for
 34 |                      (define sum 0)
 35 |                      (for ([x in-range 1 101])
 36 |                        (+= sum x))
 37 |                      sum)))
 38 |               5050)
 39 | 
 40 | ; test in-array
 41 | (check-equal? (rs (urlang
 42 |                    (urmodule test-for
 43 |                      (define sum 0)
 44 |                      (for ([x in-array (array 1 2 3 4 5)])
 45 |                        (+= sum x))
 46 |                      sum)))
 47 |               15)
 48 | 
 49 | ; test for with two parallel clauses
 50 | (check-equal? (rs (urlang
 51 |                    (urmodule test-for
 52 |                      (define sum 0)
 53 |                      (for ([x in-array (array 1 2 3 4 5)]
 54 |                            [y in-range 100 200])
 55 |                        (+= sum (+ x y)))
 56 |                      sum)))
 57 |               525)
 58 | 
 59 | ; test in-naturals and #:break <guard>
 60 | (check-equal? (rs (urlang
 61 |                    (urmodule test-for
 62 |                      (define sum 0)
 63 |                      (define stop? #f)
 64 |                      (for ([x in-naturals 1])
 65 |                        (+= sum x)
 66 |                        #:break (= x 5))
 67 |                      sum)))
 68 |               15)
 69 | 
 70 | ; test in-naturals works from varying starting points
 71 | (check-equal? (rs (urlang
 72 |                    (urmodule test-for
 73 |                      (define sum 0)
 74 |                      (define stop? #f)
 75 |                      (for ([x in-naturals 3])
 76 |                        (+= sum x)
 77 |                        #:break (= x 5))
 78 |                      sum)))
 79 |               12)
 80 | 
 81 | ; test in-string
 82 | (check-equal? (urlang (urmodule test-in-string
 83 |                         (for/array ([x in-string "foobar"]) x)))
 84 |               (urlang (urmodule test-in-string2
 85 |                         (array "f" "o" "o" "b" "a" "r"))))
 86 | 
 87 | 
 88 | ;;; for/sum
 89 | (check-equal? (rs (urlang (urmodule test-in-string
 90 |                             (for/sum ([x in-range 1 6]) x))))
 91 |               15)
 92 | 
 93 | ;;; for/product
 94 | (check-equal? (rs (urlang (urmodule test-in-string
 95 |                             (for/product ([x in-range 1 6]) x))))
 96 |               120)
 97 | 
 98 | ;;; for/and
 99 | (check-equal? (rs (urlang (urmodule test-in-string
100 |                             (for/and ([x in-range 1 5]) x))))
101 |               4)
102 | (check-equal? (rs (urlang (urmodule test-in-string
103 |                             (for/and ([x in-range 1 5]) (= x 3)))))
104 |               'false)
105 | 
106 | (check-equal? (rs (urlang (urmodule test-in-string
107 |                             (for/and () 3))))
108 |               3)
109 | 
110 | ;;; for/or
111 | (check-equal? (rs (urlang (urmodule test-in-string
112 |                             (for/or ([x in-range 1 5]) x))))
113 |               1)
114 | (check-equal? (rs (urlang (urmodule test-in-string
115 |                             (for/or ([x in-range 1 5]) (= x 3)))))
116 |               'true)
117 | 
118 | (check-equal? (rs (urlang (urmodule test-in-string
119 |                             (for/or () 3))))
120 |               3)
121 | 
122 | ;;; Multiple clauses in for*
123 | (check-equal? (rs (urlang
124 |                    (urmodule test-for
125 |                      (define sum 0)
126 |                      (for* ([y in-range 1 11]
127 |                             [x in-array (array 1 2 3 4 5)])
128 |                        (+= sum x))
129 |                      sum)))
130 |               150)
131 | 
132 | (check-equal? (rs (urlang
133 |                    (urmodule test-for
134 |                      (define sum 0)
135 |                      (for* ([y in-range 1 11]
136 |                             [x in-array (array 1 2 3 4 5)])
137 |                        #:break (= y 5)
138 |                        (+= sum x))
139 |                      sum)))
140 |               (* 4 15))
141 | 
142 | ;;; Parallel clauses stop when one of the clauses are exhausted.
143 | (check-equal? (rs (urlang
144 |                    (urmodule test-for
145 |                      (define i 0)
146 |                      (for ([y in-range 1 11]
147 |                            [x in-range 1 5])
148 |                        (:= i (+ (* 10 y) x)))
149 |                      i)))
150 |               44)
151 | 
152 | (check-equal? (urlang (urmodule test-for (for/array ([x in-range 3 7]) x)))
153 |               (urlang (urmodule test-for2 (array 3 4 5 6))))
154 | 
155 | (check-equal? (urlang (urmodule test-for (for/array #:length 4 ([x in-range 3 7]) x)))
156 |               (urlang (urmodule test-for2 (array 3 4 5 6))))
157 | 
158 | (check-equal? (urlang (urmodule test-for  (array 42 (for/array #:length 4 ([x in-range 3 7]) x))))
159 |               (urlang (urmodule test-for2 (array 42 (array 3 4 5 6)))))
160 | 
161 | 
162 | ;;; check for in expression context
163 | (check-equal? (rs (urlang (urmodule test-for (+ 0 (for/sum ([x in-range 1 6]) x)))))
164 |               15)
165 | 


--------------------------------------------------------------------------------
/urlang/tests/test-new-expressions.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | (require urlang urlang/extra)
 3 | 
 4 | ;;;
 5 | ;;; TEST
 6 | ;;;
 7 | 
 8 | ; This file contains tests for the new expression:
 9 | 
10 | ; (new constructor-id)
11 | ; (new constructor-id argument-expression ...)
12 | 
13 | ;;; Note: No output means all tests ran successfully.
14 | 
15 | ;;; Note: You need to install  node  in order to run these tests.
16 | ;;;            https://nodejs.org/en/
17 | 
18 | ;;; Running these tests will for each module produce
19 | ;;; both a JavaScript file and a file containing names of exports.
20 | 
21 | ;;; Then node (a command line version of the JavaScript engine
22 | ;;; used in Chrome) is invoked on the JavaScript file, and the
23 | ;;; output is compared with the expected output.
24 | 
25 | (current-urlang-run?                           #t) ; run using Node?
26 | (current-urlang-echo?                          #f) ; print generated JavaScript?
27 | (current-urlang-console.log-module-level-expr? #t)
28 | 
29 | (require rackunit)
30 | (define (rs s) (read (open-input-string s))) ; note: only reads FIRST value
31 | 
32 | 
33 | (check-equal? (rs (urlang (urmodule test-new1
34 |                             (import this)
35 |                             (define (Car make model year)
36 |                               (:= this "make"   make)
37 |                               (:= this "model"  model)
38 |                               (:= this "year"   year))
39 |                             (define c1 (new Car "Toyota"  "Aygo" 2015))
40 |                             (define c2 (new Car "Renault" "Clio" 2016))
41 |                             ;c1.make
42 |                             ;c2.make
43 |                             ;(:= c1 "year" 2017)
44 |                             ;c1.year
45 |                             c2.year)))
46 |               2016)
47 | 
48 | 


--------------------------------------------------------------------------------
/urlang/tests/test-operators.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | (require urlang urlang/extra)
 3 | 
 4 | ;;;
 5 | ;;; TEST
 6 | ;;;
 7 | 
 8 | ; This file contains tests for the new expression:
 9 | 
10 | ; (new constructor-id)
11 | ; (new constructor-id argument-expression ...)
12 | 
13 | ;;; Note: No output means all tests ran successfully.
14 | 
15 | ;;; Note: You need to install  node  in order to run these tests.
16 | ;;;            https://nodejs.org/en/
17 | 
18 | ;;; Running these tests will for each module produce
19 | ;;; both a JavaScript file and a file containing names of exports.
20 | 
21 | ;;; Then node (a command line version of the JavaScript engine
22 | ;;; used in Chrome) is invoked on the JavaScript file, and the
23 | ;;; output is compared with the expected output.
24 | 
25 | (current-urlang-run?                           #t) ; run using Node?
26 | (current-urlang-echo?                          #t) ; print generated JavaScript?
27 | (current-urlang-console.log-module-level-expr? #t)
28 | 
29 | (require rackunit)
30 | (define (rs s) (read (open-input-string s))) ; note: only reads FIRST value
31 | 
32 | 
33 | (check-equal? (rs (urlang (urmodule test-add1 (+ 1 2)))) 3)
34 | (check-equal? (rs (urlang (urmodule test-add1 (+ 1))))   1)
35 | (check-equal? (rs (urlang (urmodule test-add1 (+))))     0)
36 | (check-equal? (rs (urlang (urmodule test-add1 (+ 1 2 3)))) 6)
37 | 
38 | (check-equal? (rs (urlang (urmodule test-add1 (* 2 3)))) 6)
39 | (check-equal? (rs (urlang (urmodule test-add1 (* 2))))   2)
40 | (check-equal? (rs (urlang (urmodule test-add1 (*))))     1)
41 | 
42 | 
43 | (check-equal? (rs (urlang (urmodule test-add1 (- 1 2)))) -1)
44 | (check-equal? (rs (urlang (urmodule test-add1 (- 1))))   -1)
45 | ;(check-equal? (rs (urlang (urmodule test-add1 (-))))      "error")
46 | 
47 | ;(check-equal? (rs (urlang (urmodule test-add1 (% 1))))   -1)
48 | 


--------------------------------------------------------------------------------