68 lines
2.2 KiB
Scheme
68 lines
2.2 KiB
Scheme
#lang scheme/base
|
|
(require mzlib/deflate
|
|
mzlib/match
|
|
mzlib/pretty)
|
|
(require (for-syntax mzlib/inflate
|
|
mzlib/string))
|
|
|
|
(provide encode-sexp
|
|
encode-module)
|
|
|
|
(define (encode-module in-filename out-filename)
|
|
(call-with-input-file in-filename
|
|
(λ (port)
|
|
(let ([mod (read port)])
|
|
(unless (eof-object? (read port))
|
|
(error 'encode-module "found an extra expression"))
|
|
(match mod
|
|
[`(module ,m mzscheme ,@(bodies ...))
|
|
(call-with-output-file out-filename
|
|
(λ (oport)
|
|
(let ([chopped (chop-up (encode-sexp `(begin ,@bodies)))])
|
|
(fprintf oport "(module ~a mzscheme\n" m)
|
|
(fprintf oport " (require framework/private/decode)\n")
|
|
(fprintf oport " (decode ~a" (car chopped))
|
|
(for-each (lambda (chopped)
|
|
(fprintf oport "\n ~a" chopped))
|
|
(cdr chopped))
|
|
(fprintf oport "))\n")))
|
|
'truncate 'text)]
|
|
[else (error 'encode-module "cannot parse module")])))))
|
|
|
|
(define (chop-up sym)
|
|
(let ([chopping-point 50])
|
|
(let loop ([str (symbol->string sym)])
|
|
(cond
|
|
[(<= (string-length str) chopping-point)
|
|
(list (string->symbol str))]
|
|
[else
|
|
(cons (string->symbol (substring str 0 chopping-point))
|
|
(loop (substring str chopping-point (string-length str))))]))))
|
|
|
|
(define (encode-sexp sexp)
|
|
(define (str->sym string)
|
|
(string->symbol
|
|
(apply
|
|
string-append
|
|
(map
|
|
(λ (x)
|
|
(to-hex x))
|
|
(bytes->list string)))))
|
|
|
|
(define (to-hex n)
|
|
(let ([digit->hex
|
|
(λ (d)
|
|
(cond
|
|
[(<= d 9) d]
|
|
[else (integer->char (+ d -10 (char->integer #\a)))]))])
|
|
(cond
|
|
[(< n 16) (format "0~a" (digit->hex n))]
|
|
[else (format "~a~a"
|
|
(digit->hex (quotient n 16))
|
|
(digit->hex (modulo n 16)))])))
|
|
|
|
(let ([in (open-input-string (format "~s" sexp))]
|
|
[out (open-output-bytes)])
|
|
(deflate in out)
|
|
(str->sym (get-output-bytes out))))
|