Adding catchall exception handler.
This commit is contained in:
Danny Yoo
parent
a254acf05f
commit
8fb599b926
|
|
@ -26,7 +26,6 @@
|
|||
|
||||
|
||||
|
||||
|
||||
(: -compile (Expression Target Linkage -> (Listof Statement)))
|
||||
;; Generates the instruction-sequence stream.
|
||||
;; Note: the toplevel generates the lambda body streams at the head, and then the
|
||||
|
|
|
|||
|
|
@ -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)))))))
|
||||
|
||||
(define (build-standalone-xhtml f)
|
||||
(turn-on-logger!)
|
||||
(let-values ([(base filename dir?)
|
||||
(split-path f)])
|
||||
(let ([output-filename
|
||||
(build-path
|
||||
(regexp-replace #rx"[.](rkt|ss)$"
|
||||
(path->string filename)
|
||||
".xhtml"))])
|
||||
(unless (directory-exists? (current-output-dir))
|
||||
(fprintf (current-report-port) "Creating destination directory ~s\n" (current-output-dir))
|
||||
(make-directory* (current-output-dir)))
|
||||
(parameterize ([current-on-resource
|
||||
(lambda (r)
|
||||
(cond
|
||||
[(file-exists? (build-path (current-output-dir)
|
||||
(resource-key r)))
|
||||
(cond [(same-file? (build-path (current-output-dir)
|
||||
(resource-key r))
|
||||
(resource-path r))
|
||||
(void)]
|
||||
[else
|
||||
(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)
|
||||
(resource-key r)))]))])
|
||||
(fprintf (current-report-port)
|
||||
(format "Writing program ~s\n" (build-path (current-output-port) output-filename)))
|
||||
(call-with-output-file* (build-path (current-output-dir) output-filename)
|
||||
(lambda (op)
|
||||
(package-standalone-xhtml
|
||||
(make-MainModuleSource
|
||||
(normalize-path (build-path f)))
|
||||
op))
|
||||
#:exists 'replace)))))
|
||||
(with-catchall-exception-handler
|
||||
(lambda ()
|
||||
(turn-on-logger!)
|
||||
(let-values ([(base filename dir?)
|
||||
(split-path f)])
|
||||
(let ([output-filename
|
||||
(build-path
|
||||
(regexp-replace #rx"[.](rkt|ss)$"
|
||||
(path->string filename)
|
||||
".xhtml"))])
|
||||
(unless (directory-exists? (current-output-dir))
|
||||
(fprintf (current-report-port) "Creating destination directory ~s\n" (current-output-dir))
|
||||
(make-directory* (current-output-dir)))
|
||||
(parameterize ([current-on-resource
|
||||
(lambda (r)
|
||||
(cond
|
||||
[(file-exists? (build-path (current-output-dir)
|
||||
(resource-key r)))
|
||||
(cond [(same-file? (build-path (current-output-dir)
|
||||
(resource-key r))
|
||||
(resource-path r))
|
||||
(void)]
|
||||
[else
|
||||
(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)
|
||||
(resource-key r)))]))])
|
||||
(fprintf (current-report-port)
|
||||
(format "Writing program ~s\n" (build-path (current-output-port) output-filename)))
|
||||
(call-with-output-file* (build-path (current-output-dir) output-filename)
|
||||
(lambda (op)
|
||||
(package-standalone-xhtml
|
||||
(make-MainModuleSource
|
||||
(normalize-path (build-path f)))
|
||||
op))
|
||||
#:exists 'replace)))))))
|
||||
|
||||
|
||||
|
||||
(define (build-html-and-javascript f)
|
||||
(turn-on-logger!)
|
||||
(with-catchall-exception-handler
|
||||
(lambda ()
|
||||
(turn-on-logger!)
|
||||
|
||||
(define written-js-paths '())
|
||||
(define written-resources '())
|
||||
(define make-output-js-filename
|
||||
(let ([n 0])
|
||||
(lambda ()
|
||||
(define result (build-path (current-output-dir)
|
||||
(string-append
|
||||
(regexp-replace #rx"[.](rkt|ss)$"
|
||||
(path->string (file-name-from-path f))
|
||||
"")
|
||||
(if (= n 0)
|
||||
".js"
|
||||
(format "_~a.js" n)))))
|
||||
(set! written-js-paths (cons result written-js-paths))
|
||||
(set! n (add1 n))
|
||||
(fprintf (current-report-port)
|
||||
(format "Writing program ~s\n" result))
|
||||
result)))
|
||||
|
||||
(define (on-resource r)
|
||||
(cond
|
||||
[(file-exists? (build-path (current-output-dir) (resource-key r)))
|
||||
(cond [(same-file? (build-path (current-output-dir)
|
||||
(resource-key r))
|
||||
(resource-path r))
|
||||
(fprintf (current-report-port)
|
||||
(format "Skipping writing resource ~s; already exists\n"
|
||||
(build-path (current-output-dir)
|
||||
(resource-key r))))
|
||||
(void)]
|
||||
[else
|
||||
(error 'whalesong "Unable to write resource ~s; this will overwrite a file that already exists."
|
||||
(define written-js-paths '())
|
||||
(define written-resources '())
|
||||
(define make-output-js-filename
|
||||
(let ([n 0])
|
||||
(lambda ()
|
||||
(define result (build-path (current-output-dir)
|
||||
(string-append
|
||||
(regexp-replace #rx"[.](rkt|ss)$"
|
||||
(path->string (file-name-from-path f))
|
||||
"")
|
||||
(if (= n 0)
|
||||
".js"
|
||||
(format "_~a.js" n)))))
|
||||
(set! written-js-paths (cons result written-js-paths))
|
||||
(set! n (add1 n))
|
||||
(fprintf (current-report-port)
|
||||
(format "Writing program ~s\n" result))
|
||||
result)))
|
||||
|
||||
(define (on-resource r)
|
||||
(cond
|
||||
[(file-exists? (build-path (current-output-dir) (resource-key r)))
|
||||
(cond [(same-file? (build-path (current-output-dir)
|
||||
(resource-key r))
|
||||
(resource-path r))
|
||||
(fprintf (current-report-port)
|
||||
(format "Skipping writing resource ~s; already exists\n"
|
||||
(build-path (current-output-dir)
|
||||
(resource-key r))))
|
||||
(void)]
|
||||
[else
|
||||
(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)
|
||||
(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)
|
||||
(resource-key r)))])
|
||||
(set! written-resources (cons (resource-key r) written-resources)))
|
||||
|
||||
(resource-key r)))])
|
||||
(set! written-resources (cons (resource-key r) written-resources)))
|
||||
|
||||
|
||||
|
||||
(define start-time (current-inexact-milliseconds))
|
||||
(let ([title
|
||||
(regexp-replace #rx"([.](rkt|ss))$"
|
||||
(path->string (file-name-from-path f))
|
||||
"")]
|
||||
[output-html-filename
|
||||
(build-path
|
||||
(string-append (regexp-replace #rx"[.](rkt|ss)$"
|
||||
(path->string (file-name-from-path f))
|
||||
"")
|
||||
".html"))]
|
||||
[output-manifest-filename
|
||||
(build-path
|
||||
(string-append
|
||||
(regexp-replace #rx"[.](rkt|ss)$"
|
||||
(path->string (file-name-from-path f))
|
||||
"")
|
||||
".appcache"))])
|
||||
(unless (directory-exists? (current-output-dir))
|
||||
(fprintf (current-report-port) "Creating destination directory ~s\n" (current-output-dir))
|
||||
(make-directory* (current-output-dir)))
|
||||
|
||||
(define start-time (current-inexact-milliseconds))
|
||||
(let ([title
|
||||
(regexp-replace #rx"([.](rkt|ss))$"
|
||||
(path->string (file-name-from-path f))
|
||||
"")]
|
||||
[output-html-filename
|
||||
(build-path
|
||||
(string-append (regexp-replace #rx"[.](rkt|ss)$"
|
||||
(path->string (file-name-from-path f))
|
||||
"")
|
||||
".html"))]
|
||||
[output-manifest-filename
|
||||
(build-path
|
||||
(string-append
|
||||
(regexp-replace #rx"[.](rkt|ss)$"
|
||||
(path->string (file-name-from-path f))
|
||||
"")
|
||||
".appcache"))])
|
||||
(unless (directory-exists? (current-output-dir))
|
||||
(fprintf (current-report-port) "Creating destination directory ~s\n" (current-output-dir))
|
||||
(make-directory* (current-output-dir)))
|
||||
|
||||
(parameterize ([current-on-resource on-resource])
|
||||
(call-with-output-file* (make-output-js-filename)
|
||||
(lambda (op)
|
||||
(display (get-runtime) op)
|
||||
(display (get-inert-code (make-MainModuleSource
|
||||
(normalize-path (build-path f)))
|
||||
make-output-js-filename)
|
||||
op))
|
||||
#:exists 'replace))
|
||||
(parameterize ([current-on-resource on-resource])
|
||||
(call-with-output-file* (make-output-js-filename)
|
||||
(lambda (op)
|
||||
(display (get-runtime) op)
|
||||
(display (get-inert-code (make-MainModuleSource
|
||||
(normalize-path (build-path f)))
|
||||
make-output-js-filename)
|
||||
op))
|
||||
#:exists 'replace))
|
||||
|
||||
(when (current-with-legacy-ie-support?)
|
||||
(for ([r ie-resources]) (on-resource r)))
|
||||
|
||||
(fprintf (current-report-port)
|
||||
(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)
|
||||
(lambda (op)
|
||||
(display (get-html-template
|
||||
(map file-name-from-path
|
||||
(reverse written-js-paths))
|
||||
#:title title
|
||||
#:manifest output-manifest-filename)
|
||||
op))
|
||||
#:exists 'replace)
|
||||
(when (current-with-legacy-ie-support?)
|
||||
(for ([r ie-resources]) (on-resource r)))
|
||||
|
||||
(fprintf (current-report-port)
|
||||
(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)
|
||||
(lambda (op)
|
||||
(display (get-html-template
|
||||
(map file-name-from-path
|
||||
(reverse written-js-paths))
|
||||
#:title title
|
||||
#:manifest output-manifest-filename)
|
||||
op))
|
||||
#:exists 'replace)
|
||||
|
||||
;; Write the manifest
|
||||
(fprintf (current-report-port)
|
||||
(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)
|
||||
(lambda (op)
|
||||
(fprintf op "CACHE MANIFEST\n")
|
||||
(fprintf op "## Timestamp: ~a\n" (date->string (current-date) #t))
|
||||
(for [(js-name (map file-name-from-path (reverse written-js-paths)))]
|
||||
(fprintf op "~a\n" js-name))
|
||||
(for [(resource-name written-resources)]
|
||||
(fprintf op "~a\n" resource-name)))
|
||||
#:exists 'replace)
|
||||
(define stop-time (current-inexact-milliseconds))
|
||||
;; Write the manifest
|
||||
(fprintf (current-report-port)
|
||||
(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)
|
||||
(lambda (op)
|
||||
(fprintf op "CACHE MANIFEST\n")
|
||||
(fprintf op "## Timestamp: ~a\n" (date->string (current-date) #t))
|
||||
(for [(js-name (map file-name-from-path (reverse written-js-paths)))]
|
||||
(fprintf op "~a\n" js-name))
|
||||
(for [(resource-name written-resources)]
|
||||
(fprintf op "~a\n" resource-name)))
|
||||
#:exists 'replace)
|
||||
(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)
|
||||
(turn-on-logger!)
|
||||
(display (get-runtime) (current-output-port)))
|
||||
(with-catchall-exception-handler
|
||||
(lambda ()
|
||||
(turn-on-logger!)
|
||||
(display (get-runtime) (current-output-port)))))
|
||||
|
||||
|
||||
|
||||
(define (get-javascript-code filename)
|
||||
(turn-on-logger!)
|
||||
(display (get-standalone-code
|
||||
(make-MainModuleSource
|
||||
(normalize-path (build-path filename))))
|
||||
(current-output-port)))
|
||||
(with-catchall-exception-handler
|
||||
(lambda ()
|
||||
(turn-on-logger!)
|
||||
(display (get-standalone-code
|
||||
(make-MainModuleSource
|
||||
(normalize-path (build-path filename))))
|
||||
(current-output-port)))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user