thin-provisioning-tools/functional-tests/fmt/fmt-js.scm
Joe Thornber 3e5de399a7 [functional tests] Remove dependency on the ThunderChez library.
I've just moved the relevant code into the functional-tests dir.
2020-04-30 12:07:42 +01:00

75 lines
2.2 KiB
Scheme

;;;; fmt-js.scm -- javascript formatting utilities
;;
;; Copyright (c) 2011-2012 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (js-expr x)
(fmt-let 'gen js-expr/sexp
(lambda (st) (((or (fmt-gen st) js-expr/sexp) x) st))))
(define (js-expr/sexp x)
(cond
((procedure? x)
x)
((pair? x)
(case (car x)
((%fun function) (apply js-function (cdr x)))
((%var var) (apply js-var (cdr x)))
((eq? ===) (apply js=== (cdr x)))
((>>>) (apply js>>> (cdr x)))
((%array) (js-array x))
((%object) (js-object (cdr x)))
((%comment) (js-comment x))
(else (c-expr/sexp x))))
((vector? x) (js-array x))
((boolean? x) (cat (if x "true" "false")))
((char? x) (js-expr/sexp (string x)))
(else (c-expr/sexp x))))
(define (js-function . x)
(let* ((name (and (symbol? (car x)) (car x)))
(params (if name (cadr x) (car x)))
(body (if name (cddr x) (cdr x))))
(c-block
(cat "function " (dsp (or name "")) "("
(fmt-join dsp params ", ") ")")
(fmt-let 'return? #t (c-in-stmt (apply c-begin body))))))
(define (js-var . args)
(apply c-var 'var args))
(define (js=== . args)
(apply c-op "===" args))
(define (js>>> . args)
(apply c-op ">>>" args))
(define (js-comment . args)
(columnar "// " (apply-cat args)))
(define (js-array x)
(let ((ls (vector->list x)))
(c-wrap-stmt
(fmt-try-fit
(fmt-let 'no-wrap? #t (cat "[" (fmt-join js-expr ls ", ") "]"))
(lambda (st)
(let* ((col (fmt-col st))
(sep (string-append "," (make-nl-space col))))
((cat "[" (fmt-join js-expr ls sep) "]" nl) st)))))))
(define (js-pair x)
(cat (js-expr (car x)) ": " (js-expr (cdr x))))
(define (js-object ls)
(c-in-expr
(fmt-try-fit
(fmt-let 'no-wrap? #t (cat "{" (fmt-join js-pair ls ", ") "}"))
(lambda (st)
(let* ((col (fmt-col st))
(sep (string-append "," (make-nl-space col))))
((cat "{" (fmt-join js-pair ls sep) "}" nl) st))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;