Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Added readme and removed spork (a newer version of it is already in a…

…nother github repository)
  • Loading branch information...
commit 541e5a38de5eaa8d8c383cb5532dbe1fdcb685de 1 parent 173f249
@pereckerdal authored
View
6 README
@@ -0,0 +1,6 @@
+This repository contains useful libraries for use with the blackhole
+module system. It contains some basic data structures, implementations
+of some SRFIs, a web server and client, and some utility modules.
+
+When installed into the std directory of blackhole, the modules will
+be accessible with for instance (import (std srfi/1))
View
281 spork/block.scm
@@ -1,281 +0,0 @@
-(import js)
-
-(export block-name
- block-attributes
- block-children
- block-transaction?
- block-transaction
- block-transaction!
- block-name-set!
- block-child-append!
- block-child-prepend!
- block-child-remove!
- block-clear-children!
- block-attribute-set!
- block-text-content
- block-text-content-set!
- block-attribute
- block-has-attribute?
- block-has-child-nodes?
- block-child-ref
- block-attribute-remove!
- block)
-
-(define-type block-t
- name
- attributes
- children)
-
-(define (make-block var-fun name rest)
- (let* ((maybe-atts (car rest))
- (args (cdr rest))
- (maybe-attrs-is-attrs (and (pair? maybe-attrs)
- (eq? '@ (car maybe-attrs))))
- (block (var-fun
- (make-block-t name
- (if maybe-attrs-is-attrs
- (cdr maybe-attrs)
- '())
- (if maybe-attrs-is-attrs
- args
- (cons maybe-attrs args))))))
- (lambda (#!optional (action 'render) value)
- (cond
- ((eq? action 'render)
- (let ((b (block)))
- `(,(block-t-name b)
- ,@(let ((attrs (block-t-attributes b)))
- (if (null? attrs)
- '()
- `((@ ,@attrs))))
- ,@(block-t-children b))))
-
- ((eq? action 'get)
- (block))
-
- ((eq? action 'set!)
- (block value))
-
- (else
- (error "Invalid block action" action))))))
-
-(define (block-get-block-t block)
- (block 'get))
-
-(define-type transaction-cons
- car
- cdr)
-
-(define-type transaction-t
- block
- fun
- args)
-
-(define null-transaction (list 'null-transaction))
-
-(define current-transaction (make-parameter #f))
-
-(define-syntax block
- (syntax-rules ()
- ((block name args ...)
- (make-block make-variable
- `name
- `(args ...)))))
-
-(define (block-name block)
- (block-t-name (block-get-block-t block)))
-
-(define (block-attributes block)
- (block-t-attributes (block-get-block-t block)))
-
-(define (block-children block)
- (block-t-children (block-get-block-t block)))
-
-(define (block-transaction? obj)
- (or (transaction-t? obj)
- (eq? obj null-transaction)
- (transaction-cons? obj)))
-
-(define (block-transaction thunk)
- (parameterize
- ((current-transaction null-transaction))
- (thunk)
- (current-transaction)))
-
-(define (block-add-transaction-action! transaction)
- (current-transaction
- (make-transaction-cons transaction
- (current-transaction))))
-
-(define (block-transaction! thunk)
- (block-add-transaction-action!
- (block-transaction thunk)))
-
-
-;; Utility function for the letrec-syntax macros below.
-;; functions is an a-list of the form (element-name . javascript-function-sexp)
-(define (make-block-js-module functions)
- (println
- (js-module-code
- (make-js-module
- '(process-block-element)
- (list core-module)
- `((define process-block-functions
- (obj
- ,@(apply
- append
- (map (lambda (pair)
- (list (car pair)
- (cdr pair)))
- functions))))
-
- (define (process-block-element element)
- (let ((block (document.getElementById
- (element.getAttribute "bid"))))
- (for-each
- (lambda (elm)
- ((ref process-block-functions elm.nodeName) block elm))
- element.childNodes))))))))
-
-(letrec-syntax
- ((action-function
- (syntax-rules ()
- ((action fun-name _ action-fun __)
- (define (fun-name block . args)
- (block-add-transaction-action!
- (make-transaction-t block action-fun args))))))
-
- (action-functions
- (syntax-rules ()
- ((action-functions (action ...))
- (action-function action ...))
-
- ((action-functions (action ...) rest ...)
- (begin
- (action-function action ...)
- (action-functions rest ...)))))
-
- (action-js-function
- (syntax-rules ()
- ((action-js-function) '())
-
- ((action-js-function (_ elm-name __ action-fun) rest ...)
- (cons (cons 'elm-name 'action-fun)
- (action-js-function rest ...)))))
-
- (action-js
- (syntax-rules ()
- ((action-js action ...)
- (make-block-js-module
- (action-js-function action ...)))))
-
- (actions
- (syntax-rules ()
- ((actions action ...)
- (begin
- (action-js action ...)
- (action-functions action ...))))))
-
- (actions
- (block-name-set!
- nn
- (lambda (name attrs children new-name)
- (values new-name
- attrs
- children
- `(nn (@ (v ,new-name)))))
- (lambda (block node)
- (set! block.nodeName (node.getAttribute "v"))))
-
- (block-child-append!
- ca
- (lambda (name attrs children . val)
- (values name
- attrs
- (append children
- (list val))
- `(ca ,@val)))
- (lambda (block node)
- (for-each (lambda (n)
- (block.appendChild n))
- node.childNodes)))
-
- (block-child-prepend!
- cp
- (lambda (name attrs children . val)
- (values name
- attrs
- (cons val children)
- `(cp ,@val)))
- (lambda (block node)
- (let ((first-child block.firstChild))
- (for-each (lambda (n)
- (block.insertBefore n first-child))
- node.childNodes))))
-
- (block-child-remove!
- cr
- (lambda (name attrs children val)
- (values name
- attrs
- (filter (lambda (x)
- (not (eq? x val)))
- children)
- `(cr (@ (i ,TODO)))))
- (lambda (block node)
- (block.removeChild
- (ref block.childNodes
- (node.getAttribute "i")))))
-
- (block-clear-children!
- cc
- (lambda (name attrs children)
- (values name
- attrs
- '()
- `(cc)))
- (lambda (block node)
- (while block.childNodes.length
- (block.removeChild block.firstChild))))
-
- (block-attribute-set!
- as
- (lambda (n attrs c name val)
- (let ((old-attrs
- (filter (lambda (x)
- (not (eq? x name)))
- attrs)))
- (values n
- (if val
- (cons (list name val)
- old-attrs)
- old-attrs)
- c
- `(as (@ (n ,name) (v ,val))))))
- (lambda (block node)
- (block.setAttribute (node.getAttribute "n")
- (node.getAttribute "v"))))))
-
-(define (block-text-content block)
- 'TODO)
-
-(define (block-text-content-set! block text)
- (block-transaction!
- (lambda ()
- (block-clear-children! block)
- (block-child-append! text))))
-
-(define (block-attribute block name)
- (al-get (block-attributes block) name))
-
-(define (block-has-attribute? block name)
- (assoc (block-attributes block) name))
-
-(define (block-has-child-nodes? block)
- (null? (block-children block)))
-
-(define (block-child-ref block idx)
- (list-ref (block-children block) idx))
-
-(define (block-attribute-remove! block name)
- (block-attribute-set! block name #f))
View
207 spork/comet.scm
@@ -1,207 +0,0 @@
-(import ;; (termite) TODO It's not possible to import termite right now
- ../srfi/1
- ../net/http-server
- js
- widget
- core)
-
-(export comet-js-module
-
- comet-connect
- comet-connection-do
- comet-connection-close!
-
- make-comet
- comet?
- comet-add!
- comet-remove!
- comet-send
- comet-close!)
-
-(define comet-js-module
- (js-module ()
- (core-js-module)
-
- (define (on-data-fun xhr)
- (let ((pos 256))
- (lambda ()
- (let loop ()
- (let* ((str (xhr.responseText.substr pos))
- (nl-pos (str.indexOf "\n")))
- (if (not (eq? -1 nl-pos))
- (let* ((len (parseInt (str.substr 0 nl-pos)))
- (data-pos (+ nl-pos 1))
- (end-pos (+ data-pos len)))
- (if (>= str.length (+ data-pos len))
- (begin
- (eval (str.substr data-pos
- end-pos))
- (set! pos (+ pos end-pos))
- (loop))))))))))
-
- (set! Comet
- (lambda (address)
- ;; The setTimeout is a hack to avoid loading bars in WebKit
- ;; (at least). There might me a more elegant solution to this.
- (setTimeout
- (lambda ()
- (let* ((xhr (new XMLHttpRequest))
- (on-data (on-data-fun xhr)))
- (xhr.open "POST" address #t)
- (set! xhr.onreadystatechange
- (lambda ()
- (if (eq? 3 .readyState)
- (on-data))))
- (xhr.send null)))
- 20)))))
-
-
-(define x*256 "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\
- xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\
- xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\
- xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\
- xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx")
-
-(define-type comet-connection
- id: 985E1855-B9EA-48BD-B1A1-F99F13F67EE7
- constructor: comet-conn-constructor
- predicate: comet-conn-pred
- process)
-
-(define comet-connection? comet-conn-pred)
-
-(define (comet-connect setter
- #!optional
- keepalive-msg
- webkit-workaround)
- (call/cc
- (lambda (ret)
- (reply-chunk
- (lambda (send-chunk)
- (call/cc
- (lambda (close)
- ;; Work around limitation of Webkit
- (if webkit-workaround
- (send-chunk (lambda () (display x*256))))
-
-
- (let* ((conn (comet-conn-constructor #f))
- (send
- (lambda (str)
- (with-exception-catcher
- (lambda (e)
- (comet-connection-process-set! conn #f)
- (close))
- (lambda ()
- (send-chunk
- (lambda ()
- (let ((vec (with-output-to-u8vector
- '(char-encoding: UTF-8 eol-encoding: cr-lf)
- (lambda () (display str)))))
- (display (number->string
- (u8vector-length vec)))
- (display "\n")
- (write-subu8vector vec 0 (u8vector-length vec))))))))))
-
- (comet-connection-process-set!
- conn
- (spawn
- (lambda ()
- (let loop ()
- (recv
- (('send str)
- (send str))
-
- ('close
- (close))
-
- (after 60
- (if keepalive-msg
- (send keepalive-msg))))
- (loop)))))
-
- (cond
- ((comet? setter)
- (comet-add! setter conn))
-
- ((procedure? setter)
- (setter conn))
-
- (else
- (error "Invalid argument to comet-connect" setter))))
-
- (ret))))
- code: 200
- headers: '((content-type . application/x-socio-stream)))))
- (spork-die))
-
-(define (comet-connection-do comet js)
- (let ((proc (comet-connection-process comet)))
- (if proc
- (begin
- (! (comet-connection-process comet) (list 'send js))
- #t)
- #f)))
-
-(define (comet-connection-close! comet)
- (! (comet-connection-process comet) 'close))
-
-
-(define-type comet
- id: 6F5D65A1-6363-4AA7-AA79-4C43C0E1DE7D
- constructor: comet-constructor
- predicate: comet-pred
- conns
- mutex)
-
-(define (with-comet! cmt thunk)
- (let ((mtx (comet-mutex cmt)))
- (dynamic-wind
- (lambda ()
- (mutex-lock! mtx))
- thunk
- (lambda ()
- (mutex-unlock! mtx)))))
-
-(define (make-comet)
- (comet-constructor '() (make-mutex)))
-
-(define comet? comet-pred)
-
-(define (comet-add! comet conn)
- (with-comet!
- comet
- (lambda ()
- (comet-conns-set!
- comet
- (cons conn
- (comet-conns comet))))))
-
-(define (comet-remove! comet conn)
- (with-comet!
- comet
- (lambda ()
- (comet-conns-set!
- comet
- (delete! comet
- (comet-conns comet)
- eq?)))))
-
-(define (comet-send comet js)
- (with-comet!
- comet
- (lambda ()
- (comet-conns-set!
- comet
- (filter! (lambda (x)
- (comet-connection-do x js))
- (comet-conns comet))))))
-
-(define (comet-close! comet)
- (with-comet!
- comet
- (lambda ()
- (for-each (lambda (x)
- (comet-connection-close! x))
- (comet-conns comet))
- (comet-conns-set! comet '()))))
View
658 spork/core.scm
@@ -1,658 +0,0 @@
-(import ../net/http-server
- ../net/http-session
- ../net/uri
- ../srfi/1
- ../srfi/13
- ../string/util
- ../string/sxml-to-xml
- ../misc/exception
- ../misc/al
- ../misc/splice
- counter)
-
-(syntax-begin
- (import (only: ../srfi/1 filter)))
-
-(export make-spork
- spork?
- spork-pattern
- spork-function
- spork-prefix
- spork-prefix!
- spork
- add-spork
-
- cutlery?
- make-cutlery
- cutlery-join
- cutlery-join!
- cutlery-add-spork!
- cutlery-add!
- cutlery-sporks
- cutlery-prefix
- cutlery-prefix!
-
- registry-put!
- register-function
- spork-die
- spork-reply-dont-die
- spork-reply
- spork-reply-xml
-
- goto
- goto-here
-
- fork
- ajax-fork
- show
-
- spork-server?
- spork-server-errors
- spork-server-errors-set!
- spork-server-public-kids
- spork-server-public-kids-set!
- spork-server-cutlery
- spork-server-cutlery-set!
- spork-server-root
- spork-server-root-set!
- make-spork-server
- spork-server-define-error
-
- show-error
- force-method
-
- spork-server-run
- spork-serve
-
- splice
- splice?
- unsplice
-
- make-backtrackable-variable
- make-session-variable
- make-variable)
-
-;; Sporks
-
-(define-type spork
- id: 3E6E0900-4308-4D58-8DF9-EE220A415355
- (pattern read-only:)
- (function read-only:))
-
-(define (spork-prefix spork prefix)
- (make-spork (cons prefix (spork-pattern spork))
- (spork-function spork)))
-
-(define (spork-prefix! spork prefix)
- (spork-pattern spork
- (cons prefix
- (spork-pattern spork))))
-
-;; TODO This is only used by spork, so it should be in a let-syntax
-;; really, but the module system doesn't support that right now.
-(define-syntax lambda-ignorestring
- (sc-macro-transformer
- (lambda (form env)
- `(lambda ,(filter identifier? (cadr form))
- ,@(cddr form)))))
-
-(define-syntax spork
- (syntax-rules ()
- ((spork (args ...) body ...)
- (make-spork
- '(args ...)
- (lambda-ignorestring
- (args ...)
- (show
- (lambda (url)
- body ...)))))))
-
-(define-syntax add-spork
- (syntax-rules ()
- ((add-spork name (args ...) body ...)
- (cutlery-add-spork!
- name
- (spork (args ...) body ...)))))
-
-;; Cutleries
-
-(define-type cutlery
- id: D9017117-DA9D-4C17-AF35-63B02220B414
- constructor: make-cutlery-internal
- pages)
-
-(define (make-cutlery . sporks)
- (make-cutlery-internal sporks))
-
-(define (cutlery-join a b)
- (make-cutlery-internal
- (append
- (cutlery-pages a)
- (cutlery-pages b))))
-
-(define (cutlery-join! a b)
- (cutlery-pages-set!
- a
- (append (cutlery-pages a)
- (cutlery-pages b)))
- a)
-
-(define (cutlery-add-spork! c spork)
- (cutlery-pages-set!
- c
- (cons spork
- (cutlery-pages c)))
- (void))
-
-(define (cutlery-add! c address fun)
- (cutlery-add-spork! c (make-spork address fun)))
-
-(define (cutlery-sporks c)
- (cutlery-pages c))
-
-(define (cutlery-prefix c prefix)
- (apply make-cutlery
- (map (lambda (spork)
- (spork-prefix spork prefix))
- (cutlery-sporks c))))
-
-(define (cutlery-prefix! c prefix)
- (for-each (lambda (spork)
- (spork-prefix! spork prefix))
- (cutlery-sporks c)))
-
-;; Pages
-
-(define (address-match? s addrs)
- (let ((ret '()))
- (and (let loop ((addr addrs) (str s))
- (if (null? addr)
- (eq? 0 (string-length str))
- (let ((hd (car addr)))
- (cond
- ((symbol? hd)
- (let ((pos (if (null? (cdr addr))
- (string-length str)
- (string-contains str (cadr addr)))))
- (if pos
- (begin
- (set! ret (cons (substring str 0 pos) ret))
- (loop (cdr addr)
- (substring str pos (string-length str))))
- #f)))
- ((string? hd)
- (if (string-prefix? hd str)
- (loop (cdr addr)
- (string-remove-prefix str hd))
- #f))))))
- (reverse ret))))
-
-(define (split-path url)
- (let ((pos (string-contains url "/@")))
- (if pos
- (cons (string-remove-prefix (substring url 0 pos) "/")
- (substring url (+ pos 2) (string-length url)))
- (cons (string-remove-prefix url "/")
- #f))))
-
-(define (call-page cutlery addr)
- (let loop ((page (cutlery-sporks cutlery)))
- (if (null? page)
- #f
- (if (let ((res (address-match? addr (spork-pattern (car page)))))
- (if res
- (parameterize
- ((current-frame (cons '() #f)))
- (apply (spork-function (car page)) res)
- (spork-reply
- (lambda ()
- (print "Ehh... return to call-page (this is an error)\n"))))
- #f))
- #t
- (loop (cdr page))))))
-
-
-(define current-path/server (make-parameter #f))
-
-;; Core
-
-(define kid-registry (make-session-variable (make-table)))
-(define public-kid-registry (make-table))
-(define current-frame (make-parameter #f))
-
-(define generate-continuation-id
- (make-randomizer "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890-_.,:;$[]*/"))
-
-(define (generate-unique-continuation-id #!optional registry)
- (let loop ((tries 0))
- (if (> tries 1000)
- (error "Failed to generate continuation id")
- (let ((id (generate-continuation-id)))
- (if (table-ref (or registry (kid-registry)) id #f)
- (loop (+ tries 1))
- id)))))
-
-(define (registry-put! fun #!optional public kid)
- (let* ((registry (if public
- (spork-server-public-kids public)
- (kid-registry)))
- (kid (or kid (generate-unique-continuation-id
- registry))))
- (table-set! registry
- kid
- (cons fun
- (current-frame)))
- (let* ((cp (current-path/server))
- (server (if cp
- (cdr cp)
- default-server))
- (root (spork-server-root server)))
- (string-append
- root
- (if cp
- (let ((str (caar cp)))
- (if (eq? 0 (string-length str))
- ""
- (string-append "/" str)))
- "")
- (if public "/@@" "/@")
- kid))))
-
-(define (registry-run kid param #!optional public)
- (let ((res (table-ref (if public
- public-kid-registry
- (kid-registry))
- kid
- #f)))
- (if res
- (parameterize
- ((current-frame (cons '()
- (cdr res))))
- ((car res) param))
- #f)))
-
-(define suicide (make-parameter #f))
-
-(define (spork-die)
- ((suicide) #f))
-
-(define (register-function fun #!optional public kid)
- (registry-put!
- (lambda (ret)
- (fun)
- (reply (lambda ()
- (print "ehh.. return from register-function")))
- (spork-die))
- public
- kid))
-
-(define (spork-reply-dont-die . args)
- (run-before-show)
- (apply reply args))
-
-(define (spork-reply . args)
- (apply spork-reply-dont-die args)
- (spork-die))
-
-(define (spork-reply-xml . args)
- (run-before-show)
- (apply reply-xml args)
- (spork-die))
-
-(define (goto url #!optional (run-before #t))
- (if run-before
- (run-before-show))
- (http-redirect 303 (render-widget-with-env url))
- (spork-die))
-
-(define (goto-here #!optional (run-before #t))
- (call/cc
- (lambda (k)
- (goto (registry-put! k) run-before))))
-
-;; Widgets
-
-(define (fork a b)
- (letrec ((forked
- (make-backtrackable-variable
- (delay
- ;; Registry put has to be called from within
- ;; the lambda below and the a function must
- ;; only be invoked once, hence the delay.
- ;;
- ;; It's important that render-widget-cont is
- ;; captured here; It's not initialized when fork
- ;; is called first, and it will be lost at the time
- ;; the registry-put! callback is invoked.
- ;;
- ;; Ie: render-widget-cont is only valid in
- ;; the widget rendering phase
- (let* ((rwc (render-widget-cont)))
- (a (lambda ()
- (registry-put!
- (lambda (ret)
- ;; The modification of forked is sent as
- ;; a thunk to rwc. This is because
- ;; forked has to be set in the dynamic
- ;; environment of the render and not of
- ;; this request.
- (rwc
- (cons (current-frame)
- (lambda ()
- (forked
- (delay
- ;; Who knows when this will be
- ;; called. It's best to use the
- ;; query of the current dynamic
- ;; environment and not ret above.
- (b (request-query
- (current-request)))))))))))))))))
- (lambda () (force (forked)))))
-
-
-(define run-before-show-redirect
- (make-parameter #t))
-
-(define (run-before-show)
- ;; This is to assist ajax-fork.
- (if (and (run-before-show-redirect)
- (assoc "__frk" (request-get-query (current-request))))
- (parameterize
- ((run-before-show-redirect #f))
- (show
- (lambda (url)
- `(e (@ (r ,url))))
- doctype: 'xml
- mime: "text/xml"))))
-
-(define generate-ajax-fork-id
- (make-randomizer "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890"))
-
-(define (ajax-fork a b)
- (let* ((id (generate-ajax-fork-id))
- (f (fork
- (lambda (url)
- `(span
- (@ (id ,id))
- ,(a (lambda ()
- (string-append
- (url)
- "?_frk="
- id)))))
- b)))
- (lambda ()
- ;; The call to (f) has to be first, because it might do lots of
- ;; strange stuff with the continuation and it's important that
- ;; we don't cache values taken from (current-request) before
- ;; that. (Hence the let*)
- (let* ((v (render-widget (f)))
- (req-frk-id (al-get (request-get-query
- (current-request))
- "__frk")))
- (if (equal? req-frk-id id)
- (parameterize
- ((run-before-show-redirect #f))
- (show
- (lambda (url)
- `(e
- (@ (xmlns "http://www.w3.org/1999/xhtml"))
- ,v))
- doctype: 'xml
- mime: "text/xml"))
- v)))))
-
-
-;; This is initialized when the widget tree is being rendered,
-;; it points to the continuation just before the tree starts
-;; to be rendered.
-;; It is used by fork.
-(define render-widget-cont (make-parameter #f))
-
-(define (render-widget xml)
- (cond
- ((pair? xml)
- (let ((head (render-widget (car xml))))
- (if (splice? head)
- (append (map render-widget
- (unsplice head))
- (render-widget (cdr xml)))
- (cons head
- (render-widget (cdr xml))))))
-
- ((procedure? xml)
- (render-widget (xml)))
-
- (else
- xml)))
-
-(define (render-widget-with-env xml)
- (let* ((kont #f)
- (r (call/cc (lambda (k)
- (set! kont k)
- #f)))
- (thunk (lambda ()
- (parameterize
- ((render-widget-cont kont))
- (render-widget xml)))))
- (if r
- (parameterize
- ((current-frame (cons '() (car r))))
- ((cdr r)) ;; see fork
- (thunk))
- (thunk))))
-
-(define (show fun
- #!key
- (doctype 'xhtml1)
- (code 200)
- (headers '())
- (mime "text/html"))
- (call/cc
- (lambda (k)
- ;; Only save the continuation in the registry if it's actually used.
- (let* ((kid-promise (delay (registry-put! k)))
- (kid (lambda () (force kid-promise))))
- (spork-reply
- (lambda ()
- (let ((val (fun kid)))
- (if (and (not (string? val)) doctype)
- (let ((val (render-widget-with-env val)))
- (if (eq? doctype 'xml)
- (sxml>>xml-fast val)
- (sxml>>xhtml-fast val)))
- (print val))))
- code: code
- headers: headers
- type: mime)))))
-
-;; Web server
-
-(define-type spork-server
- id: 97796622-0CCE-4422-9521-6C1C054B3A2F
- constructor: make-spork-server-internal
- errors
- public-kids
- cutlery
- root)
-
-(define default-server
- (make-spork-server-internal '() #f #f ""))
-
-(define (make-spork-server cutlery #!key errors root)
- (make-spork-server-internal
- (or errors (spork-server-errors default-server))
- (make-table)
- cutlery
- (or root "")))
-
-(define (spork-server-define-error server num lambda)
- (spork-server-errors-set!
- server
- (cons (cons num lambda)
- (spork-server-errors server))))
-
-(define (show-error num . args)
- (let* ((path/server (current-path/server))
- (server (if path/server
- (cdr path/server)
- default-server))
- (v (assq num (spork-server-errors server))))
- (if v
- (spork-reply-xml (apply (cdr v) args)
- code: num)
- (error "Error page not defined" num))))
-
-;; Method is expected to be an uppercase string
-(define (force-method method)
- (if (not (equal? (request-method (current-request))
- method))
- (show-error 405)))
-
-(spork-server-define-error
- default-server 400
- (lambda (#!optional msg)
- `(html
- (head (title "Bad Request"))
- (body
- (h1 "Bad Request")
- (p ,(or msg
- "Invalid request."))))))
-
-(spork-server-define-error
- default-server 403
- (lambda ()
- `(html
- (head (title "Forbidden"))
- (body
- (h1 "Forbidden")
- (p "You don't have permission to access this page.")))))
-
-(spork-server-define-error
- default-server 404
- (lambda ()
- `(html
- (head (title "File Not Found"))
- (body
- (h1 "File Not Found")
- (p "The URL you requested could not be found.")))))
-
-(spork-server-define-error
- default-server 405
- (lambda ()
- `(html
- (head (title "Method Not Allowed"))
- (body
- (h1 "Method Not Allowed")
- (p "The request was made using an invalid method.")))))
-
-(spork-server-define-error
- default-server 500
- (lambda (#!optional exc)
- `(html
- (head (title "Internal Server Error"))
- (body
- (h1 "Internal Server Error")
- ,@(if (not exc)
- `((p "The server encountered an internal error or "
- "misconfiguration and was unable to complete "
- "your request."))
- `((pre
- ,(exception/continuation->string exc))))))))
-
-(define (handle-req server)
- (let ((cutlery (spork-server-cutlery server)))
- (call/cc
- (lambda (exit)
- (suicide exit)
- (let* ((req (current-request))
- (uri (request-uri req))
- (path (uri-path uri))
- (s-path (split-path path)))
- (parameterize
- ((current-path/server (cons s-path server)))
- (let ((id (cdr s-path))
- (url (car s-path)))
- (if id
- (if (let ((public (and (positive? (string-length id))
- (eq? #\@ (string-ref id 0)))))
- (not (registry-run (if public
- (substring id
- 1
- (string-length id))
- id)
- (request-query req)
- public)))
- (goto (string-append "/" url)))
- (if (not (call-page cutlery url))
- (show-error 404))))))))))
-
-(define (handle-req-catch-errs server)
- (lambda ()
- (with-exception/continuation-catcher
- (lambda (e)
- (show-error 500 e))
- (lambda ()
- (handle-req server)))))
-
-(define (spork-server-run server #!optional (port 8080))
- (http-server-start!
- (make-http-server (handle-req-catch-errs server)
- port)))
-
-(define (spork-serve #!key
- (port 8080)
- errors
- root)
- (let ((c (make-cutlery)))
- (thread-start!
- (make-thread
- (lambda ()
- (spork-server-run (make-spork-server c
- errors: errors
- root: root)
- port))))
- c))
-
-;; Backtrackable variables
-
-(define generate-bt-id #f)
-(let ((bt 0))
- (set! generate-bt-id
- (lambda ()
- (set! bt (+ bt 1))
- bt)))
-
-(define (bt-get id cf default)
- (let ((fv (assq id (car cf))))
- (if fv
- (cdr fv)
- (let ((parent-frame (cdr cf)))
- (if parent-frame
- (bt-get id parent-frame default)
- default)))))
-
-(define (bt-set! id val)
- (let ((cf (current-frame)))
- (set-car! cf
- (cons (cons id val)
- (car cf)))
- val))
-
-(define backtrackable-variable-nochange (gensym))
-
-(define (make-backtrackable-variable #!optional default-val)
- (let ((id (generate-bt-id)))
- (lambda (#!optional (val backtrackable-variable-nochange))
- (if (eq? val backtrackable-variable-nochange)
- (bt-get id (current-frame) default-val)
- (bt-set! id val)))))
-
-(define (make-variable #!optional default-val)
- (let ((val default-val))
- (lambda (#!optional (new-val backtrackable-variable-nochange))
- (if (eq? val backtrackable-variable-nochange)
- val
- (begin
- (set! val new-val)
- new-val)))))
-
View
39 spork/counter.scm
@@ -1,39 +0,0 @@
-(import ../srfi/13)
-
-(define (make-counter #!optional (serializer (lambda (x) x)))
- (let ((c -1))
- (lambda ()
- (set! c (+ c 1))
- (serializer c))))
-
-(define (counter-stringer str)
- (let ((gssymlen (string-length str)))
- (lambda (x)
- (reverse-list->string
- (let loop ((num x))
- (let ((idx (modulo num gssymlen)))
- (cons (string-ref str idx)
- (if (eq? idx num)
- '()
- (loop (/ (- num idx) gssymlen))))))))))
-
-(define (counter-prefixer c p)
- (lambda (x)
- (string-append p (c x))))
-
-(define (counter-symbolizer c)
- (lambda (x)
- (make-uninterned-symbol
- (c x))))
-
-
-(define (make-randomizer str #!optional (genlen 7))
- (let ((strlen (string-length str)))
- (lambda ()
- (let* ((ret (make-string genlen)))
- (let loop ((i 0))
- (if (< i genlen)
- (begin
- (string-set! ret i (string-ref str (random-integer strlen)))
- (loop (+ i 1)))))
- ret))))
View
97 spork/file.scm
@@ -1,97 +0,0 @@
-(import core
- ../misc/u8v)
-
-(export file-spork-mimes
- file-spork)
-
-;; I have no idea whether this works on non-Unix environments.
-;; I don't care right now.
-(define (is-directory? dir)
- (file-exists? (string-append dir "/")))
-
-(define (extract-extension fn)
- (let ((len (string-length fn)))
- (let loop ((i 0))
- (cond
- ((>= i len)
- fn)
-
- ((eq? (string-ref fn i) #\.)
- (substring fn i len))
-
- (else
- (loop (+ 1 i)))))))
-
-;; Root is assumed to be normalized, f might be but doesn't have to.
-(define (allowed-file? f root)
- (let ((len (string-length root))
- (fn (path-normalize f #f root)))
- (and (>= (string-length fn) len)
- (equal? root
- (substring fn 0 len))
- fn)))
-
-(define (read-file f root mimes)
- (let ((fn (allowed-file? f root)))
- (if (not fn) (show-error 400))
- (if (not (file-exists? fn)) (show-error 404))
- (if (is-directory? fn) (show-error 403))
-
- (with-input-from-file fn
- (lambda ()
- (spork-reply
- (lambda ()
- (dump-u8vector-port-to-other-u8vector-port
- (current-input-port)
- (current-output-port)))
- type: (or (table-ref mimes (extract-extension fn) #f)
- (table-ref mimes "default")))))))
-
-(define file-spork-mimes
- (list->table
- '((".avi" . "video/x-msvideo")
- (".bz2" . "application/x-bzip")
- (".class" . "application/octet-stream")
- (".css" . "text/css")
- (".dtd" . "text/xml")
- (".dvi" . "application/x-dvi")
- (".gif" . "image/gif")
- (".gz" . "application/x-gzip")
- (".htm" . "text/html")
- (".html" . "text/html")
- (".jpeg" . "image/jpeg")
- (".jpg" . "image/jpeg")
- (".js" . "text/javascript")
- (".m3u" . "audio/x-mpegurl")
- (".mov" . "video/quicktime")
- (".mp3" . "audio/mpeg")
- (".mpeg" . "video/mpeg")
- (".mpg" . "video/mpeg")
- (".ogg" . "application/ogg")
- (".pdf" . "application/pdf")
- (".png" . "image/png")
- (".ps" . "application/postscript")
- (".qt" . "video/quicktime")
- (".sig" . "application/pgp-signature")
- (".swf" . "application/x-shockwave-flash")
- (".tar" . "application/x-tar")
- (".tar.bz2" . "application/x-bzip-compressed-tar")
- (".tar.gz" . "application/x-tgz")
- (".tbz" . "application/x-bzip-compressed-tar")
- (".tgz" . "application/x-tgz")
- (".torrent" . "application/x-bittorrent")
- (".txt" . "text/plain")
- (".wav" . "audio/x-wav")
- (".wax" . "audio/x-ms-wax")
- (".wma" . "audio/x-ms-wma")
- (".wmv" . "video/x-ms-wmv")
- (".xml" . "text/xml")
- (".zip" . "application/zip")
- ("default" . "text/plain"))))
-
-(define (file-spork root #!key (path "") (mimes file-spork-mimes))
- (let ((root (path-normalize root)))
- (make-spork
- (list path 'filename)
- (lambda (filename)
- (read-file filename root mimes)))))
View
1,029 spork/js.scm
@@ -1,1029 +0,0 @@
-;; TODO Things I should add support for:
-;; Reuse gensyms over different scopes.
-;; the <><=>= operators don't support multiple arguments
-;; instanceof
-;; /= *= += -= and so on
-;; bitwise operators ... what are they called in scheme?
-;; do..while
-;; for..in
-;; continue break return?
-;; switch
-;; labels
-;; try..finally
-;; implement the scheme error function
-;; - doesn't work with only one argument
-;; Implement vector?/vector-fill!
-;; Make do work
-;; string-camelize crashes on --
-;; obj->query-string doesn't get converted to a js compatible thing
-
-
-(import ../srfi/1
- ../string/util
- ../string/pregexp
- counter)
-
-(syntax-begin
- (import ../string/util))
-
-(export with-js-environment
- js-compile
- js-compile-inside
- js-lambda
- js-lambda?
- js-fun
- js-str
-
- make-js-module
- js-module?
- js-module-symbols
- js-module-symbols-set!
- js-module-dependencies
- js-module-dependencies-set!
- js-module-macros
- js-module-macros-set!
- js-module-scm-code
- js-module-scm-code-set!
- js-module-id
- js-module-id-set!
- js-module-code
- js-module-code-set!
- make-constant-js-module
-
- js-code
- jsc
- jsp
- js-module
- define-js-module-object)
-
-(define-macro (push! var val)
- `(set! ,var (cons ,val ,var)))
-
-(define (any pred lst) ; This is ridiculously non-optimized
- (fold (lambda (a b) (or a b)) #f (map pred lst)))
-
-(define (append! lst rest)
- (cond
- ((null? lst) rest)
- ((null? (cdr lst)) (set-cdr! lst rest))
- (else (append! (cdr lst) rest))))
-
-(define-macro (condp name . conds)
- `(cond ,@(map (lambda (x) `((,(car x) ,name) ,@(cdr x))) conds)))
-
-(define (string-join between args)
- (apply string-append (join between args)))
-
-(define (pairify lst)
- (cond ((null? lst) '())
- ((null? (cdr lst)) lst)
- (else (cons (cons (car lst) (cadr lst)) (pairify (cddr lst))))))
-
-(define (transform-forms-to-pair form)
- (let* ((exprs '())
- (defs '())
- (push-expr (lambda (x)
- (set! exprs (cons x exprs))))
- (push-def (lambda (x)
- (set! defs (cons x defs)))))
- (for-each
- (lambda (x)
- (cond
- ((not (pair? x)) (push-expr x))
-
- ((eq? 'define (car x))
- (push-def x))
-
- ((eq? 'begin (car x))
- (let ((res (transform-forms-to-pair (cdr x))))
- (push-expr `(begin ,@(car res)))
- (for-each (lambda (x)
- (push-def x))
- (cdr res))))
-
- (else (push-expr x))))
- form)
- (cons (reverse exprs)
- (reverse defs))))
-
-(define (transform-forms-to-letrec form)
- (let ((res (transform-forms-to-pair form)))
- (if (null? (cdr res))
- form
- `((letrec ,(map (lambda (x)
- (let ((src (module#transform-to-lambda (cdr x))))
- src))
- (cdr res))
- ,@(car res))))))
-
-(define *js-macro-env* (make-parameter '()))
-
-(define *js-scope-env* (make-parameter '()))
-
-(define *js-gensym-env* (make-parameter #f))
-
-(define *js-gensym-symbols*
- "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ")
-
-(define *js-module-env* (make-counter
- (counter-symbolizer
- (counter-stringer
- *js-gensym-symbols*))))
-
-(define (js-gensym #!optional (env (*js-gensym-env*)))
- (env))
-
-(define (js-add-macro name body)
- (*js-macro-env* (cons (cons name
- body)
- (*js-macro-env*))))
-
-(define-macro (js-define-macro args . body)
- (if (symbol? args)
- `(js-add-macro (quote ,args) ,@body)
- (let ((name (car args))
- (args (cdr args)))
- `(js-add-macro (quote ,name) (lambda ,args ,@body)))))
-
-(define-macro (js-add-alpha exp from to)
- (let ((from-gs (gensym))
- (to-gs (gensym)))
- `(let ((,from-gs ,from)
- (,to-gs ,to))
- (map (lambda (exp)
- `(js-alpha-convert
- ,,from-gs
- ,,to-gs
- ,exp))
- ,exp))))
-
-(define (js-alpha-convert from to body)
- (cond
- ((and (symbol? body) (eq? body from))
- (js-expand-macro to))
- ((and (list? body) (not (null? body)))
- (if (and (eq? (car body) 'js-scope)
- (or (any (lambda (x) (eq? x from)) ; Search in the defined variables
- (cdadr body))
- (any (lambda (x) (eq? x from)) ; Search in the function's paramlist
- (caadr body))))
- body
- (map (lambda (x) (js-alpha-convert from to x)) body)))
- (else body)))
-
-(define (js-expand-macro expr)
- (if (list? expr)
- (let ((mac (assoc (car expr) (*js-macro-env*)))
- (hd (car expr)))
- (if mac
- (js-expand-macro (apply (cdr mac) (cdr expr)))
- (cond
- ((eq? hd 'js-syntax)
- `(js-syntax ,@(map js-expand-macro (cdr expr))))
- ((eq? hd 'js) expr)
- ((eq? hd 'js-scope)
- (parameterize
- ((*js-scope-env* (cadr expr))
- (*js-macro-env* (*js-macro-env*)))
- `(js-scope ,(cadr expr)
- ,@(map js-expand-macro (cddr expr)))))
- ((eq? hd 'js-alpha-convert)
- (js-alpha-convert (cadr expr)
- (caddr expr)
- (js-expand-macro (cadddr expr))))
- (else
- `(js-syntax ,(js-expand-macro (car expr))
- (js "(")
- ,@(join '(js ",") (map js-expand-macro (cdr expr)))
- (js ")"))))))
- expr))
-
-(define (js-undotify body)
- (cond
- ((symbol? body)
- (let* ((str (symbol->string body))
- (spl (string-split #\. str))
- (spl (if (equal? (car spl) "")
- (cons "this" (cdr spl))
- spl)))
- (if (null? (cdr spl))
- body
- `(: ,@(map string->symbol spl)))))
-
- ((pair? body) (map js-undotify body))
-
- (else body)))
-
-(define (with-js-environment thunk)
- (parameterize
- ((*js-gensym-env* (make-counter
- (counter-symbolizer
- (counter-stringer
- *js-gensym-symbols*))))
- (*js-macro-env* (*js-macro-env*)))
- (thunk)))
-
-(define (js-compile expr
- #!optional
- (env (cons
- (make-counter
- (counter-symbolizer
- (counter-stringer
- *js-gensym-symbols*)))
- (*js-macro-env*))))
- (parameterize
- ((*js-gensym-env* (car env))
- (*js-macro-env* (cdr env)))
- (cons (js-compile-inside (js-undotify expr))
- (cons (*js-gensym-env*)
- (*js-macro-env*)))))
-
-(define (js-compile-inside expr)
- (let ((expr (js-expand-macro expr)))
- (condp
- expr
- (string? (string-append
- "\""
- (pregexp-replace*
- "\n"
- (pregexp-replace*
- "\""
- expr
- "\\\\\"")
- "\\\\\\n")
- "\""))
- (null? "null")
- (symbol? (string-camelize (symbol->string expr)))
- (number? (number->string expr))
- (boolean? (if expr "true" "false"))
- (list? (let ((h (car expr)))
- (cond
- ((eq? h 'js)
- (apply string-append (cdr expr)))
- ((eq? h 'js-syntax)
- (apply string-append (map js-compile-inside (cdr expr))))
- ((eq? h 'js-scope)
- (let ((vars (cdadr expr)))
- (string-append
- (if (null? vars)
- ""
- (string-append
- "var "
- (string-join ","
- (map symbol->string
- (cdadr expr)))
- ";"))
- (apply string-append
- (map js-compile-inside
- (cddr expr))))))
- (else
- (error "Invalid expression" expr))))))))
-
-; Compiler utility macros
-
-(define-macro (jsc expr)
- `(car (js-compile (quote ,expr))))
-
-(define-macro (jsp expr)
- `(print (jsc ,expr) "\n"))
-
-;; Javascript lambdas
-
-(define-type js-fun
- id: 3B52B8C0-FFF0-43AF-8CA3-FD3AD60848A5
- str
- fun)
-
-(define-syntax js-lambda
- (syntax-rules ()
- ((js-lambda args body ...)
- (make-js-fnu
- (js-compile '(lambda args body ...))
- (lambda args body ...)))))
-
-(define js-lambda? js-fun?)
-
-(define (js-fun fun)
- (js-fun-fun fun))
-
-(define (js-str fun)
- (js-fun-str fun))
-
-;; Javascript modules
-
-(define *current-module* (make-parameter #f))
-
-(define-type js-module
- id: B2010B92-674C-459C-B20F-AD73B4EEA30D
- symbols
- dependencies
- macros
- scm-code
- id
- code)
-
-(let ((orig-fun make-js-module))
- (set! make-js-module
- (lambda (syms deps code)
- (let ((c (make-counter
- (counter-symbolizer
- (counter-stringer
- *js-gensym-symbols*)))))
- (let ((exports (map (lambda (x)
- (cons x (c)))
- syms))
- (mod-id (*js-module-env*)))
- (orig-fun
- exports
- deps
- '()
- code
- mod-id
- (parameterize
- ((*current-module* (cons mod-id
- exports)))
- (string-append
- (car
- (js-compile
- `(with-modules
- ,deps
- (begin
- (set! _
- (if (equal? (typeof _) "undefined")
- (obj)
- _))
- (set!
- (: _ ,mod-id)
- (let ((mod (obj)))
- ,@code
- ,@(map (lambda (x)
- `(set! (: mod ,(cdr x)) ,(car x)))
- exports)
- mod))))))
- ";"))))))))
-
-(define-macro (js-module syms deps . code)
- `(make-js-module ',syms (list ,@deps) ',code))
-
-(define-syntax define-js-module-object
- (sc-macro-transformer
- (lambda (form env)
- (apply
- (lambda (name mod)
- (let* ((name-sc (make-syntactic-closure env '() name))
- (mod-sc (make-syntactic-closure env '() mod))
- (old-id (with-exception-catcher
- (lambda (e)
- #f)
- (lambda ()
- (js-module-id (eval name-sc))))))
- (if old-id
- `(begin
- (set! ,name-sc
- ;; This will cause needless double compilation
- (let ((var ,mod-sc))
- (js-module-id-set! var ',old-id))))
- `(define ,name-sc ,mod-sc))))
- (cdr form)))))
-
-(js-define-macro (with-module mod body)
- (let ((mod-id (js-module-id mod)))
- (for-each (lambda (id)
- (set! body
- `(js-alpha-convert
- ,(car id)
- (: _ ,mod-id ,(cdr id))
- ,body)))
- (js-module-symbols mod)))
- body)
-
-(js-define-macro (js-mangle-name sym)
- (string-append
- "_."
- (symbol->string (car (*current-module*)))
- "."
- (let ((p (assq sym
- (cdr (*current-module*)))))
- (symbol->string
- (if p
- (cdr p)
- sym)))))
-
-(js-define-macro (with-modules mods body)
- (for-each (lambda (mod)
- (set! body
- `(with-module ,mod
- ,body)))
- mods)
- body)
-
-(define (js-code deps code)
- (car
- (js-compile
- `(with-modules
- ,deps
- ,code))))
-
-
-;; Core language macros
-
-(js-define-macro (define . args)
- `(set! ,@(module#transform-to-lambda args)))
-
-(js-define-macro (define-macro . args)
- (let* ((v (module#transform-to-lambda args))
- (name (car v))
- (val (cadr v)))
- (js-add-macro name (eval val))
- `(begin)))
-
-; This macro is for creating javascript functions. There are some quirks
-; regarding functions and scoping, so the use of this HIGHLY recommended
-; in favor of creating own function(){} syntax expressions.
-;
-; See lambda and the non-optimized version of let.
-;
-; There are two js-scope expressions in this macro. The first is just to
-; "protect" the parameters from alpha conversion, the second is both to
-; protect from alpha conversion and to add the appropriate var ...;
-; declarations on the right place. (ie, within the function definition)
-(js-define-macro (statement-wrapper vars . body)
- (let* ((gs (map (lambda (x) (js-gensym)) vars))
- (body ; For each expression in the body, add alpha conversion
- (map (lambda (res)
- (for-each (lambda (v g)
- (set! res
- `(js-alpha-convert ,v ,g ,res)))
- vars
- gs)
- res)
- body)))
- `(js-syntax (js-scope ,(list vars)
- (js "(function(")
- ,@(join '(js ",") gs)
- (js "){"))
- (js-scope ,(list vars)
- ,@body
- (js "})")))))
-
-(js-define-macro (lambda vars . body)
- `(statement-wrapper
- ,vars
- (js "return ")
- (begin ,@(transform-forms-to-letrec body))))
-
-(js-define-macro (trylet a #!optional name block)
- (let ((gs (js-gensym)))
- `(js-syntax
- (statement-wrapper
- ()
- (js "try{return ")
- ,a
- (js "}catch(")
- ,gs
- (js"){")
- ,@(if name
- `((js "return ")
- (js-alpha-convert
- ,name
- ,gs
- ,block))
- '())
- (js "}"))
- (js "()"))))
-
-(js-define-macro (try a b)
- (let ((sym (js-gensym)))
- `(trylet ,a
- ,sym
- (js-syntax ,b (js "(" ,(symbol->string sym) ")")))))
-
-(js-define-macro (throw a)
- `((statement-wrapper () (js "throw ") ,a)))
-
-;; Non-optimized let-macro. I keep it for reference and/or debugging
-(js-define-macro (let vars . body)
- `((lambda ,(map car vars) (begin ,@body))
- ,@(map cadr vars)))
-
-; Let-macro implemented with alpha-conversion
-(js-define-macro (let vars . body)
- (if (symbol? vars) ; Let loop
- `(letrec ((,vars (lambda ,(map car (car body))
- ,@(cdr body))))
- (,vars ,@(map cadr (car body))))
- (if (null? (*js-scope-env*))
- `((lambda ,(map car vars) (begin ,@body))
- ,@(map cadr vars))
- (let ((syms (map (lambda (x) (js-gensym)) vars)))
- `(begin
- ,@(map (lambda (v gs)
- (set! body
- (js-add-alpha body (car v) gs))
- (append! (*js-scope-env*) (list gs))
- `(set! ,gs ,(cadr v)))
- vars syms)
- ,@(transform-forms-to-letrec body))))))
-
-(js-define-macro (letrec vars . body)
- (if (null? (*js-scope-env*))
- ;; This is to hinder the letrec from leaking scope.
- `((lambda ()
- (letrec ,vars ,@body)))
- (let* ((alphas '())
- (syms (map (lambda (v)
- (let ((gs (js-gensym)))
- (set! alphas
- (cons (cons (car v) gs)
- alphas))
- gs))
- vars))
- (ret
- `(begin
- ,@(map (lambda (v gs)
- (set! body
- (js-add-alpha body (car v) gs))
- (append! (*js-scope-env*) (list gs))
- (let ((expr (cadr v)))
- (for-each (lambda (a)
- (set! expr
- `(js-alpha-convert
- ,(car a)
- ,(cdr a)
- ,expr)))
- alphas)
- `(set! ,gs ,expr)))
- vars syms)
- ,@body)))
- ret)))
-
-(js-define-macro (let* vars . body)
- (if (null? vars)
- `(begin ,@body)
- `(let (,(car vars))
- (let* ,(cdr vars)
- ,@body))))
-
-(js-define-macro (ref var . args)
- `(js-syntax ,var
- ,@(map (lambda (p)
- `(js-syntax (js "[") ,p (js "]")))
- args)))
-
-(js-define-macro (quote expr)
- (cond
- ((symbol? expr) `(js-syntax ,(symbol->string expr)))
- ((null? expr) '(js "null"))
- (else (error "Invalid argument supplied to quote" expr))))
-
-(js-define-macro (obj . vars)
- `(js-syntax (js "{")
- ,@(join '(js ",")
- (map (lambda (p)
- `(js-syntax ,(symbol->string (car p))
- (js ":")
- ,(cdr p)))
- (pairify vars)))
- (js "}")))
-
-(js-define-macro (begin . exprs)
- (cond
- ((null? exprs) '(void 0))
- ((null? (cdr exprs))
- (car exprs))
- (else
- `(js-syntax (js "(")
- ,@(join '(js ",") exprs)
- (js ")")))))
-
-(js-define-macro (if cond t #!optional (f '(void 0)))
- `(js-syntax (js "((")
- ,cond
- (js ")?")
- ,t
- (js ":")
- ,f
- (js ")")))
-
-(js-define-macro (cond . clauses)
- (let* ((hd (car clauses))
- (tl (cdr clauses))
- (hd-test (car hd))
- (hd-body (cdr hd)))
- (cond
- ((and (null? tl)
- (eq? hd-test 'else))
- `(begin ,@hd-body))
-
- ((null? tl)
- `(if ,hd-test (begin ,@hd-body)))
-
- (else
- `(if ,hd-test
- (begin ,@hd-body)
- (cond ,@tl))))))
-
-(js-define-macro (typeof obj)
- `(js-syntax (js "(typeof ")
- ,obj
- (js ")")))
-
-(js-define-macro (instanceof obj type)
- `(js-syntax (js "(")
- ,obj
- (js " instanceof ")
- ,type
- (js ")")))
-
-(js-define-macro (new obj . args)
- `(js-syntax (js "new ")
- ,obj
- (js "(")
- ,@(join '(js ",") args)
- (js ")")))
-
-(js-define-macro (delete obj)
- `((statement-wrapper
- ()
- (js-syntax
- (js "delete ")
- ,obj))))
-
-(js-define-macro (not b)
- `(js-syntax (js "(!(") ,b (js "))")))
-
-; The first argument is expanded to a symbol, the rest to strings.
-; This is because the first symbol is actually a variable that should be able
-; to be effected by alpha conversion for instance, but the rest shouldn't be
-; changed.
-(js-define-macro (: first . names)
- `(js-syntax ,first
- ,@(map (lambda (n)
- `(js "." ,(symbol->string n)))
- names)))
-
-(js-define-macro (regexp str #!optional (args '||))
- `(js-syntax (js "/")
- (js ,(pregexp-replace*
- "/"
- str
- "\\\\/"))
- (js "/")
- (js ,(symbol->string args))))
-
-(js-define-macro (for-in var obj . body)
- (let ((var-gs (js-gensym)))
- `((statement-wrapper
- ()
- (js-syntax
- (js "for(var ")
- ,var-gs
- (js " in ")
- ,obj
- (js ")")
- (js-alpha-convert ,var
- ,var-gs
- (begin ,@body)))))))
-
-(js-define-macro (do vars conds . body)
- (let ((syms (map (lambda (x) (js-gensym)) vars))
- (updates (map (lambda (var)
- (if (null? (cddr var))
- `(begin)
- `(set! ,(car var)
- ,(caddr var))))
- vars))
- (res-gs (js-gensym)))
- `((statement-wrapper
- ()
- (js-syntax
- (js "for(")
- ,@(if (null? vars)
- '()
- '((js "var ")))
- ,@(join '(js ",")
- (map (lambda (var sym)
- (set! body
- (js-add-alpha body (car var) sym))
- (set! conds
- (js-add-alpha conds (car var) sym))
- (set! updates
- (js-add-alpha updates (car var) sym))
- `(js-syntax
- (js ,(symbol->string
- sym))
- (js "=")
- ,(cadr var)))
- vars syms))
- (js ";")
- (js ";")
- (begin
- ,@updates)
- (js "){var ")
- ,res-gs
- (js "=")
- (or ,@conds)
- (js ";if(")
- ,res-gs
- (js ")return ")
- ,res-gs
- (js ";")
- (begin ,@body)
- (js "}"))))))
-
-(js-define-macro (while cond . body)
- `((statement-wrapper
- ()
- (js-syntax
- (js "while(")
- ,cond
- (js ")")
- (begin ,@body)))))
-
-(js-define-macro (do-while cond . body)
- `((statement-wrapper
- ()
- (js-syntax
- (js "do{")
- (begin ,@body)
- (js "}while(")
- ,cond
- (js ")")))))
-
-;; Vectors
-
-;; (js-define-macro (vector-fill! vec o) (TODO))
-
-(define no-fill (gensym))
-
-(js-define-macro (make-vector len #!optional (fill no-fill))
- (if (eq? fill no-fill)
- `(new Array ,len)
- `(let ((arr (new Array len)))
- (vector-fill! arr ,fill)
- arr)))
-
-(js-define-macro (vector . expr)
- `(js-syntax (js "[")
- ,@(join '(js ",")
- expr)
- (js "]")))
-
-(js-define-macro (vector-length vec)
- `(: ,vec length))
-
-(js-define-macro (vector-ref vec idx)
- `(ref ,vec ,idx))
-
-(js-define-macro (vector-set! vec idx obj)
- `(set! (ref ,vec ,idx) ,obj))
-
-(js-define-macro (vector? vec)
- (let ((gs (js-gensym)))
- `(let ((,gs ,vec))
- (and ,gs (=== (: ,gs constructor) Array)))))
-
-
-;; Integer increment/decrement
-
-(js-define-macro (incr! o)
- `(js-syntax (js "++") ,o))
-
-(js-define-macro (decr! o)
- `(js-syntax (js "--") ,o))
-
-(js-define-macro (incr-after! o)
- `(js-syntax ,o (js "++")))
-
-(js-define-macro (decr-after! o)
- `(js-syntax ,o (js "--")))
-
-;; Type checks
-
-(js-define-macro (null? v)
- `(=== ,v '()))
-
-(js-define-macro (procedure? p)
- `(equal? (typeof ,p) "function"))
-
-(js-define-macro (number? n)
- `(equal? (typeof ,n) "number"))
-
-(js-define-macro (undefined? o)
- `(equal? (typeof ,o) "undefined"))
-
-;; Strings
-
-(js-define-macro (string? s)
- `(equal? (typeof ,s) "string"))
-
-(js-define-macro (string-append . args)
- `(+ ,@args))
-
-;; Pairs
-
-(js-define-macro (cons a b)
- `(vector ,a ,b))
-
-(js-define-macro (car a)
- `(ref ,a 0))
-
-(js-define-macro (cdr a)
- `(ref ,a 1))
-
-(js-define-macro (set-car! cons val)
- `(set! (: ,cons a) ,val))
-
-(js-define-macro (set-cdr! cons val)
- `(set! (: ,cons b) ,val))
-
-;; Standard libary functions
-
-(js-define-macro (abs v)
- `(Math.abs ,v))
-
-(js-define-macro (cos v)
- `(Math.cos ,v))
-
-(js-define-macro (sin v)
- `(Math.sin ,v))
-
-(js-define-macro (tan v)
- `(Math.tan ,v))
-
-(js-define-macro (acos v)
- `(Math.acos ,v))
-
-(js-define-macro (asin v)
- `(Math.asin ,v))
-
-(js-define-macro (atan v)
- `(Math.asin ,v))
-
-(js-define-macro (exp v)
- `(Math.exp ,v))
-
-(js-define-macro (ceiling v)
- `(Math.ceil ,v))
-
-(js-define-macro (floor v)
- `(Math.floor ,v))
-
-(js-define-macro (log v)
- `(Math.log ,v))
-
-(js-define-macro (sqrt v)
- `(Math.sqrt ,v))
-
-(js-define-macro (min . args)
- `(Math.min ,@args))
-
-(js-define-macro (max . args)
- `(Math.max ,@args))
-
-(js-define-macro (round v)
- `(Math.round ,v))
-
-(js-define-macro (negative? v)
- `(< ,v 0))
-
-(js-define-macro (positive? v)
- `(> ,v 0))
-
-(js-define-macro (zero? v)
- `(=== 0 ,v))
-
-(js-define-macro (odd? v)
- `(modulo ,v 2))
-
-(js-define-macro (even? v)
- `(not (odd? ,v)))
-
-(js-define-macro (apply fun args)
- `((: ,fun apply) this ,args))
-
-(define (js-define-op-with-name op name)
- (js-add-macro name
- (lambda args
- `(js-syntax (js "(")
- ,@(join `(js ,(symbol->string op)) args)
- (js ")")))))
-
-(define (js-define-op op)
- (js-define-op-with-name op op))
-
-(js-define-op '+)
-(js-define-op '-)
-(js-define-op '*)
-(js-define-op '/)
-(js-define-op-with-name '% 'modulo)
-(js-define-op '=)
-(js-define-op '===)
-(js-define-op '!==)
-(js-define-op '<)
-(js-define-op '>)
-(js-define-op '<=)
-(js-define-op '>=)
-
-(js-define-op-with-name '= 'set!)
-(js-define-op-with-name '== 'eq?) ; This is not correct
-(js-define-op-with-name '== 'equal?) ; This is not correct
-(js-define-op-with-name '== '=)
-(js-define-op-with-name '!= 'neq?) ; This is not correct
-(js-define-op-with-name '|\|\|| 'or)
-(js-define-op-with-name '&& 'and)
-
-
-
-;; Utility macros and functions
-
-(define-macro (js-define-utility-with-name scheme-name name)
- (let ((obj (gensym))
- (arg (gensym)))
- `(let ((macro-name ',name))
- (js-define-macro (,scheme-name ,obj . ,arg)
- `((: ,,obj ,macro-name) ,@,arg)))))
-
-(define-macro (js-define-utility name)
- `(js-define-utility-with-name ,name ,(string-camelize name)))
-
-(js-define-utility join)
-
-;;(js-define-utility each)
-;;(js-define-utility all)
-;;(js-define-utility map)
-;;(js-define-utility find)
-;;(js-define-utility each-slice)
-;;(js-define-utility-with-name filter findAll)
-;;(js-define-utility-with-name remove reject)
-;;(js-define-utility grep)
-;;(js-define-utility in-groups-of)
-;;(js-define-utility any)
-;;(js-define-utility include)
-;;(js-define-utility-with-name fold inject)
-;;(js-define-utility invoke)
-;;(js-define-utility max)
-;;(js-define-utility min)
-;;(js-define-utility partition)
-;;(js-define-utility pluck)
-;;(js-define-utility size)
-;;(js-define-utility sort)
-;;(js-define-utility sort-by)
-
-;; Tests
-
-;;(jsp (arr.sort-by size))
-;;(jsp (arr.any even?))
-;;(jsp (arr.each-slice 4))
-;;(jsp (arr.each (lambda (x) (alert x))))
-;;(jsp (arr.all even?))
-;;(jsp (arr.map even?))
-;;(jsp (arr.find even?))
-;;(jsp (neq? 5 4))
-;;
-;;(jsp (try (alert "hej") (lambda (aa) (alert aa))))
-;;(jsp (trylet e (alert "Hej") (alert "aa")))
-;;
-;;(jsp (let ((e 5))
-;; (trylet e
-;; (throw 4)
-;; (alert e))))
-;;
-;;(jsp (or json.elementName "span"))
-;;(jsp (and (eq? 4 3) #f))
-;;
-;;(jsp 'hello)
-;;(jsp '(a b (c)))
-;;(jsp ,(a 5 c 6))
-;;(jsp (ref document "all"))
-;;
-;;(jsp (alert "Whoah"))
-;;(jsp (: ($ "yay") hej))
-;;(jsp (alert (if (eq? 5 5) "yes" "noo")))
-;;(jsp (not #t))
-;;(jsp (begin (alert "Hej") (alert "Då")))
-;;(jsp (+ 1 2 (* (+ 1 3) 2)))
-;;(jsp (lambda (be ba hje kill) (* be.kill 2)))
-;;
-;;(jsp (let ((a 5)) a))
-;;(js-expand-macro '(let ((a 5)) a))
-;;
-;;(jsp ((lambda (b)
-;; (let ((a (+ 5 b)))
-;; (alert a)
-;; (lambda (a) a))) 5))
-;;
-;;(jsp (let ((a 6)) (alert (lambda (a) 5))))
-;;(js-expand-macro '(let ((a 6)) (alert (lambda (a) a))))
-;;
-;;(jsp (set! a 5))
-;;(jsp (define test 8))
-;;
-;;(jsp (alert (if (eq? 5 5) "ja!" "neeej")))
-;;
-;;(jsp (Widget.create
-;; "label"
-;; (lambda (json)
-;; (.text.tieInnerText
-;; (.createElement (or json.elementName "span") "wgt_label")))
-;; '("text")))
View
824 spork/widget.scm
@@ -1,824 +0,0 @@
-(import core
- counter
- js
- ../net/x-www-form-urlencoded
- ../net/http-server
- ../srfi/1
- ../srfi/13
- ../misc/al
- ../string/util)
-
-;; Utilities
-
-(define (url-add-parameter url key val)
- (let ((key (urlencode key))
- (val (urlencode val)))
- (if (string-index url #\?)
- (string-append url "&" key "=" val)
- (string-append url "?" key "=" val))))
-
-(define-macro (define-tag spec . body)
- (let ((attrs '(id class style)))
- `(define (,@spec
- ,@(if (and (list? spec)
- (memq '#!key spec))
- '()
- '(#!key))
- ,@attrs)
- (define-macro (@ . args)
- (cons 'quasiquote
- (list
- (append (cons '@ args)
- ',(map (lambda (a)
- (list 'unquote-splicing
- `(if ,a `((,',a ,,a)) '())))
- attrs)))))
- ,@body)))
-
-;; Misc. widgets
-
-(define-tag (link text #!optional (href "javascript:void(0);"))
- `(a ,(@ (href ,href))
- ,text))
-
-(define (w/link text fun #!key ajax)
- ((if ajax ajax-fork fork)
- (lambda (url) (link text url))
- (lambda (ret) (fun))))
-
-(define-tag (w/link* text fun)
- (let ((url (register-function fun)))
- `(a ,(@ (href ,url)) ,text)))
-
-(define (head title . rest)
- `(head (title ,title)
- ,@rest))
-
-(define (basic-template . content)
- `(html
- ,(head "Spork")
- (body
- ,@content)))
-
-(define (js-include file)
- `(script (@ (src ,file) (type "text/javascript")) " "))
-
-(define (tabbed-pane args
- #!key
- (links
- (lambda (choices url-fun)
- `(ul (@ (class "tabbed_pane_choices"))
- ,@(map (lambda (x)
- `(li ,(link (car x)
- (url-fun x))))
- choices))))
- (content
- (lambda (content)
- `(div (@ (class "tabbed_pane_contents"))
- ,@content)))
- (wrap
- (lambda (links content)
- `(div (@ (class "tabbed_pane"))
- ,links
- ,content))))
- (let loop ((ret #f))
- (fork-choose
- (lambda (choice)
- (wrap
- (links args (lambda (tab)
- (choice (lambda (_)
- (loop tab)))))
- (content
- (if ret
- (cdr ret)
- (cdar args))))))))
-
-;; Navigation
-
-(define-tag (nav-item text url)
- (and url `(li ,(@) ,(link text url))))
-
-(define-tag (navigation lst)
- `(ul ,(@)
- ,@(filter
- (lambda (x) x)
- (map (lambda (p) (apply nav-item p))
- lst))))
-
-(define-syntax nav
- (syntax-rules ()
- ((nav "INNER")
- '())
-
- ((nav "INNER" (elm ...) rest ...)
- (cons (list elm ...)
- (nav "INNER" rest ...)))
-
- ((nav elm ...)
- (navigation
- (nav "INNER" elm ...)))))
-
-;; Javascript
-
-(define core-js-module
- (js-module (for-each
- map
- obj->query-string
- jsfork
- event-observe
- event-stop)
- ()
-
- (define (for-each fun arr)
- (if (or (vector? arr)
- (instanceof arr NodeList)
- (instanceof arr HTMLCollection))
- (do ((i 0 (+ i 1)))
- ((= i arr.length))
- (fun (ref arr i) i))
- (for-in key arr
- (fun (cons key (ref arr key))))))
-
- (define (map fun arr)
- (let ((res (vector)))
- (for-each (lambda (elm idx)
- (res.push (fun elm idx)))
- arr)
- res))
-
- (let* ((old-xhr window.XMLHttpRequest)
- ;; Browser type
- (gecko? (not (not window.controllers)))
- (ie? (and window.document.all
- (not window.opera)))
- ;; Constructor
- (new-xhr (lambda ()
- (set! ._object (if old-xhr
- (new old-xhr)
- (new window.ActiveXObject
- "Microsoft.XMLHTTP")))
- (set! ._listeners (vector))
- this)))
-
- (define (clean-transport req)
- ;; Bugfix: IE - memory leak (on-page leak)
- (set! req._object.onreadystatechange (new window.Function))
- (delete req._headers))
-
- (define (get-document req)
- (let ((doc req.responseXML))
- ;; Try parsing responseText
- (if (and ie?
- doc
- (not doc.documentElement)
- ((: (req.getResponseHeader "Content-Type") match)
- (regexp "[^/]+/[^\\+]+\\+xml")))
- (begin
- (set! doc
- (new window.ActiveXObject "Microsoft.XMLDOM"))
- (doc.loadXML req.responseText)))
- ;; Check if there is no error in document
- (if (and doc
- (or (and ie? (not (eq? doc.parseError 0)))
- (eq? doc.documentElement.tagName "parsererror")))
- '()
- doc)))
-
- (define (synchronize-values req)
- (trylet (set! req.responseText req._object.responseText))
- (trylet (set! req.responseXML (get-document req._object)))
- (trylet (set! req.status req._object.status))
- (trylet (set! req.statusText req._object.statusText)))
-
- (define (ready-state-change-helper req)
- ;; Sniffing code
- (if new-xhr.onreadystatechange
- (new-xhr.onreadystatechange.apply req))
-
- ;; Fake event
- (req.dispatchEvent
- (obj type "readystatechange"
- bubbles #f
- cancelable #f
- timeStamp (+ (new Date) 0))))
-
- ;; Bugfix: FF w/ Firebug installed would break pages if not executed
- (if (and gecko? old-xhr.wrapped)
- (set! new-xhr.wrapped old-xhr.wrapped))
-
- ;; Constants and class-level event handlers
- (for-each
- (lambda (pair)
- (set! (ref new-xhr (car pair))
- (cdr pair)))
- (obj
- UNSENT 0
- OPENED 1
- HEADERS_RECEIVED 2
- LOADING 3
- DONE 4
- onreadystatechange '()
- onopen '()
- onsend '()
- onabort '()
-
- toString (lambda () "[XMLHttpRequest]")))
-
- ;; Public properties, instance-level event handlers
- ;; and public methods
- (let ((proto new-xhr.prototype))
- (for-each
- (lambda (pair)
- (set! (ref proto (car pair))
- (cdr pair)))
- (obj
- readyState new-xhr.UNSENT
- responseText ""
- responseXML '()
- status 0
- statusText ""
- onreadystatechange '()
- open (lambda (method url async user password)
- (if (undefined? async)
- (set! async #t))
- (define request this)
- (define state .readyState)
-
- ;; Bugfix: IE memory leak on page unload (inter-page leak)
- (define on-unload #f)
- (if ie?
- (begin
- (set! on-unload
- (lambda ()
- (if (not
- (eq? request._object.readyState
- new-xhr.DONE))
- (clean-transport request)
- (request.abort))))
- (if async
- (window.attachEvent "onunload" on-unload))))
-
- (set!
- ._object.onreadystatechange
- (lambda ()
- (cond
- ((and gecko? (not async))
- #f)
-
- ;; Bugfix: Firefox fires unneccesary DONE when aborting
- (request._aborted
- (set! request.readyState new-xhr.UNSENT)
- #f)
-
- (else
- ;; Synchronize state
- (set! request.readyState
- request._object.readyState)
-
- (synchronize-values request)
-
- (if (eq? request.readyState new-xhr.DONE)
- (begin
- (clean-transport request)
-
- ;; Bugfix: IE - memory leak in interrupted
- (if (and ie? async)
- (window.detachEvent "onunload"
- on-unload))))
-
- ;; Bugfix: IE and Gecko fire OPEN readystate twice
- (if (not (and (eq? state request.readyState)
- (eq? state 1)))
- (ready-state-change-helper request))
-
- (set! state request.readyState)))))
-
- ;; Add method sniffer
- (if new-xhr.onopen
- (new-xhr.opopen.apply this arguments))