suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Adding catchall exception handler.

Browse Source
This commit is contained in:
Danny Yoo 2011-10-03 14:19:17 -04:00
parent a254acf05f
commit 8fb599b926
2 changed files with 171 additions and 150 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
compiler/compiler.rkt
View File

@ -26,7 +26,6 @@
(: -compile (Expression Target Linkage -> (Listof Statement))) (: -compile (Expression Target Linkage -> (Listof Statement)))
;; Generates the instruction-sequence stream. ;; Generates the instruction-sequence stream.
;; Note: the toplevel generates the lambda body streams at the head, and then the ;; Note: the toplevel generates the lambda body streams at the head, and then the

312
whalesong-helpers.rkt
View File

@ -40,6 +40,20 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (with-catchall-exception-handler thunk)
(with-handlers
[(void (lambda (exn)
(printf "ERROR: Whalesong has encountered an internal error.\n\n")
(printf "Please send the following error report log to dyoo@hashcollision.org.\n\n")
(define op (open-output-string))
(parameterize ([current-error-port op])
((error-display-handler) (exn-message exn) exn))
(printf "------------------\n")
(displayln (get-output-string op))
(printf "------------------\n")
(printf "\nAborting compilation.\n")
(exit)))]
(thunk)))
@ -66,172 +80,180 @@
(loop))))))) (loop)))))))
(define (build-standalone-xhtml f) (define (build-standalone-xhtml f)
(turn-on-logger!) (with-catchall-exception-handler
(let-values ([(base filename dir?) (lambda ()
(split-path f)]) (turn-on-logger!)
(let ([output-filename (let-values ([(base filename dir?)
(build-path (split-path f)])
(regexp-replace #rx"[.](rkt|ss)$" (let ([output-filename
(path->string filename) (build-path
".xhtml"))]) (regexp-replace #rx"[.](rkt|ss)$"
(unless (directory-exists? (current-output-dir)) (path->string filename)
(fprintf (current-report-port) "Creating destination directory ~s\n" (current-output-dir)) ".xhtml"))])
(make-directory* (current-output-dir))) (unless (directory-exists? (current-output-dir))
(parameterize ([current-on-resource (fprintf (current-report-port) "Creating destination directory ~s\n" (current-output-dir))
(lambda (r) (make-directory* (current-output-dir)))
(cond (parameterize ([current-on-resource
[(file-exists? (build-path (current-output-dir) (lambda (r)
(resource-key r))) (cond
(cond [(same-file? (build-path (current-output-dir) [(file-exists? (build-path (current-output-dir)
(resource-key r)) (resource-key r)))
(resource-path r)) (cond [(same-file? (build-path (current-output-dir)
(void)] (resource-key r))
[else (resource-path r))
(error 'whalesong "Unable to write resource ~s; this will overwrite a file that already exists." (void)]
(build-path (current-output-dir) [else
(resource-key r)))])] (error 'whalesong "Unable to write resource ~s; this will overwrite a file that already exists."
[else (build-path (current-output-dir)
(fprintf (current-report-port) (resource-key r)))])]
(format "Writing resource ~s\n" (build-path (current-output-dir) [else
(resource-key r)))) (fprintf (current-report-port)
(copy-file (resource-path r) (format "Writing resource ~s\n" (build-path (current-output-dir)
(build-path (current-output-dir) (resource-key r))))
(resource-key r)))]))]) (copy-file (resource-path r)
(fprintf (current-report-port) (build-path (current-output-dir)
(format "Writing program ~s\n" (build-path (current-output-port) output-filename))) (resource-key r)))]))])
(call-with-output-file* (build-path (current-output-dir) output-filename) (fprintf (current-report-port)
(lambda (op) (format "Writing program ~s\n" (build-path (current-output-port) output-filename)))
(package-standalone-xhtml (call-with-output-file* (build-path (current-output-dir) output-filename)
(make-MainModuleSource (lambda (op)
(normalize-path (build-path f))) (package-standalone-xhtml
op)) (make-MainModuleSource
#:exists 'replace))))) (normalize-path (build-path f)))
op))
#:exists 'replace)))))))
(define (build-html-and-javascript f) (define (build-html-and-javascript f)
(turn-on-logger!) (with-catchall-exception-handler
(lambda ()
(turn-on-logger!)
(define written-js-paths '()) (define written-js-paths '())
(define written-resources '()) (define written-resources '())
(define make-output-js-filename (define make-output-js-filename
(let ([n 0]) (let ([n 0])
(lambda () (lambda ()
(define result (build-path (current-output-dir) (define result (build-path (current-output-dir)
(string-append (string-append
(regexp-replace #rx"[.](rkt|ss)$" (regexp-replace #rx"[.](rkt|ss)$"
(path->string (file-name-from-path f)) (path->string (file-name-from-path f))
"") "")
(if (= n 0) (if (= n 0)
".js" ".js"
(format "_~a.js" n))))) (format "_~a.js" n)))))
(set! written-js-paths (cons result written-js-paths)) (set! written-js-paths (cons result written-js-paths))
(set! n (add1 n)) (set! n (add1 n))
(fprintf (current-report-port) (fprintf (current-report-port)
(format "Writing program ~s\n" result)) (format "Writing program ~s\n" result))
result))) result)))
(define (on-resource r) (define (on-resource r)
(cond (cond
[(file-exists? (build-path (current-output-dir) (resource-key r))) [(file-exists? (build-path (current-output-dir) (resource-key r)))
(cond [(same-file? (build-path (current-output-dir) (cond [(same-file? (build-path (current-output-dir)
(resource-key r)) (resource-key r))
(resource-path r)) (resource-path r))
(fprintf (current-report-port) (fprintf (current-report-port)
(format "Skipping writing resource ~s; already exists\n" (format "Skipping writing resource ~s; already exists\n"
(build-path (current-output-dir) (build-path (current-output-dir)
(resource-key r)))) (resource-key r))))
(void)] (void)]
[else [else
(error 'whalesong "Unable to write resource ~s; this will overwrite a file that already exists." (error 'whalesong "Unable to write resource ~s; this will overwrite a file that already exists."
(build-path (current-output-dir)
(resource-key r)))])]
[else
(fprintf (current-report-port)
(format "Writing resource ~s\n" (build-path (current-output-dir)
(resource-key r))))
(copy-file (resource-path r)
(build-path (current-output-dir) (build-path (current-output-dir)
(resource-key r)))])] (resource-key r)))])
[else (set! written-resources (cons (resource-key r) written-resources)))
(fprintf (current-report-port)
(format "Writing resource ~s\n" (build-path (current-output-dir)
(resource-key r))))
(copy-file (resource-path r)
(build-path (current-output-dir)
(resource-key r)))])
(set! written-resources (cons (resource-key r) written-resources)))
(define start-time (current-inexact-milliseconds)) (define start-time (current-inexact-milliseconds))
(let ([title (let ([title
(regexp-replace #rx"([.](rkt|ss))$" (regexp-replace #rx"([.](rkt|ss))$"
(path->string (file-name-from-path f)) (path->string (file-name-from-path f))
"")] "")]
[output-html-filename [output-html-filename
(build-path (build-path
(string-append (regexp-replace #rx"[.](rkt|ss)$" (string-append (regexp-replace #rx"[.](rkt|ss)$"
(path->string (file-name-from-path f)) (path->string (file-name-from-path f))
"") "")
".html"))] ".html"))]
[output-manifest-filename [output-manifest-filename
(build-path (build-path
(string-append (string-append
(regexp-replace #rx"[.](rkt|ss)$" (regexp-replace #rx"[.](rkt|ss)$"
(path->string (file-name-from-path f)) (path->string (file-name-from-path f))
"") "")
".appcache"))]) ".appcache"))])
(unless (directory-exists? (current-output-dir)) (unless (directory-exists? (current-output-dir))
(fprintf (current-report-port) "Creating destination directory ~s\n" (current-output-dir)) (fprintf (current-report-port) "Creating destination directory ~s\n" (current-output-dir))
(make-directory* (current-output-dir))) (make-directory* (current-output-dir)))
(parameterize ([current-on-resource on-resource]) (parameterize ([current-on-resource on-resource])
(call-with-output-file* (make-output-js-filename) (call-with-output-file* (make-output-js-filename)
(lambda (op) (lambda (op)
(display (get-runtime) op) (display (get-runtime) op)
(display (get-inert-code (make-MainModuleSource (display (get-inert-code (make-MainModuleSource
(normalize-path (build-path f))) (normalize-path (build-path f)))
make-output-js-filename) make-output-js-filename)
op)) op))
#:exists 'replace)) #:exists 'replace))
(when (current-with-legacy-ie-support?) (when (current-with-legacy-ie-support?)
(for ([r ie-resources]) (on-resource r))) (for ([r ie-resources]) (on-resource r)))
(fprintf (current-report-port) (fprintf (current-report-port)
(format "Writing html ~s\n" (build-path (current-output-dir) output-html-filename))) (format "Writing html ~s\n" (build-path (current-output-dir) output-html-filename)))
(call-with-output-file* (build-path (current-output-dir) output-html-filename) (call-with-output-file* (build-path (current-output-dir) output-html-filename)
(lambda (op) (lambda (op)
(display (get-html-template (display (get-html-template
(map file-name-from-path (map file-name-from-path
(reverse written-js-paths)) (reverse written-js-paths))
#:title title #:title title
#:manifest output-manifest-filename) #:manifest output-manifest-filename)
op)) op))
#:exists 'replace) #:exists 'replace)
;; Write the manifest ;; Write the manifest
(fprintf (current-report-port) (fprintf (current-report-port)
(format "Writing manifest ~s\n" (build-path (current-output-dir) output-manifest-filename))) (format "Writing manifest ~s\n" (build-path (current-output-dir) output-manifest-filename)))
(call-with-output-file* (build-path (current-output-dir) output-manifest-filename) (call-with-output-file* (build-path (current-output-dir) output-manifest-filename)
(lambda (op) (lambda (op)
(fprintf op "CACHE MANIFEST\n") (fprintf op "CACHE MANIFEST\n")
(fprintf op "## Timestamp: ~a\n" (date->string (current-date) #t)) (fprintf op "## Timestamp: ~a\n" (date->string (current-date) #t))
(for [(js-name (map file-name-from-path (reverse written-js-paths)))] (for [(js-name (map file-name-from-path (reverse written-js-paths)))]
(fprintf op "~a\n" js-name)) (fprintf op "~a\n" js-name))
(for [(resource-name written-resources)] (for [(resource-name written-resources)]
(fprintf op "~a\n" resource-name))) (fprintf op "~a\n" resource-name)))
#:exists 'replace) #:exists 'replace)
(define stop-time (current-inexact-milliseconds)) (define stop-time (current-inexact-milliseconds))
(fprintf (current-timing-port) "Time taken: ~a milliseconds\n" (- stop-time start-time)))) (fprintf (current-timing-port) "Time taken: ~a milliseconds\n" (- stop-time start-time))))))
(define (print-the-runtime) (define (print-the-runtime)
(turn-on-logger!) (with-catchall-exception-handler
(display (get-runtime) (current-output-port))) (lambda ()
(turn-on-logger!)
(display (get-runtime) (current-output-port)))))
(define (get-javascript-code filename) (define (get-javascript-code filename)
(turn-on-logger!) (with-catchall-exception-handler
(display (get-standalone-code (lambda ()
(make-MainModuleSource (turn-on-logger!)
(normalize-path (build-path filename)))) (display (get-standalone-code
(current-output-port))) (make-MainModuleSource
(normalize-path (build-path filename))))
(current-output-port)))))