diff --git a/pitfall/pitfall/binparser/gif-parse.rkt b/pitfall/pitfall/binparser/gif-parse.rkt index 09513694..d375eab3 100644 --- a/pitfall/pitfall/binparser/gif-parse.rkt +++ b/pitfall/pitfall/binparser/gif-parse.rkt @@ -5,33 +5,23 @@ (define unparse-val (make-parameter #f)) -(define identity (λ (x) x)) +(struct binary-problem (msg val) #:transparent) + +(define (read-bytes-exact count p) + (define bs (read-bytes count p)) + (unless (and (bytes? bs) (= (bytes-length bs) count)) + (raise (binary-problem (format "byte string length ~a" count) bs))) + bs) + -(define-macro-cases :atomic - [(N COUNT) #'(N COUNT identity)] - [(N COUNT PROC) #'(λ () - (define bs (read-bytes COUNT)) - (when (< (bytes-length bs) COUNT) - (error 'not-enough-bytes (format "~a needs ~a" 'N COUNT))) - (PROC bs))]) (define (seq->hash xs) (make-hasheq xs)) (define (seq->list xs) (map cdr xs)) -(define-macro-cases :seq - [(N SEQ ... (:bidi PROC)) - #'(λ () (if (unparse-val) - (report (PROC (unparse-val))) - (PROC (map (λ(f) (f)) (list SEQ ...)))))] - [(N SEQ ...) #'(N SEQ ... (:bidi identity))]) -(struct elem (name val bidi) #:transparent) -(define-macro-cases define-rule - [(N ID WHAT) #'(N ID WHAT (:bidi identity))] - [(N ID WHAT (:bidi PROC)) - #'(define ID (λ () (elem 'ID (WHAT) PROC)))]) + (define-macro (:bidi X) #'X) @@ -40,19 +30,26 @@ (report (car (map cdr (hash->list x)))) (make-hasheq (list x)))) -(define (bytes->int bs) - (if (= (bytes-length bs) 1) - (bytes-ref bs 0) - (integer-bytes->integer bs #f #f))) +(define (bytes->integer len x) + (when (< (bytes-length x) len) (raise-argument-error 'bytes->integer "too short" x)) + (cond + [(= len 1) (bytes-ref x 0)] + [else (integer-bytes->integer x #f #f)])) + +(define (integer->bytes len x) + (cond + [(= len 1) (bytes x)] + [else (integer->integer-bytes x len #f #f)])) (define (bytes->bitfield bs) (for*/list ([b (in-bytes bs)] [idx (in-range 8)]) - (bitwise-bit-set? b idx))) + (bitwise-bit-set? b idx))) (define (bytes->string bs) (bytes->string/latin-1 bs)) +#| (define-rule gif (:seq signature version logical-screen-descriptor (:bidi seq->hash))) (define-rule signature (:atomic 3 (:bidi bytes->string))) (define-rule version (:atomic 3 (:bidi bytes->string))) @@ -64,22 +61,85 @@ (define-rule packed (:atomic 1 (:bidi bytes->bitfield))) (define-rule bgcolor-idx (:atomic 1 (:bidi bytes->int))) (define-rule aspect (:atomic 1 (:bidi bytes->int))) +|# + +(define (:atomic count #:type [type #f]) + (λ (x) + (define-values (input-proc output-proc) + (match type + [integer? + (values (curry bytes->integer count) + (curry integer->bytes count))] + [else (values identity identity)])) + (if (input-port? x) + (input-proc (read-bytes-exact count x)) + (let ([result (output-proc x)]) + (unless (and (bytes? result) (= (bytes-length result) count)) + (raise (binary-problem (format "byte string length ~a" count) result))) + result)))) + + +(define (list->hash-with-keys keys vals) + (make-hash (map cons keys vals))) + +(define (hash->list-with-keys keys h) + (for/list ([k (in-list keys)]) + (hash-ref h k))) + +(define (procedure-name proc) + (string->symbol (cadr (regexp-match #rx"^#$" (with-output-to-string (λ () (display proc))))))) + +(define (hash-has-keys? h keys) + (define (sortation xs) (sort xs #:key symbol->string stringhash-with-keys rule-proc-names) + (curry hash->list-with-keys rule-proc-names) + (λ (x) + (unless (and (hash? x) (hash-has-keys? x rule-proc-names)) + (raise (binary-problem (format "hash with ~a keys, namely ~a" (length rule-procs) rule-proc-names) x)))))] + [else (values identity identity + (λ (x) + (unless (and (list? x) (= (length rule-procs) (length x))) + (raise (binary-problem (format "list of ~a values" (length rule-procs)) x)))))])) + (match x + [(? input-port? p) (input-proc (map (λ (rule-proc) (rule-proc p)) rule-procs))] + [else + (output-check x) + (apply bytes-append (map (λ (rp xi) (rp xi)) rule-procs (output-proc x)))]))) + +(define-macro-cases :repeat + [(_ COUNT RULE-PROC ...) #'(λ (p) (append-map (λ (i) (list (RULE-PROC p) ...)) (range COUNT)))]) -(define (make-byte-parser rule) - (λ (x) (parse-with-template x rule))) - - -(define (parse-with-template in template) - (parameterize ([current-input-port (cond - [(bytes? in) (open-input-bytes in)] - [(path-string? in) (open-input-file in)] - [(input-port? in) in] - [else (error 'unknown-parse-input-type)])]) - (template))) - -(define (unparse-with-template val template) - (parameterize ([unparse-val val]) - (template))) +(define-macro-cases define-rule + [(_ ID RULE-PROC) + (with-pattern ([ID$ (suffix-id #'ID "$")]) + #'(begin + (define (ID [x (current-input-port)]) + (with-handlers ([binary-problem? (λ (exn) + (raise-result-error + 'ID + (binary-problem-msg exn) + (binary-problem-val exn)))]) + (RULE-PROC x))) + (struct ID$ (val) #:transparent)))]) + +(define-rule foo (:seq bar zam #:type hash?)) +(define-rule bar (:atomic 1 #:type integer?)) +(define-rule zam (:atomic 2 #:type integer?)) + +(define-rule foolist (:seq bar zam bar zam)) + +(check-equal? #"AB" (zam (zam (open-input-bytes #"AB"))) (zam 16961)) +(check-equal? #"123" (foo (foo (open-input-bytes #"123"))) (foo '#hash((bar . 49) (zam . 13106)))) + +(foolist (open-input-bytes #"123456")) +(foolist '(49 13106 52 13877)) (require rackunit) #;(check-equal? (parse-with-template "test.gif" gif) @@ -88,8 +148,4 @@ '(signature . "GIF") '(version . "87a"))))) -#;(define parse-width-bytes (make-byte-parser width)) -(define-rule foo (:atomic 2)) -(define parse-foo-bytes (make-byte-parser foo)) -(define in (open-input-bytes #"12")) -(parse-foo-bytes in) +#;(define parse-width-bytes (make-byte-parser width)) \ No newline at end of file