diff --git a/pkgs/parser-tools-pkgs/parser-tools-lib/parser-tools/private-lex/stx.rkt b/pkgs/parser-tools-pkgs/parser-tools-lib/parser-tools/private-lex/stx.rkt index 67cc38a..1104a87 100644 --- a/pkgs/parser-tools-pkgs/parser-tools-lib/parser-tools/private-lex/stx.rkt +++ b/pkgs/parser-tools-pkgs/parser-tools-lib/parser-tools/private-lex/stx.rkt @@ -1,37 +1,38 @@ -(module stx mzscheme - (require "util.rkt" - syntax/id-table) - - (provide parse) +#lang racket - (define (bad-args stx num) - (raise-syntax-error - #f - (format "incorrect number of arguments (should have ~a)" num) - stx)) - - ;; char-range-arg: syntax-object syntax-object -> nat - ;; If c contains is a character or length 1 string, returns the integer - ;; for the character. Otherwise raises a syntax error. - (define (char-range-arg stx containing-stx) - (let ((c (syntax-e stx))) - (cond - ((char? c) (char->integer c)) - ((and (string? c) (= (string-length c) 1)) - (char->integer (string-ref c 0))) - (else - (raise-syntax-error - #f - "not a char or single-char string" - containing-stx stx))))) - (test-block () - ((char-range-arg #'#\1 #'here) (char->integer #\1)) - ((char-range-arg #'"1" #'here) (char->integer #\1))) +(require "util.rkt" + syntax/id-table) + +(provide parse) - (define orig-insp (variable-reference->module-declaration-inspector - (#%variable-reference))) - (define (disarm stx) - (syntax-disarm stx orig-insp)) +(define (bad-args stx num) + (raise-syntax-error + #f + (format "incorrect number of arguments (should have ~a)" num) + stx)) + +;; char-range-arg: syntax-object syntax-object -> nat +;; If c contains is a character or length 1 string, returns the integer +;; for the character. Otherwise raises a syntax error. +(define (char-range-arg stx containing-stx) + (let ((c (syntax-e stx))) + (cond + ((char? c) (char->integer c)) + ((and (string? c) (= (string-length c) 1)) + (char->integer (string-ref c 0))) + (else + (raise-syntax-error + #f + "not a char or single-char string" + containing-stx stx))))) +(module+ test + (check-equal? (char-range-arg #'#\1 #'here) (char->integer #\1)) + (check-equal? (char-range-arg #'"1" #'here) (char->integer #\1))) + +(define orig-insp (variable-reference->module-declaration-inspector + (#%variable-reference))) +(define (disarm stx) + (syntax-disarm stx orig-insp)) ;; parse : syntax-object (box (list-of syntax-object)) -> s-re (see re.rkt) ;; checks for errors and generates the plain s-exp form for s @@ -170,41 +171,50 @@ (and (= 2 (length s-re)) (char-set? (cadr s-re)))) (else #f)))) (else #f))) - (test-block () - ((char-set? #\a) #t) - ((char-set? "12") #f) - ((char-set? "1") #t) - ((char-set? '(repetition 1 2 #\1)) #f) - ((char-set? '(repetition 1 1 "12")) #f) - ((char-set? '(repetition 1 1 "1")) #t) - ((char-set? '(union "1" "2" "3")) #t) - ((char-set? '(union "1" "" "3")) #f) - ((char-set? '(intersection "1" "2" (union "3" "4"))) #t) - ((char-set? '(intersection "1" "")) #f) - ((char-set? '(complement "1")) #f) - ((char-set? '(concatenation "1" "2")) #f) - ((char-set? '(concatenation "" "2")) #f) - ((char-set? '(concatenation "1")) #t) - ((char-set? '(concatenation "12")) #f) - ((char-set? '(char-range #\1 #\2)) #t) - ((char-set? '(char-complement #\1)) #t)) + + (module+ test + (require rackunit)) + (module+ test + (check-equal? (char-set? #\a) #t) + (check-equal? (char-set? "12") #f) + (check-equal? (char-set? "1") #t) + (check-equal? (char-set? '(repetition 1 2 #\1)) #f) + (check-equal? (char-set? '(repetition 1 1 "12")) #f) + (check-equal? (char-set? '(repetition 1 1 "1")) #t) + (check-equal? (char-set? '(union "1" "2" "3")) #t) + (check-equal? (char-set? '(union "1" "" "3")) #f) + (check-equal? (char-set? '(intersection "1" "2" (union "3" "4"))) #t) + (check-equal? (char-set? '(intersection "1" "")) #f) + (check-equal? (char-set? '(complement "1")) #f) + (check-equal? (char-set? '(concatenation "1" "2")) #f) + (check-equal? (char-set? '(concatenation "" "2")) #f) + (check-equal? (char-set? '(concatenation "1")) #t) + (check-equal? (char-set? '(concatenation "12")) #f) + (check-equal? (char-set? '(char-range #\1 #\2)) #t) + (check-equal? (char-set? '(char-complement #\1)) #t)) - (test-block () - ((parse #'#\a) #\a) - ((parse #'"1") "1") - ((parse #'(repetition 1 1 #\1)) '(repetition 1 1 #\1)) - ((parse #'(repetition 0 +inf.0 #\1)) '(repetition 0 +inf.0 #\1)) - ((parse #'(union #\1 (union "2") (union))) - '(union #\1 (union "2") (union))) - ((parse #'(intersection #\1 (intersection "2") (intersection))) - '(intersection #\1 (intersection "2") (intersection))) - ((parse #'(complement (union #\1 #\2))) - '(complement (union #\1 #\2))) - ((parse #'(concatenation "1" "2" (concatenation))) - '(concatenation "1" "2" (concatenation))) - ((parse #'(char-range "1" #\1)) '(char-range #\1 #\1)) - ((parse #'(char-range #\1 "1")) '(char-range #\1 #\1)) - ((parse #'(char-range "1" "3")) '(char-range #\1 #\3)) - ((parse #'(char-complement (union "1" "2"))) - '(char-complement (union "1" "2")))) - ) + ;; yikes... these test cases all have the wrong arity, now. + ;; and by "now", I mean it's been broken since before we + ;; moved to git. + (module+ test + (check-equal? (parse #'#\a null) #\a) + (check-equal? (parse #'"1" null) "1") + (check-equal? (parse #'(repetition 1 1 #\1) null) + '(repetition 1 1 #\1)) + (check-equal? (parse #'(repetition 0 +inf.0 #\1) null) '(repetition 0 +inf.0 #\1)) + (check-equal? (parse #'(union #\1 (union "2") (union)) null) + '(union #\1 (union "2") (union))) + (check-equal? (parse #'(intersection #\1 (intersection "2") (intersection)) + null) + '(intersection #\1 (intersection "2") (intersection))) + (check-equal? (parse #'(complement (union #\1 #\2)) + null) + '(complement (union #\1 #\2))) + (check-equal? (parse #'(concatenation "1" "2" (concatenation)) null) + '(concatenation "1" "2" (concatenation))) + (check-equal? (parse #'(char-range "1" #\1) null) '(char-range #\1 #\1)) + (check-equal? (parse #'(char-range #\1 "1") null) '(char-range #\1 #\1)) + (check-equal? (parse #'(char-range "1" "3") null) '(char-range #\1 #\3)) + (check-equal? (parse #'(char-complement (union "1" "2")) null) + '(char-complement (union "1" "2")))) +; ) diff --git a/pkgs/parser-tools-pkgs/parser-tools-lib/parser-tools/private-lex/unicode-chars.rkt b/pkgs/parser-tools-pkgs/parser-tools-lib/parser-tools/private-lex/unicode-chars.rkt index 457aaf5..c21e88c 100644 --- a/pkgs/parser-tools-pkgs/parser-tools-lib/parser-tools/private-lex/unicode-chars.rkt +++ b/pkgs/parser-tools-pkgs/parser-tools-lib/parser-tools/private-lex/unicode-chars.rkt @@ -1,67 +1,69 @@ -(module unicode-chars mzscheme - (require "util.rkt") - - (provide (all-defined)) - - ;; mapped-chars : (listof (list nat nat bool)) - (define mapped-chars (make-known-char-range-list)) - - - ;; get-chars-for-x : (nat -> bool) (listof (list nat nat bool)) -> (listof (cons nat nat)) - (define (get-chars-for char-x? mapped-chars) - (cond - ((null? mapped-chars) null) - (else - (let* ((range (car mapped-chars)) - (low (car range)) - (high (cadr range)) - (x (char-x? low))) - (cond - ((caddr range) - (if x - (cons (cons low high) - (get-chars-for char-x? (cdr mapped-chars))) - (get-chars-for char-x? (cdr mapped-chars)))) - (else - (let loop ((range-start low) - (i (car range)) - (parity x)) - (cond - ((> i high) - (if parity - (cons (cons range-start high) (get-chars-for char-x? (cdr mapped-chars))) - (get-chars-for char-x? (cdr mapped-chars)))) - ((eq? parity (char-x? i)) - (loop range-start (add1 i) parity)) - (parity - (cons (cons range-start (sub1 i)) (loop i (add1 i) #f))) - (else - (loop i (add1 i) #t)))))))))) +#lang racket - (define (compute-ranges x?) - (delay (get-chars-for (lambda (x) (x? (integer->char x))) mapped-chars))) - - (define alphabetic-ranges (compute-ranges char-alphabetic?)) ;; 325 - (define lower-case-ranges (compute-ranges char-lower-case?)) ;; 405 - (define upper-case-ranges (compute-ranges char-upper-case?)) ;; 380 - (define title-case-ranges (compute-ranges char-title-case?)) ;; 10 - (define numeric-ranges (compute-ranges char-numeric?)) ;; 47 - (define symbolic-ranges (compute-ranges char-symbolic?)) ;; 153 - (define punctuation-ranges (compute-ranges char-punctuation?)) ;; 86 - (define graphic-ranges (compute-ranges char-graphic?)) ;; 401 - (define whitespace-ranges (compute-ranges char-whitespace?)) ;; 10 - (define blank-ranges (compute-ranges char-blank?)) ;; 9 - #;(define hexadecimal-ranges (compute-ranges char-hexadecimal?)) - (define iso-control-ranges (compute-ranges char-iso-control?)) ;; 2 +(require "util.rkt") + +(provide (all-defined-out)) +;; mapped-chars : (listof (list nat nat bool)) +(define mapped-chars (make-known-char-range-list)) +;; get-chars-for-x : (nat -> bool) (listof (list nat nat bool)) -> (listof (cons nat nat)) +(define (get-chars-for char-x? mapped-chars) + (cond + ((null? mapped-chars) null) + (else + (let* ((range (car mapped-chars)) + (low (car range)) + (high (cadr range)) + (x (char-x? low))) + (cond + ((caddr range) + (if x + (cons (cons low high) + (get-chars-for char-x? (cdr mapped-chars))) + (get-chars-for char-x? (cdr mapped-chars)))) + (else + (let loop ((range-start low) + (i (car range)) + (parity x)) + (cond + ((> i high) + (if parity + (cons (cons range-start high) (get-chars-for char-x? (cdr mapped-chars))) + (get-chars-for char-x? (cdr mapped-chars)))) + ((eq? parity (char-x? i)) + (loop range-start (add1 i) parity)) + (parity + (cons (cons range-start (sub1 i)) (loop i (add1 i) #f))) + (else + (loop i (add1 i) #t)))))))))) - (test-block () - ((get-chars-for odd? '()) '()) - ((get-chars-for odd? '((1 4 #f) (8 13 #f))) '((1 . 1) (3 . 3) (9 . 9) (11 . 11) (13 . 13))) - ((get-chars-for (lambda (x) - (odd? (quotient x 10))) - '((1 5 #t) (17 19 #t) (21 51 #f))) - '((17 . 19) (30 . 39) (50 . 51)))) +(define (compute-ranges x?) + (delay (get-chars-for (lambda (x) (x? (integer->char x))) mapped-chars))) + +(define alphabetic-ranges (compute-ranges char-alphabetic?)) ;; 325 +(define lower-case-ranges (compute-ranges char-lower-case?)) ;; 405 +(define upper-case-ranges (compute-ranges char-upper-case?)) ;; 380 +(define title-case-ranges (compute-ranges char-title-case?)) ;; 10 +(define numeric-ranges (compute-ranges char-numeric?)) ;; 47 +(define symbolic-ranges (compute-ranges char-symbolic?)) ;; 153 +(define punctuation-ranges (compute-ranges char-punctuation?)) ;; 86 +(define graphic-ranges (compute-ranges char-graphic?)) ;; 401 +(define whitespace-ranges (compute-ranges char-whitespace?)) ;; 10 +(define blank-ranges (compute-ranges char-blank?)) ;; 9 +#;(define hexadecimal-ranges (compute-ranges char-hexadecimal?)) +(define iso-control-ranges (compute-ranges char-iso-control?)) ;; 2 + + + +(module+ test + (require rackunit) + (check-equal? (get-chars-for odd? '()) '()) + (check-equal? (get-chars-for odd? '((1 4 #f) (8 13 #f))) + '((1 . 1) (3 . 3) (9 . 9) (11 . 11) (13 . 13))) + (check-equal? (get-chars-for (lambda (x) + (odd? (quotient x 10))) + '((1 5 #t) (17 19 #t) (21 51 #f))) + '((17 . 19) (30 . 39) (50 . 51)))) - ) + diff --git a/pkgs/parser-tools-pkgs/parser-tools-lib/parser-tools/private-lex/util.rkt b/pkgs/parser-tools-pkgs/parser-tools-lib/parser-tools/private-lex/util.rkt index 29c4017..a7afc54 100644 --- a/pkgs/parser-tools-pkgs/parser-tools-lib/parser-tools/private-lex/util.rkt +++ b/pkgs/parser-tools-pkgs/parser-tools-lib/parser-tools/private-lex/util.rkt @@ -1,14 +1,16 @@ -(module util mzscheme - (require mzlib/list) - - (provide (all-defined)) +#lang racket - (define max-char-num #x10FFFF) - - (define-struct lex-abbrev (get-abbrev)) - (define-struct lex-trans (f)) - - #;(define-syntax test-block +(provide (all-defined-out)) + +(define max-char-num #x10FFFF) + +(define-struct lex-abbrev (get-abbrev)) +(define-struct lex-trans (f)) + +(module+ test + (require rackunit)) + +#;(define-syntax test-block (syntax-rules () ((_ defs (code right-ans) ...) (let* defs @@ -17,100 +19,109 @@ (printf "Test failed: ~e gave ~e. Expected ~e\n" 'code real-ans 'right-ans))) ...)))) - (define-syntax test-block - (syntax-rules () - ((_ x ...) (void)))) - - - ;; A cache is (X ( -> Y) -> Y) - ;; make-cache : -> cache - ;; table map Xs to Ys. If key is mapped, its value is returned. - ;; Otherwise, build is invoked and its result is placed in the table and - ;; returned. - ;; Xs are compared with equal? - (define (make-cache) - (let ((table (make-hash-table 'equal))) - (lambda (key build) - (hash-table-get table key - (lambda () - (let ((new (build))) - (hash-table-put! table key new) - new)))))) - (test-block ((cache (make-cache))) - ((cache '(s 1 2) (lambda () 9)) 9) - ((cache '(s 2 1) (lambda () 8)) 8) - ((cache '(s 1 2) (lambda () 1)) 9) - ((cache (cons 's (cons 0 (cons +inf.0 10))) (lambda () 22)) 22) - ((cache (cons 's (cons 0 (cons +inf.0 10))) (lambda () 1)) 22)) - +(define-syntax test-block + (syntax-rules () + ((_ x ...) (void)))) - - ;; make-counter : -> -> nat - ;; makes a function that returns a higher number by 1, each time - ;; it is called. - (define (make-counter) - (let ((counter 0)) - (lambda () - (begin0 - counter - (set! counter (add1 counter)))))) - (test-block ((c (make-counter)) - (d (make-counter))) - ((c) 0) - ((d) 0) - ((c) 1) - ((d) 1) - ((c) 2)) - - ;; remove-dups : (list-of X) (X -> number) -> (list-of X) - ;; removes the entries from l that have the same index as a - ;; previous entry. l must be grouped by indexes. - (define (remove-dups l index acc) - (cond - ((null? l) (reverse acc)) - ((null? acc) (remove-dups (cdr l) index (cons (car l) acc))) - ((= (index (car acc)) (index (car l))) - (remove-dups (cdr l) index acc)) - (else - (remove-dups (cdr l) index (cons (car l) acc))))) - - (test-block () - ((remove-dups '((1 2) (2 2) (1 3) (1 4) (100 4) (0 5)) cadr null) - '((1 2) (1 3) (1 4) (0 5))) - ((remove-dups null error null) null)) - - - ;; do-simple-equiv : (list-of X) (X -> nat) -> (list-of X) - ;; Sorts l according to index and removes the entries with duplicate - ;; indexes. - (define (do-simple-equiv l index) - (let ((ordered (sort l (lambda (a b) (< (index a) (index b)))))) - (remove-dups ordered index null))) - - (test-block () - ((do-simple-equiv '((2 2) (1 4) (1 2) (100 4) (1 3) (0 5)) cadr) - '((2 2) (1 3) (1 4) (0 5))) - ((do-simple-equiv null error) null)) - +;; A cache is (X ( -> Y) -> Y) +;; make-cache : -> cache +;; table map Xs to Ys. If key is mapped, its value is returned. +;; Otherwise, build is invoked and its result is placed in the table and +;; returned. +;; Xs are compared with equal? +(define (make-cache) + (let ((table (make-hash))) + (lambda (key build) + (hash-ref table key + (lambda () + (let ((new (build))) + (hash-set! table key new) + new)))))) + +(module+ test + (define cache (make-cache)) + (check-equal? (cache '(s 1 2) (lambda () 9)) 9) + (check-equal? (cache '(s 2 1) (lambda () 8)) 8) + (check-equal? (cache '(s 1 2) (lambda () 1)) 9) + (check-equal? (cache (cons 's (cons 0 (cons +inf.0 10))) + (lambda () 22)) 22) + (check-equal? (cache (cons 's (cons 0 (cons +inf.0 10))) + (lambda () 1)) 22)) + + + +;; make-counter : -> -> nat +;; makes a function that returns a higher number by 1, each time +;; it is called. +(define (make-counter) + (let ((counter 0)) + (lambda () + (begin0 + counter + (set! counter (add1 counter)))))) + +(module+ test + (define c (make-counter)) + (define d (make-counter)) + (check-equal? (c) 0) + (check-equal? (d) 0) + (check-equal? (c) 1) + (check-equal? (d) 1) + (check-equal? (c) 2)) + + +;; remove-dups : (list-of X) (X -> number) -> (list-of X) +;; removes the entries from l that have the same index as a +;; previous entry. l must be grouped by indexes. +(define (remove-dups l index acc) + (cond + ((null? l) (reverse acc)) + ((null? acc) (remove-dups (cdr l) index (cons (car l) acc))) + ((= (index (car acc)) (index (car l))) + (remove-dups (cdr l) index acc)) + (else + (remove-dups (cdr l) index (cons (car l) acc))))) + + +(module+ test + (check-equal? (remove-dups '((1 2) (2 2) (1 3) (1 4) + (100 4) (0 5)) cadr null) + '((1 2) (1 3) (1 4) (0 5))) + (check-equal? (remove-dups null error null) null)) + +;; do-simple-equiv : (list-of X) (X -> nat) -> (list-of X) +;; Sorts l according to index and removes the entries with duplicate +;; indexes. +(define (do-simple-equiv l index) + (let ((ordered (sort l (lambda (a b) (< (index a) (index b)))))) + (remove-dups ordered index null))) + +(module+ test + (check-equal? (do-simple-equiv '((2 2) (1 4) (1 2) + (100 4) (1 3) (0 5)) + cadr) + '((2 2) (1 3) (1 4) (0 5))) + (check-equal? (do-simple-equiv null error) null)) + +;; replace : (list-of X) (X -> bool) (X -> (list-of X)) (list-of X) -> +;; (list-of X) +;; If (pred? r) for some r in l, splice (get r) in place of r in the resulting +;; list. +(define (replace l pred? get acc) + (cond + ((null? l) acc) + ((pred? (car l)) (replace (cdr l) pred? get (append (get (car l)) acc))) + (else (replace (cdr l) pred? get (cons (car l) acc))))) + - ;; replace : (list-of X) (X -> bool) (X -> (list-of X)) (list-of X) -> - ;; (list-of X) - ;; If (pred? r) for some r in l, splice (get r) in place of r in the resulting - ;; list. - (define (replace l pred? get acc) - (cond - ((null? l) acc) - ((pred? (car l)) (replace (cdr l) pred? get (append (get (car l)) acc))) - (else (replace (cdr l) pred? get (cons (car l) acc))))) - - (test-block () - ((replace null void (lambda () (list 1)) null) null) - ((replace '(1 2 3 4 3 5) - (lambda (x) (= x 3)) - (lambda (x) (list 1 2 3)) - null) - '(5 1 2 3 4 1 2 3 2 1))) +(module+ test + (check-equal? (replace null void (lambda () (list 1)) null) null) + (check-equal? (replace '(1 2 3 4 3 5) + (lambda (x) (= x 3)) + (lambda (x) (list 1 2 3)) + null) + '(5 1 2 3 4 1 2 3 2 1))) - ) +