├── trivial ├── list.rkt ├── define.rkt ├── scribblings │ ├── .gitignore │ ├── Makefile │ ├── trivial.scrbl │ └── using-tailorings.scrbl ├── vector.rkt ├── no-colon.rkt ├── format.rkt ├── integer.rkt ├── regexp.rkt ├── db.rkt ├── string.rkt ├── function.rkt ├── main.rkt ├── private │ ├── README.md │ ├── db │ │ ├── mysql.rkt │ │ ├── postgres.rkt │ │ ├── query.rkt │ │ └── schema.rkt │ ├── test-common.rkt │ ├── function.rkt │ ├── format.rkt │ ├── db.rkt │ ├── define.rkt │ ├── integer.rkt │ ├── tailoring.rkt │ ├── raco-command.rkt │ ├── list.rkt │ ├── string.rkt │ ├── regexp.rkt │ ├── vector.rkt │ ├── sequence-domain.rkt │ └── common.rkt ├── info.rkt └── tailoring.rkt ├── .gitignore ├── test ├── README.md ├── double-expand.rkt ├── function-fail.rkt ├── format-fail.rkt ├── string-fail.rkt ├── set-bang.rkt ├── function-pass.rkt ├── list-fail.rkt ├── vector-fail.rkt ├── format-pass.rkt ├── define-pass.rkt ├── integer-fail.rkt ├── string-pass.rkt ├── regexp-fail.rkt ├── db-pass.rkt ├── list-pass.rkt ├── integer-pass.rkt ├── logging.rkt ├── vector-pass.rkt ├── db-fail.rkt └── regexp-pass.rkt ├── LICENSE.txt ├── .travis.yml └── README.md /trivial/list.rkt: -------------------------------------------------------------------------------- 1 | #lang reprovide 2 | 3 | trivial/private/list 4 | -------------------------------------------------------------------------------- /trivial/define.rkt: -------------------------------------------------------------------------------- 1 | #lang reprovide 2 | 3 | trivial/private/define 4 | -------------------------------------------------------------------------------- /trivial/scribblings/.gitignore: -------------------------------------------------------------------------------- 1 | *\.css 2 | *\.html 3 | *\.js 4 | *\.sh 5 | -------------------------------------------------------------------------------- /trivial/vector.rkt: -------------------------------------------------------------------------------- 1 | #lang reprovide 2 | 3 | trivial/private/vector 4 | -------------------------------------------------------------------------------- /trivial/no-colon.rkt: -------------------------------------------------------------------------------- 1 | #lang reprovide 2 | trivial 3 | 4 | ;; For backwards compatibility 5 | -------------------------------------------------------------------------------- /trivial/format.rkt: -------------------------------------------------------------------------------- 1 | #lang reprovide 2 | 3 | (except-in trivial/private/format 4 | F-dom) 5 | -------------------------------------------------------------------------------- /trivial/integer.rkt: -------------------------------------------------------------------------------- 1 | #lang reprovide 2 | 3 | (except-in trivial/private/integer 4 | I-dom) 5 | -------------------------------------------------------------------------------- /trivial/regexp.rkt: -------------------------------------------------------------------------------- 1 | #lang reprovide 2 | 3 | (except-in trivial/private/regexp 4 | R-dom) 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | compiled 2 | coverage 3 | doc 4 | 5 | *\.swp 6 | *~ 7 | \.\#* 8 | 9 | vdt/ 10 | -------------------------------------------------------------------------------- /trivial/db.rkt: -------------------------------------------------------------------------------- 1 | #lang reprovide 2 | 3 | (except-in trivial/private/db 4 | DB-dom Connection-dom) 5 | -------------------------------------------------------------------------------- /trivial/string.rkt: -------------------------------------------------------------------------------- 1 | #lang reprovide 2 | 3 | (except-in trivial/private/string 4 | B-dom S-dom) 5 | 6 | -------------------------------------------------------------------------------- /trivial/function.rkt: -------------------------------------------------------------------------------- 1 | #lang reprovide 2 | 3 | (except-in trivial/private/function 4 | A-dom format-arity-error) 5 | -------------------------------------------------------------------------------- /trivial/scribblings/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | raco scribble \ 3 | --html \ 4 | ++main-xref-in \ 5 | --redirect-main http://docs.racket-lang.org/ \ 6 | trivial.scrbl 7 | 8 | clean: 9 | rm -rf compiled 10 | rm *.css 11 | rm *.js 12 | rm *.html 13 | -------------------------------------------------------------------------------- /trivial/main.rkt: -------------------------------------------------------------------------------- 1 | #lang reprovide 2 | 3 | ;trivial/db 4 | 5 | trivial/define 6 | trivial/format 7 | trivial/function 8 | (except-in trivial/list first second third make-list) 9 | trivial/integer 10 | trivial/regexp 11 | trivial/string 12 | trivial/vector 13 | (only-in trivial/private/common 14 | [ttt-logger trivial-logger]) 15 | -------------------------------------------------------------------------------- /test/README.md: -------------------------------------------------------------------------------- 1 | test 2 | === 3 | 4 | Root directory for `trivial` package test cases. 5 | 6 | There should be 2 files for each module `M` in the parent directory. 7 | - `M-pass.rkt` : tests exercising intended behavior 8 | - `M-fail.rkt` : tests that should raise type errors 9 | 10 | Run tests for any file with `raco test FILE.rkt`. 11 | -------------------------------------------------------------------------------- /trivial/private/README.md: -------------------------------------------------------------------------------- 1 | private 2 | === 3 | 4 | Files that no law-abiding library user should `require`. 5 | 6 | - `common.rkt` Helper functions common to a few macros. 7 | - `set-bang.rkt` Restrict `set!` to respect our syntax property metadata. 8 | - `test-common.rkt` Helpers for unit testing 9 | - `db/` Support for the `db.rkt` implementation 10 | -------------------------------------------------------------------------------- /test/double-expand.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Each identifier from `trivial` should produce exactly 1 log message 4 | 5 | (module+ test 6 | (require 7 | (only-in trivial lambda + -) 8 | rackunit 9 | trivial/private/test-common) 10 | 11 | (test-case "double-expand" 12 | 13 | (check-trivial-log-sequence 14 | (lambda (x) (- (+ x x) 1)) 15 | '((INFER+ lambda) 16 | (CHECK- +) 17 | (CHECK- -)))) 18 | ) 19 | -------------------------------------------------------------------------------- /test/function-fail.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require 3 | trivial/private/test-common 4 | (only-in racket/port open-output-nowhere)) 5 | 6 | (module+ test 7 | (parameterize (#;[current-error-port (open-output-nowhere)]) ;; TODO 8 | (test-compile-error 9 | #:require trivial/function 10 | #:exn exn? ;#rx"Type Checker" 11 | ((curry (lambda (x y) x)) 0 1) 12 | (((curry (lambda (x y z) z)) 'x) 'y 'z) 13 | (((curry (lambda ([x : Integer] [y : Integer]) (+ x x y))) 'a) 'b) 14 | ((((curry (λ ([x : Any] [y : Any]) x)) 'a) 'b) 'c) 15 | ))) 16 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | trivial 2 | Copyright (c) 2015-2024 Ben Greenman 3 | 4 | This package is distributed under the GNU Lesser General Public 5 | License (LGPL). This means that you can link this package into proprietary 6 | applications, provided you follow the rules stated in the LGPL. You 7 | can also modify this package; if you distribute a modified version, 8 | you must distribute it under the terms of the LGPL, which in 9 | particular means that you must release the source code for the 10 | modified software. See http://www.gnu.org/copyleft/lesser.html 11 | for more information. 12 | -------------------------------------------------------------------------------- /test/format-fail.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require trivial/private/test-common) 3 | 4 | ;; `format:` expressions that should fail to compile 5 | 6 | (module+ test (test-compile-error 7 | #:require trivial/format trivial/define 8 | #:exn #rx"format:|printf:|Type Checker" 9 | (printf "hello ~a" "john" "doe") 10 | (printf "hello ~a" "john" "doe") 11 | (printf "binary number ~b\n" 3.14) 12 | (printf "character ~c\n" 88) 13 | (printf "octl ~o\n" 1.0+2i) 14 | (printf "hex ~o\n" (exact->inexact 0)) 15 | (let () 16 | (define s "asdf ~a asdf") 17 | (printf s)) 18 | (let ([s "asdf ~a asdf"]) 19 | (printf s)) 20 | )) 21 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | langauge: c 2 | sudo: false 3 | env: 4 | global: 5 | - RACKET_DIR=~/racket 6 | matrix: 7 | - RACKET_VERSION=HEAD 8 | 9 | before_install: 10 | - git clone https://github.com/greghendershott/travis-racket.git ../travis-racket 11 | - cat ../travis-racket/install-racket.sh | bash 12 | - export PATH="${RACKET_DIR}/bin:${PATH}" 13 | 14 | install: raco pkg install --deps search-auto $TRAVIS_BUILD_DIR/trivial 15 | 16 | #before_script: 17 | # - psql -c 'create database travis_ci_test;' -U postgres 18 | 19 | script: 20 | - raco setup --check-pkg-deps trivial 21 | - raco test $TRAVIS_BUILD_DIR/trivial 22 | - raco test $TRAVIS_BUILD_DIR/test 23 | 24 | #after_success: 25 | # - raco pkg install --deps search-auto cover 26 | # - raco pkg install --deps search-auto cover-coveralls 27 | # - raco cover -f coveralls -d $TRAVIS_BUILD_DIR/coverage -b . 28 | -------------------------------------------------------------------------------- /test/string-fail.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require 3 | trivial/private/test-common) 4 | 5 | (module+ test (test-compile-error 6 | #:require trivial/string 7 | #:exn #rx"out of range" 8 | (string-ref "" 0) 9 | (string-ref "abc" 3) 10 | (string-ref "a" -1) 11 | ;;(string-set! "" 0 #\x) 12 | ;;(string-set! "a" 3 ((lambda (x) x) #\A)) ;; TODO not a compile-time error 13 | (substring "asdf" -3) 14 | (substring "asdf" 0 8) 15 | (substring "asdf" 0 -1) 16 | (substring "asdf" 99 3) 17 | 18 | (bytes-ref #"" 8) 19 | (bytes-ref #"aaa" -1) 20 | ;;(bytes-set! #"a" 1 3) 21 | ;;(bytes-set! #"a" -1 69) 22 | (subbytes #"xxx" -2) 23 | (subbytes #"xxx" 2 4) 24 | (subbytes #"xxx" -8 -2))) 25 | 26 | (module+ test (test-compile-error 27 | #:require trivial/string 28 | #:exn #rx"Invalid slice range" 29 | (substring "asdf" 2 1) 30 | (subbytes #"asdf" 1 0))) 31 | 32 | -------------------------------------------------------------------------------- /trivial/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | (define collection "trivial") 3 | (define deps '("base" 4 | "db-lib" 5 | "plot-lib" 6 | "rackunit-lib" 7 | "reprovide-lang" 8 | "scribble-lib" 9 | "typed-racket-lib" 10 | "typed-racket-more")) 11 | (define build-deps '("at-exp-lib" 12 | "racket-doc" 13 | "rackunit-abbrevs" 14 | "rackunit-lib" 15 | "scribble-doc" 16 | "typed-racket-doc" 17 | "scribble-lib")) 18 | (define pkg-desc "Macros for lightweight program analysis") 19 | (define version "2.1") 20 | (define pkg-authors '(ben)) 21 | (define scribblings '(("scribblings/trivial.scrbl" () ("typed-racket")))) 22 | (define raco-commands '(("trivial" (submod trivial/private/raco-command main) "Compile and log optimizations" #f))) 23 | -------------------------------------------------------------------------------- /test/set-bang.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; TODO the `vector-ref` should not be optimized 4 | ;; -- its variable is set! 5 | ;; -- the set! eventually makes an unsafe reference 6 | 7 | ;; ideas: 8 | ;; - don't produce unsafe-ref, produce a different checked'ref 9 | ;; that's easier for the compiler to optimize 10 | ;; - don't produce unsafe-ref at all 11 | ;; - disallow set! 12 | ;; - globally analyze, find all set! vars before macro expanding 13 | ;; - leave a disclaimer 14 | ;; - undo relevant changes 15 | ;; - detect if interpolant used in optimization 16 | 17 | ;; - possible to do a whole-program 1st pass? 18 | 19 | #; 20 | (module+ test 21 | (require (except-in trivial add1) rackunit) 22 | 23 | (check-equal? 24 | (let* ([len 2] 25 | [v (build-vector len values)] 26 | [i 0]) 27 | (let loop () 28 | (if (<= i len) 29 | (+ (vector-ref v i) 30 | (begin 31 | (set! i (add1 i)) 32 | (loop))) 33 | 0))) 34 | 1) ;; should not segfault! 35 | ) 36 | -------------------------------------------------------------------------------- /test/function-pass.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | 3 | (module+ test 4 | (require 5 | trivial/function 6 | typed/rackunit) 7 | 8 | (check-equal? 9 | (((curry (lambda (x y) x)) 'x) 'y) 10 | 'x) 11 | 12 | (check-equal? 13 | ((((curry (lambda (x y z) z)) 0) 1) 2) 14 | 2) 15 | 16 | (check-equal? 17 | (((curry (lambda ([x : Integer] [y : Integer]) 2)) 0) 1) 18 | 2) 19 | 20 | (check-true 21 | (begin 22 | (curry (lambda ([x : Integer]) x)) 23 | (curry (lambda ([x : String]) x)) 24 | (curry (lambda ([x : Any]) x)) 25 | ((curry (lambda (x) x)) 1) 26 | ((curry (lambda ([x : (Listof Any)]) x)) '()) 27 | (curry (lambda ([x : (Listof Boolean)]) x)) 28 | (curry (lambda ([x : (Vectorof (Listof Boolean))]) x)) 29 | #t)) 30 | 31 | (check-equal? 32 | ((curry (lambda ([x : Integer]) x)) 3) 33 | 3) 34 | 35 | (check-equal? 36 | (((curry (lambda ([x : Integer] [y : Integer]) (+ x x y))) 3) 1) 37 | 7) 38 | 39 | (check-equal? 40 | (((curry (λ ([x : Any] [y : Any]) x)) 'a) 'b) 41 | 'a) 42 | 43 | ) 44 | -------------------------------------------------------------------------------- /test/list-fail.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require trivial/private/test-common) 3 | 4 | (module+ test (test-compile-error 5 | #:require trivial 6 | #:exn #rx"out of range|Type Checker" 7 | 8 | (let ([v1 (list 1)]) 9 | (let ([v2 (list v1)]) 10 | (list-ref (list-ref v2 0) 1))) 11 | 12 | (car '()) 13 | (cdr '()) 14 | 15 | (list-ref (list 1) 3) 16 | 17 | (let ([v (list 1 2 3)]) 18 | (list-ref v 3)) 19 | 20 | (let () 21 | (define v (list 3 4)) 22 | (list-ref v 9)) 23 | 24 | (list-ref (map (lambda (x) x) (list #t "ha")) 20) 25 | 26 | (list-ref (list 0) -5) 27 | 28 | (list-ref 29 | (map add1 (map add1 (map add1 (list 0 0 0)))) 30 | 3) 31 | 32 | (list-ref (map symbol->string (list 'a 'b)) 5) 33 | 34 | (list-ref 35 | (map add1 (map add1 (map add1 (list 0 0 0)))) 36 | 3) 37 | 38 | (let ([v (list 0 0 0)] 39 | [v2 (list 1 2)]) 40 | (list-ref (append v2 v) 8)) 41 | 42 | (list-ref (list 1 2 1) 3) 43 | 44 | 45 | )) 46 | 47 | ;; TODO these raise errors in the test environment, 48 | ;; but "work as expected" 49 | ; (map (λ ([x : String] [y : String]) 50 | ; (string-append x y)) 51 | ; '("hello")) 52 | ; 53 | ; (map (λ ([x : String] [y : String]) 54 | ; (string-append x y)) 55 | ; '("hello") 56 | ; '("world") 57 | ; '("howareya")) 58 | ; 59 | ; (map (λ ([x : String] [y : String]) 60 | ; (format "~d ~d" x y)) 61 | ; '("hello") 62 | ; '("world")) 63 | -------------------------------------------------------------------------------- /trivial/tailoring.rkt: -------------------------------------------------------------------------------- 1 | #lang reprovide 2 | 3 | (only-in trivial/private/common 4 | [ttt-logger trivial-logger]) 5 | 6 | trivial/private/tailoring 7 | 8 | (for-syntax 9 | (only-in trivial/private/common 10 | φ 11 | φ? 12 | φ-init 13 | φ-ref 14 | φ-set 15 | φ<=? 16 | 17 | [make-abstract-domain make-property-domain] 18 | [abstract-domain? property-domain?] 19 | in-domain? 20 | ⊥ 21 | ⊤ 22 | ⊥? 23 | ⊤? 24 | ⊓ 25 | ⊓* 26 | [⊓ glb] 27 | [⊓* glb*] 28 | ⊔ 29 | [⊔ lub] 30 | ⊔* 31 | [⊔* lub*] 32 | reduce 33 | reduce*)) 34 | 35 | (only-in trivial/private/format 36 | [F-dom format-string-domain]) 37 | (only-in trivial/private/function 38 | [A-dom arity-domain]) 39 | (only-in trivial/private/integer 40 | [I-dom integer-domain]) 41 | (only-in trivial/private/regexp 42 | [R-dom regexp-group-domain]) 43 | (for-syntax 44 | (only-in trivial/private/sequence-domain 45 | list-domain 46 | vector-domain 47 | vector-domain->list-domain 48 | list-domain->vector-domain 49 | [list-domain->I-dom list-domain->integer-domain] 50 | [I-dom->list-domain integer-domain->list-domain] 51 | [vector-domain->I-dom vector-domain->integer-domain] 52 | [I-dom->vector-domain integer-domain->vector-domain] 53 | list-domain-append* 54 | list-domain-car 55 | list-domain-cdr 56 | list-domain-cons 57 | list-domain-length 58 | list-domain-ref 59 | list-domain-reverse 60 | list-domain-set 61 | list-domain-slice 62 | vector-domain-append* 63 | vector-domain-length 64 | vector-domain-ref 65 | vector-domain-set 66 | vector-domain-slice)) 67 | -------------------------------------------------------------------------------- /test/vector-fail.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require 3 | trivial/private/test-common) 4 | 5 | (module+ test (test-compile-error 6 | #:require trivial 7 | #:exn #rx"out of range|Type Checker" 8 | 9 | (vector-ref (vector 1) 3) 10 | 11 | (let ([v (vector 1 2 3)]) 12 | (vector-ref v 3)) 13 | 14 | (let () 15 | (define v (vector 3 4)) 16 | (vector-ref v 9)) 17 | 18 | (let ([v1 (vector 1)]) 19 | (let ([v2 (vector v1)]) 20 | (vector-ref (vector-ref v2 0) 1))) 21 | 22 | (vector-set! (vector 0) -1 0) 23 | 24 | (vector-set! (vector 0) 0 "hello") ;; Strong update 25 | 26 | (vector-ref (vector-map (lambda (x) x) (vector #t "ha")) 20) 27 | 28 | (vector-ref (vector 0) -5) 29 | 30 | (vector-ref 31 | (vector-map add1 (vector-map add1 (vector-map add1 (vector 0 0 0)))) 32 | 3) 33 | 34 | (vector-ref (vector-map! (lambda (x) x) (vector #t #t)) 4) 35 | (vector-ref (vector-map! symbol->string (vector 'a 'b)) 0) 36 | 37 | (vector-ref 38 | (vector-map! add1 (vector-map! add1 (vector-map! add1 (vector 0 0 0)))) 39 | 3) 40 | 41 | (let ([v (vector 0 0 0)] 42 | [v2 (vector 1 2)]) 43 | (vector-ref (vector-append v2 v) 8)) 44 | 45 | (vector-ref (vector->immutable-vector (vector 1 2 1)) 3) 46 | 47 | (vector-take (vector) 1) 48 | (vector-take (vector 1 2) 4) 49 | (vector-take (vector 'a) -1) 50 | 51 | (vector-take-right (vector) 1) 52 | (vector-take-right (vector 1 2) 4) 53 | (vector-take-right (vector 'a) -1) 54 | 55 | (vector-drop (vector) 1) 56 | (vector-drop (vector 1 2) 4) 57 | (vector-drop (vector 'a) -1) 58 | 59 | (vector-drop-right (vector) 1) 60 | (vector-drop-right (vector 1 2) 4) 61 | (vector-drop-right (vector 'a) -1) 62 | 63 | )) 64 | -------------------------------------------------------------------------------- /test/format-pass.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | 3 | ;; Successful use of `format` 4 | 5 | (module+ test 6 | 7 | (require 8 | trivial/format 9 | typed/rackunit 10 | racket/port) 11 | 12 | (define-syntax-rule (test-format [template arg* ...] expect) 13 | (begin 14 | (check-equal? 15 | (format template arg* ...) 16 | expect) 17 | (check-equal? 18 | (with-output-to-string (lambda () (printf template arg* ...))) 19 | expect))) 20 | 21 | (test-format ["success"] "success") 22 | (test-format ["~a" "hi"] "hi") 23 | (test-format ["~A" "hi"] "hi") 24 | (test-format ["~b" 9] "1001") 25 | (test-format ["~B" 9] "1001") 26 | (test-format ["~c" #\Y] "Y") 27 | (test-format ["~C" #\Y] "Y") 28 | (test-format ["~e" "hi"] "\"hi\"") 29 | (test-format ["~E" "hi"] "\"hi\"") 30 | (test-format ["~o" 9] "11") 31 | (test-format ["~O" 9] "11") 32 | (test-format ["~s" "hi"] "\"hi\"") 33 | (test-format ["~S" "hi"] "\"hi\"") 34 | (test-format ["~v" "hi"] "\"hi\"") 35 | (test-format ["~V" "hi"] "\"hi\"") 36 | (test-format ["~x" 12] "c") 37 | (test-format ["~X" 12] "c") 38 | (test-format ["hello ~ \n world"] "hello world") 39 | (test-format ["begin...~n...end"] "begin...\n...end") 40 | 41 | (parameterize ([error-print-width 4]) 42 | (test-format ["~a ~.a" "hello" "world"] "hello w...")) 43 | 44 | ;; Higher-order use: should work, but lose typechecking 45 | (check-equal? 46 | ((lambda ([f : (-> String Any String)] [x : Any]) (f "hello ~a" x)) 47 | format 'world) 48 | "hello world") 49 | 50 | (check-exn exn:fail:contract? 51 | (lambda () 52 | ((lambda ([f : (-> String Any Void)]) 53 | (f "~b" "not-a-number")) 54 | printf))) 55 | 56 | ) 57 | -------------------------------------------------------------------------------- /test/define-pass.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | (require 3 | trivial/define 4 | trivial/integer 5 | trivial/list 6 | trivial/regexp 7 | trivial/vector) 8 | 9 | (module+ test 10 | (require typed/rackunit typed/racket/class) 11 | 12 | (check-equal? 13 | (let () 14 | (define n 3) 15 | (let ([m n]) 16 | (ann (- m n) Zero))) 17 | 0) 18 | 19 | (check-equal? 20 | (let ([x (regexp "(a*)(b*)")]) 21 | (let ([m (regexp-match x "aaabbb")]) 22 | (if m (string-append (cadr m) (caddr m)) ""))) 23 | "aaabbb") 24 | 25 | (check-equal? 26 | (let ([v '#(3 9 2)]) 27 | (ann (- (vector-length v) 3) Zero)) 28 | 0) 29 | 30 | (check-equal? 31 | (let ([f (lambda ([x : String] [y : Integer]) 32 | (format "hello(~a) and ~b" x y))]) 33 | (let ([xs '("hi" "hi" "HI")] 34 | [ys '(4 3 1)]) 35 | (map f xs ys))) 36 | '("hello(hi) and 100" "hello(hi) and 11" "hello(HI) and 1")) 37 | 38 | ;; Should be okay with "Indiana-style" defines 39 | (let () 40 | (define fact : (-> Integer Integer) 41 | (lambda (n) 42 | (if (< n 2) 1 (* n (fact (- n 1)))))) 43 | (check-equal? (fact 5) 120)) 44 | 45 | ;; Also with classes 46 | (let () 47 | (define f% : (Rec t (Class (yolo (-> (Instance t))))) 48 | (class object% 49 | (super-new) 50 | (define/public (yolo) 51 | (new f%)))) 52 | (check-false (not (new f%)))) 53 | 54 | ;; let* 55 | (check-equal? 56 | (let* ([v (list 1 2 3)] 57 | [w v] 58 | [k 42]) 59 | (ann (length w) 3)) 60 | 3) 61 | 62 | ;; let with different kinds of bindings 63 | (check-equal? 64 | (let ([v (list 1 2 3)] 65 | [k 42]) 66 | (ann (length v) 3)) 67 | 3) 68 | ) 69 | -------------------------------------------------------------------------------- /test/integer-fail.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require 3 | trivial/private/test-common 4 | (only-in typed/racket/base ann lambda One Zero -> : Natural Exact-Rational)) 5 | 6 | ;; Integer arithmetic expressions that fail to typecheck 7 | 8 | (module+ test (test-compile-error 9 | #:require trivial/math 10 | #:exn #rx"quotient|/|Type Checker" 11 | (ann (let ([n 2]) (+ n -2)) Zero) 12 | (ann (let ([n 2]) (- 2 n)) Zero) 13 | (ann (let ([n 5]) (* n 1/5 1)) One) 14 | (ann (let ([n 4]) (/ n n)) One) 15 | (ann (let ([n 2]) (expt 3 (- n n))) One) 16 | (ann (expt 3 2) Zero) 17 | (ann (quotient 3 3) Zero) 18 | (ann ((lambda ([x : Natural]) (expt x 3)) 2) Index) 19 | ;; -- lambda => back to racket/base 20 | (ann ((lambda ([f : (-> Natural Natural Natural)]) (f 0 0)) +) Zero) 21 | (ann ((lambda ([f : (-> Natural Natural Integer)]) (f 0 0)) -) Zero) 22 | (ann ((lambda ([f : (-> Natural Natural Natural)]) (f 0 0)) *) Zero) 23 | (ann ((lambda ([f : (-> Natural Natural Exact-Rational)]) (f 0 0)) /) Zero) 24 | (ann ((lambda ([f : (-> Natural Natural Natural)]) (f 0 1)) expt) Zero) 25 | ;; -- dividing by zero => caught statically 26 | (/ 1 1 0) 27 | (/ 1 1 (+ 4 -2 -2)) 28 | (quotient 9 0) 29 | ;; -- redefine ops => fail 30 | (ann (let ([+ (lambda (x y) "hello")]) (+ 1 1)) Integer) 31 | (ann (let ([- (lambda (x y) "hello")]) (- 1 1)) Integer) 32 | (ann (let ([/ (lambda (x y) "hello")]) (/ 1 1)) Integer) 33 | (ann (let ([* (lambda (x y) "hello")]) (* 1 1)) Integer) 34 | (ann (let ([expt (lambda (x y) "hello")]) (expt 1 1)) Integer) 35 | (ann (* 5 1/5 1) One) ;; -- can't do rational arithmetic. It's integers only 36 | (let ([h 1]) 37 | ;; -- variables don't currently expand to their value 38 | (set! h (sub1 h)) 39 | (ann h One)) 40 | (let ([h -1]) 41 | (set! h (add1 h)) 42 | (ann (+ h 1) One)) 43 | (let ([h 1]) 44 | (set! h (sub1 h)) 45 | (ann (+ h 1) One)) 46 | )) 47 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | trivial 2 | === 3 | [![Build Status](https://travis-ci.org/bennn/trivial.svg)](https://travis-ci.org/bennn/trivial) 4 | [![Coverage Status](https://coveralls.io/repos/bennn/trivial/badge.svg?branch=master&service=github)](https://coveralls.io/github/bennn/trivial?branch=master) 5 | [![Scribble](https://img.shields.io/badge/Docs-Scribble-blue.svg)](http://docs.racket-lang.org/trivial/index.html) 6 | 7 | The `trivial` library implements _type tailoring_ for a variety of standard library operations. 8 | 9 | The tailored operations catch more errors statically and raise fewer unnecessary type errors. 10 | 11 | ``` 12 | #lang typed/racket 13 | (require trivial) 14 | 15 | (format "binary(~a) = ~b" 3.14 3.14) 16 | ;; static type error :) 17 | 18 | (let ([match-list (regexp-match #rx"(a*)(b*)" "aaab")]) 19 | (if match-list 20 | (string-length (second match-list)) 21 | 0)) 22 | ;; not a type error :) 23 | 24 | (vector-ref (make-vector 3 #true) 4) 25 | ;; static bounds error :) 26 | ``` 27 | 28 | See the documentation for more details. 29 | [http://docs.racket-lang.org/trivial/index.html](http://docs.racket-lang.org/trivial/index.html) 30 | 31 | 32 | Install 33 | --- 34 | 35 | From [the package server](https://pkgn.racket-lang.org): 36 | ``` 37 | $ raco pkg install trivial 38 | ``` 39 | 40 | From GitHub: 41 | ``` 42 | $ git clone https://github.com/bennn/trivial 43 | $ raco pkg install ./trivial 44 | ``` 45 | 46 | 47 | Project Structure 48 | --- 49 | 50 | - `trivial/main.rkt` defines the API (e.g. the result of `(require trivial)`) 51 | - `trivial/define.rkt` 52 | `trivial/format.rkt` 53 | `trivial/function.rkt` 54 | `trivial/integer.rkt` 55 | `trivial/list.rkt` 56 | `trivial/regexp.rkt` 57 | `trivial/vector.rkt` implement tailored versions of Racket forms 58 | - `trivial/tailoring.rkt` is an API for building new tailorings 59 | - `trivial/private/` main implementation 60 | - `test/` unit tests 61 | 62 | -------------------------------------------------------------------------------- /test/string-pass.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | 3 | (module+ test 4 | 5 | (require 6 | trivial/regexp 7 | trivial/string 8 | trivial/define 9 | trivial/integer 10 | typed/rackunit) 11 | 12 | (test-case "string" 13 | (check-equal? 14 | (ann (string-length "") Zero) 15 | 0) 16 | (check-equal? 17 | (ann (- (string-length "racket") 6) Zero) 18 | 0) 19 | (check-equal? 20 | (ann (string-ref "racket" 0) Char) 21 | #\r) 22 | #;(check-equal? 23 | (let ([s (string-append "r" "acket")]) 24 | (check-equal? (string-set! s 0 #\R) (void)) 25 | 0 26 | #;(ann (- (string-length s) 6) Zero)) 27 | 0) 28 | (check-equal? 29 | (ann (- (string-length (substring "racket" 5)) 1) Zero) 30 | 0) 31 | (check-equal? 32 | (ann (- (string-length (substring "racket" 0 3)) 3) Zero) 33 | 0) 34 | (check-equal? 35 | (ann (- (string-length (substring "racket" 3 6)) 3) Zero) 36 | 0) 37 | (check-equal? 38 | (ann (- (string-length (string-append "rac" "ke" "t")) 6) Zero) 39 | 0)) 40 | 41 | (test-case "bytes" 42 | (check-equal? 43 | (ann (- (bytes-length #"aaaa") 4) Zero) 44 | 0) 45 | (check-equal? 46 | (ann (bytes-ref #"racket" 2) Byte) 47 | (char->integer #\c)) 48 | #;(check-equal? 49 | (ann (- (bytes-length (bytes-set! (bytes-append #"" #"racket") 5 #\T)) 6) Zero) 50 | 0) 51 | (check-equal? 52 | (ann (- (bytes-length (subbytes #"racket" 2)) 4) Zero) 53 | 0) 54 | (check-equal? 55 | (ann (- (bytes-length (subbytes #"racket" 4 6)) 2) Zero) 56 | 0) 57 | (check-equal? 58 | (ann (- (bytes-length (bytes-append #"r" #"a" #"ck" #"et")) 6) Zero) 59 | 0)) 60 | 61 | (test-case "regexp:string" 62 | (let ([s0 "a*"] 63 | [s1 "b*"]) 64 | (check-equal? 65 | (ann 66 | (regexp-match (string-append "(" s0 ")" s1) "aaab") 67 | (U #f (List String String))) 68 | '("aaab" "aaa")))) 69 | 70 | (test-case "regexp:bytes" 71 | (let ([s0 #"a*"] 72 | [s1 #"b*"]) 73 | (check-equal? 74 | (ann 75 | (regexp-match (bytes-append #"(" s0 #")" s1) #"aaab") 76 | (U #f (List Bytes Bytes))) 77 | '(#"aaab" #"aaa")))) 78 | ) 79 | -------------------------------------------------------------------------------- /test/regexp-fail.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require 3 | trivial/private/test-common 4 | (only-in typed/racket/base 5 | ann : -> String Listof List U Bytes)) 6 | 7 | ;; Ill-typed `regexp:` expressions 8 | ;; TODO why can't I catch errors for (ann ... (List String))? WhydoI need #f? 9 | 10 | (module+ test (test-compile-error 11 | #:require trivial/regexp trivial/define 12 | #:exn #rx"Type Checker" 13 | (ann (regexp-match "hi" "hi") 14 | (U #f (List String String String))) 15 | (ann (regexp-match #rx"(h)(i)" "hi") 16 | (U #f (List String String))) 17 | (ann (regexp-match #px"(?<=h)(?=i)" "hi") 18 | (U #f (List String String String))) 19 | ;;bg; ill-typed in untyped Racket 20 | (byte-regexp #rx#"yolo") 21 | (ann (regexp-match #rx#"hi" "hi") 22 | (U #f (List String String))) 23 | (ann (regexp-match #px#"hi" "hi") 24 | (U #f (List Bytes Bytes))) 25 | ;; --- Can't handle |, yet 26 | (ann (regexp-match "this(group)|that" "that") 27 | (U #f (List String String))) 28 | ;; --- can't handle starred groups 29 | (ann (regexp-match "(a)*(b)" "b") 30 | (U #f (List String String String))) 31 | ) 32 | 33 | (test-compile-error 34 | #:require trivial/regexp racket/port trivial/define 35 | #:exn #rx"Type Checker" 36 | ;; -- expected String, given Bytes 37 | (with-input-from-string "hello" 38 | (lambda () 39 | (define m (regexp-match #rx#"lang" (current-input-port))) 40 | (and m (string=? (car m) "lang")))) 41 | 42 | ;; ---- is raising a type error, which is GOOD, but throwing during test 43 | ;; -- return type assumed to be String, but really is Bytes 44 | ;; (ugly, but at least we catch it statically) 45 | ;(with-input-from-file "test/regexp-fail.rkt" 46 | ; (lambda () 47 | ; (define m (regexp-match #rx"lang" (current-input-port))) 48 | ; (and m (string=? (car m) #"lang")))) 49 | ) 50 | 51 | ;; 2016-06-13 : these really should be errors, just no-opts 52 | ;(test-compile-error 53 | ; #:require trivial/regexp trivial/define 54 | ; #:exn #rx"mutation not allowed" 55 | ; ;; -- set! problems 56 | ; (ann (let ([a #rx"(b)(B)"]) 57 | ; (set! a #rx"") 58 | ; (regexp-match a "hai")) 59 | ; (List String String String)) 60 | ; (let () 61 | ; (define a #rx"h(i)") 62 | ; (set! a #rx"hi") 63 | ; (regexp-match a "hi")) 64 | ; 65 | ; (let ([a #rx"h(i)"]) 66 | ; (set! a #rx"(h)(i)") 67 | ; (regexp-match a "hi")) 68 | ;) 69 | ) 70 | -------------------------------------------------------------------------------- /trivial/private/db/mysql.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide 4 | mysql-parameter? 5 | ;; (-> Any (Option Natural)) 6 | ;; If input is a Postgres parameter, return the parameter number. 7 | ;; i.e $2 -> 2 8 | ;; Otherwise return #f. 9 | 10 | ;; -- also exports predicates defined with `define-sql-keyword-predicate` 11 | ) 12 | 13 | (require 14 | (for-syntax 15 | typed/racket/base 16 | racket/syntax 17 | syntax/parse)) 18 | 19 | (define-syntax (define-sql-keyword-predicate stx) 20 | (syntax-parse stx 21 | [(_ kwd*:id ...) 22 | #:with (kwd?* ...) (for/list ([kwd (in-list (syntax-e #'(kwd* ...)))]) 23 | (format-id stx "~a?" (syntax-e kwd))) 24 | (syntax/loc stx 25 | (begin (begin (provide kwd?*) (define (kwd?* v) (symbol-ci=? v 'kwd*))) ...))])) 26 | 27 | ;; ----------------------------------------------------------------------------- 28 | 29 | (define (symbol-ci=? s1 s2) 30 | (and 31 | (symbol? s1) 32 | (symbol? s2) 33 | (string-ci=? (symbol->string s1) (symbol->string s2)))) 34 | 35 | (define-sql-keyword-predicate 36 | select 37 | from 38 | where 39 | and) 40 | 41 | ;; Check for query parameters. Currently only for Postgres. 42 | (define (mysql-parameter? s) 43 | (and 44 | (or (string? s) (symbol? s)) 45 | (let ([str (if (string? s) s (symbol->string s))]) 46 | (string=? "?" str)))) 47 | 48 | (module+ test 49 | (require rackunit rackunit-abbrevs) 50 | 51 | (check-apply* symbol-ci=? 52 | ['a 'a 53 | => #t] 54 | ['a 'A 55 | => #t] 56 | ['yellow 'YeLLOW 57 | => #t] 58 | ['wait 'forME 59 | => #f] 60 | ['x 'y 61 | => #f] 62 | ["A" 'A 63 | => #f] 64 | [315 "bage" 65 | => #f] 66 | ) 67 | 68 | (check-apply* select? 69 | ['select 70 | => #t] 71 | ['SELECT 72 | => #t] 73 | ['yolo 74 | => #f] 75 | ) 76 | 77 | (check-apply* from? 78 | ['from 79 | => #t] 80 | ['FROM 81 | => #t] 82 | ['yolo 83 | => #f] 84 | ) 85 | 86 | (check-apply* where? 87 | ['where 88 | => #t] 89 | ['WHERE 90 | => #t] 91 | ['yolo 92 | => #f] 93 | ) 94 | 95 | (check-apply* and? 96 | ['and 97 | => #t] 98 | ['AND 99 | => #t] 100 | ['yolo 101 | => #f] 102 | ) 103 | 104 | (check-apply* mysql-parameter? 105 | ["$1" 106 | => #false] 107 | ['$1 108 | => #false] 109 | ["?" 110 | => #true] 111 | ['? 112 | => #true] 113 | ['wepa 114 | => #f] 115 | [3 116 | => #f] 117 | ) 118 | ) 119 | 120 | -------------------------------------------------------------------------------- /trivial/private/db/postgres.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide 4 | postgres-parameter? 5 | ;; (-> Any (Option Natural)) 6 | ;; If input is a Postgres parameter, return the parameter number. 7 | ;; i.e $2 -> 2 8 | ;; Otherwise return #f. 9 | 10 | ;; -- also exports predicates defined with `define-sql-keyword-predicate` 11 | ) 12 | 13 | (require 14 | (for-syntax 15 | typed/racket/base 16 | racket/syntax 17 | syntax/parse)) 18 | 19 | (define-syntax (define-sql-keyword-predicate stx) 20 | (syntax-parse stx 21 | [(_ kwd*:id ...) 22 | #:with (kwd?* ...) (for/list ([kwd (in-list (syntax-e #'(kwd* ...)))]) 23 | (format-id stx "~a?" (syntax-e kwd))) 24 | (syntax/loc stx 25 | (begin (begin (provide kwd?*) (define (kwd?* v) (symbol-ci=? v 'kwd*))) ...))])) 26 | 27 | ;; ----------------------------------------------------------------------------- 28 | 29 | (define (symbol-ci=? s1 s2) 30 | (and 31 | (symbol? s1) 32 | (symbol? s2) 33 | (string-ci=? (symbol->string s1) (symbol->string s2)))) 34 | 35 | (define-sql-keyword-predicate 36 | select 37 | from 38 | where 39 | and) 40 | 41 | ;; Check for query parameters. Currently only for Postgres. 42 | (define (postgres-parameter? s) 43 | (and 44 | (or (string? s) (symbol? s)) 45 | (let ([str (if (string? s) s (symbol->string s))]) 46 | (and 47 | (= 2 (string-length str)) 48 | (eq? #\$ (string-ref str 0)) 49 | (string->number (string (string-ref str 1))))))) 50 | 51 | (module+ test 52 | (require rackunit rackunit-abbrevs) 53 | 54 | (check-apply* symbol-ci=? 55 | ['a 'a 56 | => #t] 57 | ['a 'A 58 | => #t] 59 | ['yellow 'YeLLOW 60 | => #t] 61 | ['wait 'forME 62 | => #f] 63 | ['x 'y 64 | => #f] 65 | ["A" 'A 66 | => #f] 67 | [315 "bage" 68 | => #f] 69 | ) 70 | 71 | (check-apply* select? 72 | ['select 73 | => #t] 74 | ['SELECT 75 | => #t] 76 | ['yolo 77 | => #f] 78 | ) 79 | 80 | (check-apply* from? 81 | ['from 82 | => #t] 83 | ['FROM 84 | => #t] 85 | ['yolo 86 | => #f] 87 | ) 88 | 89 | (check-apply* where? 90 | ['where 91 | => #t] 92 | ['WHERE 93 | => #t] 94 | ['yolo 95 | => #f] 96 | ) 97 | 98 | (check-apply* and? 99 | ['and 100 | => #t] 101 | ['AND 102 | => #t] 103 | ['yolo 104 | => #f] 105 | ) 106 | 107 | (check-apply* postgres-parameter? 108 | ["$1" 109 | => 1] 110 | ['$1 111 | => 1] 112 | ["$125" 113 | => #f] 114 | ['$555 115 | => #f] 116 | ['wepa 117 | => #f] 118 | [3 119 | => #f] 120 | ) 121 | ) 122 | -------------------------------------------------------------------------------- /trivial/private/test-common.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide 4 | test-compile-error 5 | check-trivial-log-sequence 6 | ) 7 | 8 | (require 9 | rackunit 10 | racket/logging 11 | (only-in racket/list 12 | add-between) 13 | (only-in racket/string 14 | string-contains? 15 | string-join) 16 | (only-in trivial/private/common 17 | ttt-logger) 18 | (for-syntax 19 | racket/base 20 | syntax/parse)) 21 | 22 | ;; ============================================================================= 23 | 24 | (define-syntax (test-compile-error stx) 25 | (syntax-parse stx 26 | [(_ #:require r-s* ... 27 | #:exn exn-rx 28 | e* ...) 29 | (syntax/loc stx 30 | (begin 31 | (check-exn exn-rx 32 | (lambda () 33 | (compile-syntax #'(module t typed/racket/base (require r-s* ...) e*)))) 34 | ...))])) 35 | 36 | (define-syntax (check-trivial-log-sequence stx) 37 | (syntax-parse stx 38 | [(_ ?e ?type+sym*) 39 | (quasisyntax/loc stx 40 | (with-check-info* (list (make-check-location '#,(syntax->location stx))) 41 | (λ () 42 | (define type+sym* ?type+sym*) 43 | (define inbox (intercept-ttt-log #'?e)) 44 | (define log* (reverse (hash-ref inbox 'info))) 45 | (define len (length type+sym*)) 46 | (define num-log* (length log*)) 47 | (define fail-msg 48 | (format "too ~a log messages:~n ~s" 49 | (if (< num-log* len) "few" "many") 50 | (string-join (add-between log* " ~n ")))) 51 | (check-equal? num-log* len fail-msg) 52 | ;; (printf fail-msg) (newline) ;; --- for debugging 53 | (when (= num-log* len) 54 | (for ([log (in-list log*)] 55 | [ts (in-list type+sym*)]) 56 | (define pat (format "~a '~a'" (car ts) (cadr ts))) 57 | (check-true (string-contains? log pat) 58 | (format "pattern '~a' not in log message: ~a" pat log)))) 59 | (void))))])) 60 | 61 | (define (intercept-ttt-log stx) 62 | (define inbox (make-hasheq '((debug . ()) (info . ()) (warning . ()) (error . ()) (fatal . ())))) 63 | (with-intercepted-logging 64 | (λ (l) 65 | (define lvl (vector-ref l 0)) 66 | (define msg (vector-ref l 1)) 67 | (when (eq? 'ttt (vector-ref l 3)) ;; filters out logs from racket/contract, etc 68 | (hash-set! inbox lvl (cons msg (hash-ref inbox lvl)))) 69 | (void)) 70 | (λ () 71 | (compile-syntax stx)) 72 | #:logger ttt-logger 73 | 'info) 74 | inbox) 75 | 76 | (define-for-syntax (syntax->location stx) 77 | (list (syntax-source stx) 78 | (syntax-line stx) 79 | (syntax-column stx) 80 | (syntax-position stx) 81 | (syntax-span stx))) 82 | 83 | -------------------------------------------------------------------------------- /trivial/private/db/query.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Parsing SQL queries 4 | 5 | 6 | (provide 7 | query-parser 8 | ) 9 | 10 | (require 11 | trivial/private/common 12 | trivial/private/db/mysql 13 | (only-in racket/port with-input-from-string) 14 | (only-in racket/format ~a) 15 | (only-in racket/string string-replace) 16 | racket/match 17 | syntax/parse 18 | (for-syntax syntax/parse racket/syntax typed/racket/base) 19 | ) 20 | 21 | ;; ============================================================================= 22 | 23 | (define (quoted-stx-value? stx) 24 | (syntax-parse stx 25 | [((~datum quote) v) 26 | (syntax-e #'v)] 27 | [_ #f])) 28 | 29 | (define (query-parser stx) 30 | (define str (if (string? (syntax-e stx)) (syntax-e stx) (quoted-stx-value? stx))) 31 | (and 32 | (string? str) 33 | (match (with-input-from-string 34 | (string-append "(" (sanitize-for-read str) ")") 35 | read) 36 | [(list (? select?) sel* ... (? from?) database rest* ...) 37 | (define flat-sel* 38 | (if (and (not (null? sel*)) 39 | (list? (car sel*))) 40 | (if (null? (cdr sel*)) 41 | (car sel*) 42 | (error 'internal-error "Failed to parse query '~a'" str)) 43 | sel*)) 44 | (define condition* (condition-parser rest*)) 45 | (list flat-sel* database condition*)] 46 | [_ #f]))) 47 | 48 | (define (sanitize-for-read str) 49 | (string-replace 50 | (string-replace str "," " ") 51 | "'" "\"")) 52 | 53 | (define (condition-parser v*) 54 | (let loop ([v* v*]) 55 | (match v* 56 | ['() 57 | '()] 58 | [(list (or (? where?) (? and?)) db+row '= v rest* ...) 59 | (cons (cons (~a db+row) (~a v)) ;; ~a is a little confusing 60 | (loop rest*))] 61 | [(cons _ rest*) 62 | (loop rest*)]))) 63 | 64 | ;; (define-values (query-key query? query-def query-let) 65 | ;; (make-value-property 'db:query query-parser)) 66 | ;; (define-syntax-class/predicate query/expand query?) 67 | 68 | ;; ============================================================================= 69 | 70 | (module+ test 71 | (require rackunit rackunit-abbrevs) 72 | 73 | (check-apply* query-parser 74 | [#'"SELECT a FROM b" 75 | => '((a) b ())] 76 | [#'"select * from c" 77 | => '((*) c ())] 78 | [#'"select (a, b, c) from d" 79 | => '((a b c) d ())] 80 | [#'"select a, b from d limit 10" 81 | => '((a b) d ())] 82 | [#'"select a, b from d limit 10 where d.a = \"hello\"" 83 | => '((a b) d (("d.a" . "hello")))] 84 | [#'"select a, b from d where a = 'hi' and b = 3" 85 | => '((a b) d (("a" . "hi") ("b" . "3")))] 86 | ) 87 | 88 | (check-apply* sanitize-for-read 89 | ["hello" 90 | => "hello"] 91 | ["what, the, 'heck'" 92 | => "what the \"heck\""] 93 | ) 94 | 95 | (check-apply* condition-parser 96 | ['() 97 | => '()] 98 | ['(limit something = anotherthing) 99 | => '()] 100 | ['(limit something where a = b and y = zzz) 101 | => '(("a" . "b") ("y" . "zzz"))] 102 | ) 103 | ) 104 | -------------------------------------------------------------------------------- /trivial/private/function.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Track procedure arity 4 | 5 | ;; TODO 6 | ;; - vectorized operations 7 | ;; - improve apply? 8 | ;; - get types 9 | 10 | ;; ----------------------------------------------------------------------------- 11 | 12 | (provide 13 | (for-syntax A-dom format-arity-error) 14 | (rename-out 15 | [-curry curry] 16 | [-lambda lambda] 17 | [-lambda λ])) 18 | 19 | ;; ----------------------------------------------------------------------------- 20 | 21 | (require 22 | (prefix-in tr- (only-in typed/racket/base lambda :)) 23 | (for-syntax 24 | syntax/parse 25 | racket/syntax 26 | racket/base 27 | typed/untyped-utils 28 | trivial/private/common)) 29 | 30 | ;; ============================================================================= 31 | 32 | (begin-for-syntax 33 | (define A-dom 34 | (make-abstract-domain A 35 | [x (⊥ A-dom)])) 36 | 37 | (define (parse-identifiers arr) 38 | (map parse-identifier arr)) 39 | 40 | (define (parse-identifier stx) 41 | (syntax-parse stx #:literals (tr-:) 42 | [_:id stx] 43 | [(x tr-: _) #'x])) 44 | 45 | (define (curry-error stx msg) 46 | (raise-user-error 'curry 47 | "[~a:~a] ~a in ~a" 48 | (syntax-line stx) 49 | (syntax-column stx) 50 | msg 51 | (syntax->datum stx))) 52 | 53 | (define (format-arity-error stx [arity #f]) 54 | (format "[~a:~a] expected a function~a in ~a" 55 | (syntax-line stx) 56 | (syntax-column stx) 57 | (if arity (format " with arity ~a" arity) "") 58 | (syntax->datum stx))) 59 | 60 | ) 61 | 62 | ;; ----------------------------------------------------------------------------- 63 | 64 | (define-syntax (-lambda stx) 65 | (with-syntax ([lam (if (syntax-local-typed-context?) (syntax/loc stx tr-lambda) (syntax/loc stx lambda))]) 66 | (syntax-parse stx 67 | [(_ arg* . e*) 68 | (log-ttt-infer+ 'lambda stx) 69 | (⊢ (syntax/loc stx 70 | (lam arg* . e*)) 71 | (φ-set (φ-init) A-dom (syntax-e #'arg*)))] 72 | [(_ . e*) 73 | (log-ttt-infer- 'lambda stx) 74 | (syntax/loc stx 75 | (lam . e*))] 76 | [_:id 77 | (syntax/loc stx 78 | lam)]))) 79 | 80 | (define-syntax (-curry stx) 81 | (with-syntax ([lam (if (syntax-local-typed-context?) (syntax/loc stx tr-lambda) (syntax/loc stx lambda))]) 82 | (syntax-parse stx 83 | [(_ p:~>) 84 | (define arr (φ-ref (φ #'p.~>) A-dom)) 85 | (cond 86 | [(⊥? A-dom arr) 87 | (log-ttt-check- 'curry stx) 88 | (curry-error stx "unknown arity")] 89 | [(⊤? A-dom arr) 90 | (log-ttt-check- 'curry stx) 91 | (raise-user-error 'curry (format-arity-error stx))] 92 | [else 93 | (log-ttt-check+ 'curry stx) 94 | (with-syntax ([id+* (parse-identifiers arr)]) 95 | (for/fold ([expr (syntax/loc stx (p.~> . id+*))]) 96 | ([a (in-list (reverse arr))]) 97 | (quasisyntax/loc stx 98 | (lam (#,a) #,expr)))) ])] 99 | [_ 100 | (log-ttt-check- 'curry stx) 101 | (curry-error stx "bad syntax")]))) 102 | 103 | -------------------------------------------------------------------------------- /trivial/scribblings/trivial.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @require[ 3 | racket/include 4 | scribble/eval 5 | scriblib/footnote 6 | (for-label 7 | racket/base 8 | (only-in typed/racket/base String)) 9 | ] 10 | 11 | @(define (reftech . word*) 12 | (tech #:doc '(lib "scribblings/reference/reference.scrbl") word*)) 13 | 14 | @; ============================================================================= 15 | 16 | @title[#:tag "top"]{Trivial: type-tailored library functions} 17 | @author[@hyperlink["https://github.com/bennn"]{Ben Greenman}] 18 | 19 | @defmodule[trivial] 20 | @(define trivial-eval (make-base-eval #:lang 'typed/racket/base '(begin (require trivial)))) 21 | 22 | The @racketmodname[trivial] module exports @emph{tailored} versions of standard library functions. 23 | 24 | @section[#:tag "ttt:introduction"]{What is Tailoring?} 25 | A tailored function @racket[f+]: 26 | @itemlist[ 27 | @item{ 28 | has the same specification and behavior as some library function @racket[f] 29 | } 30 | @item{ 31 | but can catch runtime errors during @reftech{expansion} 32 | } 33 | @item{ 34 | and may typecheck a little smoother in Typed Racket. 35 | } 36 | ] 37 | 38 | @subsection{Examples of Tailoring} 39 | For example, make a new Racket module with a malformed call to @racket[format]: 40 | 41 | @codeblock{ 42 | #lang racket/base 43 | 44 | (format "batman and ~a") 45 | } 46 | 47 | This file will compile no problem (@tt{raco make file.rkt}), but will raise a runtime error (@tt{racket file.rkt}). 48 | If you add the line @racket[(require trivial)], the file no longer compiles, but instead gives a helpful error message. 49 | 50 | 51 | Here's another example. 52 | Save the following (correct) Racket module: 53 | 54 | @codeblock{ 55 | #lang racket/base 56 | 57 | (define (get-sidekick str) 58 | (cond 59 | [(regexp-match #rx"^([a-z]+) and ([a-z]+)$" str) 60 | => caddr] 61 | [else "???"])) 62 | 63 | (get-sidekick "batman and alfred") 64 | } 65 | 66 | It should compile and run, returning @racket{alfred}. Great. 67 | Now try converting it to Typed Racket: 68 | 69 | @codeblock{ 70 | #lang typed/racket/base 71 | 72 | (define (get-sidekick (str : String)) : String 73 | (cond 74 | [(regexp-match #rx"^([a-z]+) and ([a-z]+)$" str) 75 | => caddr] 76 | [else "???"])) 77 | 78 | (get-sidekick "batman and alfred") 79 | } 80 | 81 | The file doesn't compile anymore. 82 | Adding @racket[(require trivial)] to the top of the file removes the error. 83 | 84 | 85 | @subsection{Technical Description} 86 | 87 | A tailored function @racket[f+] is really a macro that examines its call site and attempts to combine knowledge about the behavior of @racket[f] with @emph{static properties} of its arguments. 88 | If all goes well, the tailoring will either (1) identify an error or (2) transform the call site into an equivalent---but more efficient or more Typed-Racket-friendly---call. 89 | Otherwise, the call to @racket[f+] behaves exactly as a call to @racket[f] would. 90 | 91 | In general, the @emph{static properties} could be the result of any static analysis. 92 | But this library is limited to properties that other macros can establish through local analysis and propagate via @reftech{syntax properties}. 93 | See @secref{ttt:api} for more details. 94 | 95 | @include-section{using-tailorings.scrbl} 96 | @include-section{defining-tailorings.scrbl} 97 | 98 | -------------------------------------------------------------------------------- /test/db-pass.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | ; 3 | ;;; To run these test: 4 | ;;; - Install postgres, start server 5 | ;;; - Create superuser 'postgres' 6 | ;;; - Create database 'travis_ci_test' 7 | ;;; Then you can `raco test ...` as usual 8 | ; 9 | ;(module+ test 10 | ; (require 11 | ; typed/rackunit 12 | ; trivial/vector 13 | ; trivial/private/db) 14 | ; 15 | ; (define-type Id Natural) 16 | ; 17 | ; ;; -- create fake database 18 | ; (define fish-sql 19 | ; (string-append 20 | ; "CREATE TABLE fish ( " 21 | ; "id serial PRIMARY KEY, " 22 | ; "name text UNIQUE NOT NULL, " 23 | ; "weight int NOT NULL);")) 24 | ; 25 | ; (define cube-sql 26 | ; (string-append 27 | ; "CREATE TABLE cube ( " 28 | ; "id serial PRIMARY KEY, " 29 | ; "length smallint NOT NULL, " 30 | ; "width integer NOT NULL, " 31 | ; "height bigint NOT NULL);")) 32 | ; 33 | ; (define-schema: schema 34 | ; '((fish ((id . Id) (name . String) (weight . Integer))) 35 | ; (cube ((id . Id) (length . Integer) (width . Integer) (height . Integer))))) 36 | ; 37 | ; (define-connection: conn (postgresql-connect: schema #:user "postgres" #:database "travis_ci_test")) 38 | ; 39 | ; (struct fish ([name : String] [weight : Integer])) 40 | ; (define-type Fish fish) 41 | ; (struct cube ([length : Integer] [width : Integer] [height : Integer])) 42 | ; (define-type Cube cube) 43 | ; 44 | ; (: insert-fish (-> Fish Void)) 45 | ; (define (insert-fish f) 46 | ; (query-exec conn "INSERT INTO fish (name, weight) VALUES ($1, $2);" 47 | ; (fish-name f) (fish-weight f))) 48 | ; 49 | ; (: insert-cube (-> Cube Void)) 50 | ; (define (insert-cube c) 51 | ; (query-exec conn "INSERT INTO cube (length, width, height) VALUES ($1, $2, $3);" 52 | ; (cube-length c) (cube-width c) (cube-height c))) 53 | ; 54 | ; (: with-transaction (-> (-> Any) Void)) 55 | ; (define (with-transaction thunk) 56 | ; (begin 57 | ; (define maybe-exn 58 | ; (with-handlers ([exn? (lambda ([e : exn]) e)]) 59 | ; (start-transaction conn) 60 | ; (thunk) 61 | ; #f)) 62 | ; (rollback-transaction conn) 63 | ; (if maybe-exn (raise maybe-exn) (void)))) 64 | ; 65 | ; (with-transaction (lambda () 66 | ; ;; --------------------------------------------------------------------------- 67 | ; ;; Insert some things 68 | ; (query-exec conn fish-sql) 69 | ; (query-exec conn cube-sql) 70 | ; 71 | ; (define f1 (fish "Swordfish" 432)) 72 | ; (define f2 (fish "Tuna" 9999)) 73 | ; (define f3 (fish "Dorado" 12)) 74 | ; (insert-fish f1) 75 | ; (insert-fish f2) 76 | ; (insert-fish f3) 77 | ; 78 | ; (define c1 (cube 1 1 1)) 79 | ; (define c2 (cube 88 88 132)) 80 | ; (define c3 (cube 1 20 300)) 81 | ; (insert-cube c1) 82 | ; (insert-cube c2) 83 | ; (insert-cube c3) 84 | ; 85 | ; ;; --------------------------------------------------------------------------- 86 | ; 87 | ; (check-equal? 88 | ; (ann (query-row: conn "SELECT * FROM fish LIMIT 1") (Vector Id String Integer)) 89 | ; (vector 1 (fish-name f1) (fish-weight f1))) 90 | ; 91 | ; (check-equal? 92 | ; (ann (query-row: conn "SELECT * FROM cube LIMIT 1") (Vector Id Integer Integer Integer)) 93 | ; (vector 1 (cube-length c1) (cube-width c1) (cube-height c1))) 94 | ; 95 | ; (check-equal? 96 | ; (ann (query-row: conn "SELECT * FROM fish WHERE fish.name = 'Tuna'") (Vector Id String Integer)) 97 | ; (vector 2 (fish-name f2) (fish-weight f2))) 98 | ; 99 | ; (check-equal? 100 | ; (ann (query-row: conn "SELECT * FROM cube WHERE cube.width = $1" 20) (Vector Id Integer Integer Integer)) 101 | ; (vector 3 (cube-length c3) (cube-width c3) (cube-height c3))) 102 | ; 103 | ; (let-vector: ([v (query-row: conn "SELECT id FROM fish WHERE fish.id = 2")]) 104 | ; (check-equal? (vector-ref: v 0) 2) 105 | ; (check-equal? 106 | ; (ann (vector-length: v) One) 107 | ; 1)) 108 | ; 109 | ; (let-vector: ([v (query-row: conn "SELECT id, weight FROM fish WHERE fish.name = 'Dorado'")]) 110 | ; (check-equal? (vector-ref: v 0) 3) 111 | ; (check-equal? (vector-ref: v 1) (fish-weight f3)) 112 | ; (check-equal? (vector-length: v) 2)) 113 | ; 114 | ;))) 115 | -------------------------------------------------------------------------------- /trivial/private/format.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Statically-checked format strings 4 | 5 | (provide 6 | (for-syntax F-dom) 7 | (rename-out 8 | [-format format] 9 | [-printf printf])) 10 | 11 | (require 12 | (prefix-in τ- (only-in typed/racket/base ann format printf Char Exact-Number)) 13 | (prefix-in λ- (only-in racket/base format printf)) 14 | trivial/private/tailoring 15 | (for-syntax 16 | syntax/parse 17 | racket/syntax 18 | racket/base 19 | typed/untyped-utils 20 | trivial/private/common)) 21 | 22 | ;; ============================================================================= 23 | 24 | (begin-for-syntax 25 | (define F-dom 26 | (make-abstract-domain F 27 | [s:str 28 | (parse-formats #'s)])) 29 | 30 | ;; By analogy to 'format-group-error' ... 31 | (define (format-format-error stx str i) 32 | (format 33 | "[~a:~a] Invalid format escape at position ~a in '~a'" 34 | (syntax-line stx) 35 | (syntax-column stx) 36 | i 37 | str)) 38 | 39 | (define (format-format-arity-error stx expect) 40 | (format 41 | "[~a:~a] format string expected ~a argument~a, given ~a" 42 | (syntax-line stx) 43 | (syntax-column stx) 44 | expect 45 | (if (equal? 1 expect) "" "s") 46 | (syntax->datum stx))) 47 | 48 | ;; Count the number of format escapes in a string. 49 | ;; Returns a list of optional types (to be spliced into the source code). 50 | ;; Example: If result is '(#f Integer), then 51 | ;; - The format string expects 2 arguments 52 | ;; - First argument has no type constraints, second must be an Integer 53 | (define (parse-formats stx) 54 | (define str (syntax-e stx)) 55 | (cond 56 | [(string? str) 57 | (define last-index (- (string-length str) 1)) 58 | (let loop ([i 0] [acc '()]) 59 | (cond 60 | [(>= i last-index) 61 | (reverse acc)] 62 | [(eq? #\~ (string-ref str i)) 63 | ;; From fprintf docs @ http://docs.racket-lang.org/reference/Writing.html 64 | (case (string-ref str (+ i 1)) 65 | [(#\% #\n #\~ #\space #\tab #\newline) 66 | ;; Need 0 arguments 67 | (loop (+ i 2) acc)] 68 | [(#\a #\A #\s #\S #\v #\V #\e #\E) 69 | ;; Need 1 argument, can be anything 70 | (loop (+ i 2) (cons #f acc))] 71 | [(#\.) 72 | ;; Need at most 1, can be anything 73 | (if (and (< (+ 1 i) last-index) 74 | (memq (string-ref str (+ i 2)) '(#\a #\A #\s #\S #\v #\V))) 75 | (loop (+ i 3) (cons #f acc)) 76 | (loop (+ i 3) acc))] 77 | [(#\c #\C) 78 | ;; Need 1 `char?` 79 | (loop (+ i 2) (cons 'τ-Char acc))] 80 | [(#\b #\B #\o #\O #\x #\X) 81 | ;; Need 1 `exact?` 82 | (loop (+ i 2) (cons 'τ-Exact-Number acc))] 83 | [else 84 | ;; Invalid format sequence 85 | (⊤ F-dom (format-format-error stx str i))])] 86 | [else 87 | (loop (+ i 1) acc)]))] 88 | [else (⊥ F-dom)])) 89 | 90 | ) 91 | 92 | ;; ----------------------------------------------------------------------------- 93 | 94 | (define-syntax (define-formatter stx) 95 | (syntax-parse stx 96 | [(_ -fmt:id) 97 | #:with λ-fmt (format-id stx "λ~a" #'-fmt) 98 | #:with τ-fmt (format-id stx "τ~a" #'-fmt) 99 | (syntax/loc stx 100 | (define-tailoring (-fmt [e1 ~> e1+ (φ1 [F-dom ↦ fmt?])] 101 | [e* ~> e+* (φ*)] (... ...)) 102 | #:with +f (τλ #'τ-fmt #'λ-fmt) 103 | (define num-given (length φ*)) 104 | (define typed-context? (syntax-local-typed-context?)) 105 | #:= (⊥? F-dom fmt?) 106 | (+f e1+ e+* (... ...)) 107 | #:+ (= num-given (length fmt?)) 108 | (+f e1+ #,@(for/list ([a (in-list (syntax-e #'(e* (... ...))))] 109 | [t (in-list fmt?)]) 110 | (if (and t typed-context?) 111 | #`(τ-ann #,a #,t) 112 | a))) 113 | #:- #t 114 | (format-format-arity-error #'(e+* (... ...)) (length fmt?)) 115 | #:φ (φ-init)))])) 116 | 117 | (define-formatter -format) 118 | (define-formatter -printf) 119 | -------------------------------------------------------------------------------- /trivial/private/db.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | 3 | (provide 4 | (for-syntax DB-dom Connection-dom) 5 | (rename-out 6 | [-sqlite3-connect sqlite3-connect] 7 | [-mysql-connect mysql-connect] 8 | [-query-row query-row]) 9 | 10 | ; start-transaction 11 | ; rollback-transaction 12 | ; query-exec 13 | ; Connection 14 | ; ;(rename-out [quasiquote DB]) ;; TODO try using struct types 15 | ; let-schema: 16 | ; define-schema: 17 | ; let-connection: 18 | ; define-connection: 19 | ; postgresql-connect: 20 | ; ;query-exec: 21 | ; ;query-maybe-row: 22 | ; ;; define schema 23 | ; ;; start connection 24 | ; ;; query-exec 25 | ) 26 | 27 | ;; ----------------------------------------------------------------------------- 28 | 29 | (require 30 | trivial/private/tailoring 31 | (for-syntax 32 | (rename-in trivial/private/sequence-domain 33 | [vector-domain V-dom] 34 | [I-dom->vector-domain I->V]) 35 | racket/base 36 | racket/syntax 37 | syntax/parse 38 | syntax/stx 39 | typed/untyped-utils 40 | trivial/private/common 41 | trivial/private/db/schema 42 | trivial/private/db/query 43 | )) 44 | 45 | (require/typed db 46 | (#:opaque Connection connection?) 47 | (mysql-connect (->* [#:user String #:database String] [] Connection)) 48 | (sqlite3-connect (->* [#:database String] [] Connection)) 49 | (query-row (-> Connection String Any * (Vectorof Any))) 50 | ) 51 | 52 | ;; ============================================================================= 53 | 54 | (define-for-syntax DB-dom 55 | (make-abstract-domain DB 56 | [s:str 57 | (query-parser #'s)])) 58 | 59 | (define-for-syntax Connection-dom 60 | (make-abstract-domain Conn 61 | [s:expr 62 | (schema-parser #'s)])) 63 | 64 | ;; (define-for-syntax query-key (gensym 'query)) 65 | ;; (define-for-syntax connection-key (gensym 'schema)) 66 | 67 | ;; ----------------------------------------------------------------------------- 68 | 69 | (define-syntax (-mysql-connect stx) 70 | (syntax-parse stx 71 | [(_ #:user user:str 72 | #:database database:str 73 | #:schema s:expr) 74 | #:with schema (schema-parser #'s) 75 | (⊢ 76 | (syntax/loc stx (mysql-connect #:user user #:database database)) 77 | (φ-set (φ-init) Connection-dom #'schema))])) 78 | 79 | (define-syntax (-sqlite3-connect stx) 80 | (syntax-parse stx 81 | [(_ #:database database:str 82 | #:schema s:expr) 83 | #:with schema (schema-parser #'s) 84 | (⊢ 85 | (syntax/loc stx (sqlite3-connect #:database database)) 86 | (φ-set (φ-init) Connection-dom #'schema))])) 87 | 88 | (define-syntax (-query-row stx) 89 | (syntax-parse stx 90 | [(_ c:~> q:~> arg* ...) 91 | (define schema-val (φ-ref (φ #'c.~>) Connection-dom)) 92 | (define query-val (φ-ref (φ #'q.~>) DB-dom)) 93 | (cond 94 | [(not (and schema-val query-val)) 95 | (syntax/loc stx 96 | (query-row c.~> q.~> arg* ...))] 97 | [else 98 | (define-values (maybe-row* table condition*) (apply values query-val)) 99 | (define tbl-schema (table-mem schema-val table)) 100 | (unless tbl-schema 101 | (raise-syntax-error 'query-row "Unknown table" (syntax->datum stx) table)) 102 | (define row* (resolve-wildcard tbl-schema maybe-row*)) 103 | (when (null? row*) 104 | (raise-syntax-error 'query-row "Empty selection" (syntax->datum stx) 'q.~>)) 105 | (define result-type* 106 | (for/list ([r (in-list row*)]) 107 | (or (row-mem tbl-schema r) 108 | (raise-syntax-error 'query-row "Unknown column" (syntax->datum stx) r)))) 109 | (define type* (condition*->type* schema-val condition* #:src stx)) 110 | ;; -- Check number of arguments 111 | (define num-expected (length type*)) 112 | (let ([num-actual (length (syntax-e #'(arg* ...)))]) 113 | (unless (= num-expected num-actual) 114 | (apply raise-arity-error 115 | 'query-row 116 | num-expected 117 | (map syntax->datum (syntax-e #'(arg* ...)))))) 118 | (define (id->type id) (format-id stx "~a" id)) 119 | (with-syntax ([(t* ...) (map id->type type*)] 120 | [vec-stx (format-id stx "Vector")] 121 | [(r-t* ...) (map id->type result-type*)]) 122 | (⊢ 123 | (syntax/loc stx 124 | (cast (query-row c.~> q.~> (ann arg* t*) ...) 125 | (vec-stx r-t* ...))) 126 | (φ-set (φ-init) V-dom (I->V num-expected)))) ])] 127 | [_ #f])) 128 | 129 | -------------------------------------------------------------------------------- /trivial/private/define.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Implement generic elaboration rules, 4 | ;; propagating prop. environments φ 5 | 6 | (provide 7 | (rename-out 8 | [-let let] 9 | [-let* let*] 10 | ;; [-error error] 11 | ;; [-if if] 12 | [-define define] 13 | [-set! set!])) 14 | 15 | ;; ----------------------------------------------------------------------------- 16 | 17 | (require 18 | (prefix-in tr- (only-in typed/racket/base define error if let)) 19 | (for-syntax 20 | trivial/private/common 21 | typed/untyped-utils 22 | racket/base 23 | racket/syntax 24 | syntax/parse 25 | syntax/id-set 26 | syntax/id-table)) 27 | 28 | ;; ============================================================================= 29 | 30 | (define-syntax (--let stx) 31 | (with-syntax ([+let (if (syntax-local-typed-context?) (syntax/loc stx tr-let) (syntax/loc stx let))]) 32 | (syntax-parse stx 33 | [(_ ([name ann ... e:~>]) . body) 34 | (define e-φ (φ (syntax-local-introduce #'e.~>))) 35 | (log-ttt-debug "(let ~a ~a)" #'name e-φ) 36 | (quasisyntax/loc stx 37 | (+let ([name ann ... e.~>]) 38 | (let-syntax ([name (make-rename-transformer (⊢ #'name '#,e-φ))]) 39 | . body)))] 40 | [(_ arg* ...) 41 | (syntax/loc stx (+let arg* ...))]))) 42 | 43 | (define-syntax (-let* stx) 44 | (syntax-case stx () 45 | [(_ ([e* ...]) . body) 46 | (syntax/loc stx 47 | (--let ([e* ...]) . body))] 48 | [(_ ([e* ...] more ...) . body) 49 | (syntax/loc stx 50 | (--let ([e* ...]) 51 | (-let* (more ...) 52 | . body)))] 53 | [(_ . e*) 54 | (syntax/loc stx 55 | (--let . e*))])) 56 | 57 | (define-syntax (-let stx) 58 | (syntax-case stx () 59 | [(_ ([e* ...]) . body) 60 | (syntax/loc stx 61 | (--let ([e* ...]) . body))] 62 | [(_ ([v ann ... b] more ...) . body) 63 | (syntax/loc stx 64 | (--let ([tmp ann ... b]) 65 | (-let* (more ...) 66 | (--let ([v ann ... tmp]) . body))))] 67 | [(_ . e*) 68 | (syntax/loc stx 69 | (--let . e*))])) 70 | 71 | (define-syntax (-define stx) 72 | (with-syntax ([+define (if (syntax-local-typed-context?) (syntax/loc stx tr-define) (syntax/loc stx define))]) 73 | (syntax-parse stx 74 | [(_ name:id ann* ... e) 75 | #:with e~ 76 | ;; TODO 2016-10-30: 77 | ;; - debug/fix 'class misuse of method (not in application) 78 | ;; - plot-area.rkt 79 | ;; - mines.rkt 80 | ;; (both these are 'benchmark/' programs) 81 | (parameterize ([*STOP-LIST* (list* (format-id stx "class") 82 | (format-id stx "class*") 83 | (format-id stx "#%app") 84 | (syntax/loc stx name) 85 | (*STOP-LIST*))]) 86 | (syntax-parse #'e [e:~> #'e.~>])) 87 | (define e-φ (φ #'e~)) 88 | (log-ttt-debug "(define ~a ~a)" #'name e-φ) 89 | (quasisyntax/loc stx 90 | (begin 91 | (+define name ann* ... e~) 92 | (define-syntaxes () 93 | (begin 94 | (free-id-table-set! φ-tbl #'name '#,e-φ) 95 | (values)))))] 96 | [(_ . e*) 97 | (syntax/loc stx 98 | (+define . e*))]))) 99 | 100 | (define-syntax (-set! stx) 101 | (syntax-parse stx 102 | [(_ name:id e:~>) 103 | (log-ttt-warning "the library is unsound for set!, check that ~a has not been used for unsafe optimization, in: ~a" (syntax-e #'name) (syntax->datum stx)) 104 | (define e-φ (φ #'e.~>)) 105 | (free-id-set-add! φ-mutated #'name) 106 | (syntax/loc stx (set! name e.~>))] 107 | [(_ . e*) 108 | (syntax/loc stx (set! . e*))] 109 | [_:id (syntax/loc stx set!)])) 110 | 111 | ;; (define-syntax (-if stx) 112 | ;; (with-syntax ([+if (if (syntax-local-typed-context?) (syntax/loc stx tr-if) (syntax/loc stx if))]) 113 | ;; (syntax-parse stx 114 | ;; [(_ tst thn:~> els:~>) 115 | ;; #:with thn+ #'thn.~> 116 | ;; #:with els+ #'els.~> 117 | ;; (⊢ (quasisyntax/loc stx 118 | ;; (+if tst thn+ els+)) 119 | ;; (φ-join (φ #'thn+) (φ #'els+)))]))) 120 | ;; 121 | ;; (define-syntax (-error stx) 122 | ;; (with-syntax ([+error (if (syntax-local-typed-context?) (syntax/loc stx tr-error) (syntax/loc stx error))]) 123 | ;; (syntax-parse stx 124 | ;; [(_ args ...) 125 | ;; (⊢ (quasisyntax/loc stx 126 | ;; (+error args ...)) 127 | ;; (φ-init))]))) 128 | 129 | -------------------------------------------------------------------------------- /test/list-pass.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | 3 | (module+ test 4 | (require 5 | trivial 6 | typed/rackunit) 7 | 8 | (test-case "cons" 9 | (check-equal? 10 | (ann (cons 1 '(2)) (List Natural Natural)) 11 | '(1 2)) 12 | (check-equal? 13 | (ann (- (length (cons 1 (cons 2 (cons 3 '())))) 3) Zero) 14 | 0)) 15 | 16 | (test-case "car" 17 | (define (id-list (x : (Listof Symbol))) : (Listof Symbol) x) 18 | (check-equal? (car '(a b)) 'a) 19 | (check-equal? (car (id-list '(a b))) 'a)) 20 | 21 | (test-case "cdr" 22 | (define (id-list (x : (Listof Symbol))) : (Listof Symbol) x) 23 | (check-equal? (cdr '(1 2)) '(2)) 24 | (check-equal? (cdr (id-list '(a b))) '(b)) 25 | ) 26 | 27 | (test-case "length" 28 | (check-equal? 29 | (length '()) 0) 30 | (check-equal? 31 | (length (list 1 2 2)) 3) 32 | (check-equal? 33 | (ann (- (length (list 5 5 5 5 5)) 4) 34 | One) 35 | 1) 36 | (let ([v1 (list 2 3 4)] 37 | [v2 (list 4 3 2)]) 38 | (check-equal? 39 | (ann (+ 1 (- (* 5 (length v1)) (+ (* 4 3) (length v2)))) 40 | One) 41 | 1)) 42 | (let () 43 | (define v1 (list 2 3 4)) 44 | (define v2 (list 4 3 2)) 45 | (check-equal? 46 | (ann (* 5 (- (length v1) (* 1 1 (length v2) 1))) 47 | Zero) 48 | 0))) 49 | 50 | (test-case "list-ref" 51 | (check-equal? (list-ref (list 1) 0) 1) 52 | 53 | (let ([v (list 2)]) 54 | (check-equal? (list-ref v 0) 2)) 55 | 56 | (let () 57 | (define v (list "a" "bee" "sea")) 58 | (check-equal? (list-ref v 2) "sea")) 59 | 60 | (check-equal? 61 | ((lambda (v) (list-ref v 3)) (list 8 2 19 3 0)) 62 | 3) 63 | 64 | (check-exn exn:fail:contract? 65 | (lambda () 66 | ((lambda ([f : (-> (Listof Any) Natural Any)]) 67 | (f (list 0 1 2) 10)) list-ref))) 68 | 69 | (check-equal? 70 | (ann (list-ref (list-ref '((A)) 0) 0) 'A) 71 | 'A) 72 | 73 | (let ([v1 (list 'X)]) 74 | (let ([v2 (list v1)]) 75 | (check-equal? (list-ref (list-ref v2 0) 0) 'X)))) 76 | 77 | (test-case "map" 78 | (check-equal? (map add1 (list 1)) (list 2)) 79 | 80 | (check-equal? 81 | (let ([v (list (list 1) (list 2 2) 82 | (list 3 3 3) (list 4 4 4 4))]) 83 | (map (lambda ([x : (Listof Any)]) (length x)) v)) ;; dammit map 84 | (list 1 2 3 4)) 85 | 86 | (check-equal? 87 | (map add1 (map add1 (map add1 (list 0 0 0)))) 88 | (list 3 3 3)) 89 | 90 | (check-equal? 91 | ((lambda ([v : (Listof (Listof Any))]) 92 | (map (lambda ([x : (Listof Any)]) (length x)) v)) 93 | (list (list 1) (list 2 2) (list 3 3 3) (list 4 4 4 4))) 94 | (list 1 2 3 4)) 95 | 96 | (let ([v* (make-list 200 #f)]) 97 | (check-true (for/and ([v (in-list (map not v*))]) v))) 98 | 99 | (check-equal? 100 | ((lambda ([f : (-> (-> Symbol String) (Listof Symbol) (Listof String))]) 101 | (f symbol->string '(x yy z))) 102 | map) 103 | (list "x" "yy" "z")) 104 | 105 | (check-exn exn:fail:contract? 106 | (lambda () 107 | ((lambda ([f : (-> (-> Integer Integer) (Listof Integer) (Listof Integer))]) 108 | (list-ref (f add1 (list 0 0)) 3)) 109 | map))) 110 | 111 | (check-equal? 112 | (map (lambda ([x : Natural]) (add1 x)) '(8 2 1 3)) 113 | '(9 3 2 4)) 114 | 115 | (check-equal? 116 | (map (λ ([x : String] [y : String]) 117 | (string-append x y)) 118 | '("hello") 119 | '("world")) 120 | '("helloworld")) 121 | 122 | (check-equal? 123 | (map (λ ([x : String] [y : String]) 124 | (format "~a ~a" x y)) 125 | '("hello") 126 | '("world")) 127 | '("hello world")) 128 | 129 | (check-equal? 130 | (map (lambda ([x : Integer] [y : Integer] [z : Integer]) 131 | (+ (* x y) z)) 132 | '(1 2 3) 133 | '(4 5 6) 134 | '(8 9 10)) 135 | '(12 19 28))) 136 | 137 | (test-case "append" 138 | (let ([v (list 0 0 8)] 139 | [v2 (list 1 2)]) 140 | (check-equal? 141 | (list-ref (append v2 v) 4) 142 | 8))) 143 | 144 | (test-case "reverse" 145 | (let ([v (list 0 0 8)] 146 | [v2 (list 1 2)]) 147 | (let ([v+ (reverse (append v2 v))]) 148 | (check-equal? (car v+) 8) 149 | (check-equal? (ann (- (length v+) 5) Zero) 0)))) 150 | 151 | (test-case "sort" 152 | (let ([v (list 3 1 2)]) 153 | (let ([v+ (sort v <)]) 154 | (check-equal? (ann (- (length v+) 2) One) 1)))) 155 | 156 | ) 157 | -------------------------------------------------------------------------------- /trivial/private/integer.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Integer arithmetic + contant propagation 4 | 5 | (provide 6 | (for-syntax I-dom) 7 | (rename-out 8 | [-+ +] 9 | [-- -] 10 | [-* *] 11 | [-/ /] 12 | [-add1 add1] 13 | [-sub1 sub1] 14 | [-expt expt] 15 | [-quotient quotient]) 16 | ) 17 | 18 | ;; ----------------------------------------------------------------------------- 19 | 20 | (require 21 | syntax/parse 22 | trivial/private/tailoring 23 | (prefix-in τ- (only-in typed/racket/base * add1 sub1 expt quotient)) 24 | (prefix-in λ- (only-in racket/base * add1 sub1 expt quotient)) 25 | (for-syntax 26 | syntax/parse 27 | racket/syntax 28 | racket/base 29 | trivial/private/common)) 30 | 31 | ;; ============================================================================= 32 | 33 | (define-for-syntax I-dom 34 | (make-abstract-domain I #:leq <= 35 | [i:integer 36 | (syntax-e #'i)])) 37 | 38 | (define-for-syntax (division-by-zero stx) 39 | (raise-syntax-error '/ "division by zero" stx)) 40 | 41 | ;; Simplify a list of expressions using an associative binary operator. 42 | ;; Return either: 43 | ;; - A numeric value 44 | ;; - A list of syntax objects, to be spliced back in the source code 45 | (define-for-syntax (reduce/op op stx) 46 | (define expr* (syntax-e stx)) 47 | (cond 48 | [(list? expr*) 49 | (let loop ([prev #f] ;; (U #f Number), candidate for reduction 50 | [acc '()] ;; (Listof Syntax), irreducible arguments 51 | [e* expr*]) ;; (Listof Syntax), arguments to process 52 | (if (null? e*) 53 | ;; then: finished, return a number (prev) or list of expressions (acc) 54 | (if (null? acc) 55 | prev 56 | (reverse (if prev (cons prev acc) acc))) 57 | ;; else: pop the next argument from e*, fold if it's a constant 58 | (syntax-parse (car e*) 59 | [e+:~> 60 | (define v (φ-ref (φ #'e+.~>) I-dom)) 61 | (if (integer? v) 62 | ;; then: reduce the number 63 | (if prev 64 | ;; Watch for division-by-zero 65 | (if (and (zero? v) (eq? / op)) 66 | (division-by-zero stx) 67 | (loop (op prev v) acc (cdr e*))) 68 | (loop v acc (cdr e*))) 69 | ;; else: save value in acc 70 | (let ([acc+ (cons #'e+.~> (if prev (cons prev acc) acc))]) 71 | (loop #f acc+ (cdr e*))))])))] 72 | [else #f])) 73 | 74 | (define-syntax make-numeric-operator 75 | (syntax-parser 76 | [(_ f:id) 77 | #:with -f (format-id #'f "-~a" (syntax-e #'f)) 78 | #'(define-syntax (-f stx) 79 | (syntax-parse stx 80 | [(_ e* (... ...)) 81 | #:with f-id (format-id stx "~a" 'f) 82 | (let ([e+ (reduce/op f #'(e* (... ...)))]) 83 | (cond 84 | [(list? e+) 85 | (log-ttt-check- 'f stx) 86 | (quasisyntax/loc stx (#%app f-id #,@e+))] 87 | [else 88 | (log-ttt-check+ 'f stx) 89 | (⊢ (quasisyntax/loc stx #,e+) 90 | (φ-set (φ-init) I-dom e+))]))] 91 | [_:id #'f]))])) 92 | 93 | (make-numeric-operator +) 94 | (make-numeric-operator -) 95 | (make-numeric-operator *) 96 | (make-numeric-operator /) 97 | 98 | (define-tailoring (-add1 [e ~> e+ (φ [I-dom ↦ i])]) 99 | #:with +add1 (τλ #'τ-add1 #'λ-add1) 100 | #:= (⊥? I-dom i) 101 | (+add1 e+) 102 | #:+ #t 103 | '#,(+ i 1) 104 | #:φ (φ-set (φ-init) I-dom (reduce I-dom + i 1))) 105 | 106 | (define-tailoring (-sub1 [e ~> e+ (φ [I-dom ↦ i])]) 107 | #:with +sub1 (τλ #'τ-sub1 #'λ-sub1) 108 | #:= (⊥? I-dom i) 109 | (+sub1 e+) 110 | #:+ #t 111 | '#,(- i 1) 112 | #:φ (φ-set (φ-init) I-dom (reduce I-dom - i 1))) 113 | 114 | (define-tailoring (-expt [e1 ~> e1+ (φ1 [I-dom ↦ i1])] 115 | [e2 ~> e2+ (φ2 [I-dom ↦ i2])]) 116 | #:with +expt (τλ #'τ-expt #'λ-expt) 117 | #:with +* (τλ #'τ-* #'λ-*) 118 | (define new-i 119 | (let ([i1-⊥? (⊥? I-dom i1)] 120 | [i2-⊥? (⊥? I-dom i2)]) 121 | (cond 122 | [(and (not i1-⊥?) (zero? i1)) 123 | 0] 124 | [(and (not i2-⊥?) (zero? i2)) 125 | 1] 126 | [(and (not i1-⊥?) (not i2-⊥?)) 127 | (expt i1 i2)] 128 | [else 129 | (⊥ I-dom)]))) 130 | (define success? 131 | (or (not (⊥? I-dom new-i)) 132 | (and (not (⊥? I-dom i2)) (ok-to-unfold? i2)))) 133 | #:= (not success?) 134 | (+expt e1+ e2+) 135 | #:+ #t 136 | #,(if (⊥? I-dom new-i) 137 | #`(+* #,@(for/list ([_i (in-range i2)]) #'e1+)) 138 | new-i) 139 | #:φ (φ-set (φ-init) I-dom new-i)) 140 | 141 | (define-tailoring (-quotient [e1 ~> e1+ (φ1 [I-dom i1])] 142 | [e2 ~> e2+ (φ2 [I-dom i2])]) 143 | #:with +quotient (τλ #'τ-quotient #'λ-quotient) 144 | #:= (or (⊥? I-dom i1) (⊥? I-dom i2)) 145 | (+quotient e1+ e2+) 146 | #:+ #t 147 | '#,(quotient i1 i2) 148 | #:φ (φ-set (φ-init) I-dom (reduce I-dom quotient i1 i2))) 149 | 150 | -------------------------------------------------------------------------------- /test/integer-pass.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | 3 | ;; Well-typed math 4 | 5 | (module+ test 6 | (require 7 | trivial/integer 8 | trivial/define 9 | typed/rackunit 10 | ) 11 | 12 | (test-case "+-basic" 13 | (check-equal? (ann (+ 0 0) Zero) 0) 14 | (check-equal? (ann (+ 1 0) One) 1) 15 | (check-equal? (ann (+ 0 1) One) 1) 16 | (check-equal? (ann (+ 3 2) 5) 5) 17 | (check-equal? (ann (+ 3 1 1) Natural) 5) 18 | 19 | (check-equal? 20 | (ann ((lambda ([f : (-> Integer Integer Integer)]) (f 0 0)) +) Integer) 21 | 0) 22 | 23 | (check-equal? 24 | (let ([n (+ 0 -4)] [m (+ 0 5)]) 25 | (ann (+ m n -1) Zero)) 26 | 0)) 27 | 28 | (test-case "+-let" 29 | ;; does it works with self-quoting datum? 30 | (check-equal? 31 | (let ([n -4] [m 5]) 32 | (ann (+ m n -1) Zero)) 33 | 0)) 34 | 35 | (test-case "+-define" 36 | (check-equal? 37 | (let () 38 | (define n 6) 39 | (define m -8) 40 | (ann (+ n 2 m) Zero)) 41 | 0)) 42 | 43 | (test-case "-" 44 | (check-equal? (ann (- 0 0) Zero) 0) 45 | (check-equal? (ann (- 1 1) Zero) 0) 46 | (check-equal? (ann (- 2 2) Zero) 0) 47 | (check-equal? (ann (- 99 97 2) Zero) 0) 48 | (check-equal? (ann (- 8 1 3 16) -12) -12) 49 | 50 | (check-equal? 51 | (ann ((lambda ([f : (-> Integer Integer Integer)]) (f 0 0)) -) Integer) 52 | 0) 53 | 54 | (check-equal? 55 | (let ([n 4] [m 5]) 56 | (ann (- m n 1) Zero)) 57 | 0) 58 | 59 | (check-equal? 60 | (let () 61 | (define n 6) 62 | (define m -8) 63 | (ann (- n m 14) Zero)) 64 | 0)) 65 | 66 | (test-case "*" 67 | (check-equal? (ann (* 0 1315) Zero) 0) 68 | (check-equal? (ann (* 11 0) Zero) 0) 69 | (check-equal? (ann (* 3 1 3) 9) 9) 70 | (check-equal? (ann (* -1 8 4) Negative-Integer) -32) 71 | 72 | (check-equal? 73 | (ann ((lambda ([f : (-> Integer Integer Integer)]) (f 0 0)) *) Integer) 74 | 0) 75 | 76 | (check-equal? 77 | (let ([n 4] [m 5]) 78 | (ann (- (* m n) 20) Zero)) 79 | 0) 80 | 81 | (check-equal? 82 | (let () 83 | (define n 2) 84 | (define m -8) 85 | (ann (- (* n -2 m) 32) Zero)) 86 | 0)) 87 | 88 | (test-case "/" 89 | (check-equal? (ann (/ 0 1) Zero) 0) 90 | (check-equal? (ann (/ 0 42) Zero) 0) 91 | (check-equal? (ann (/ 0 1 2 3 4) Zero) 0) 92 | (check-equal? (ann (/ 9 9) One) 1) 93 | 94 | (check-equal? 95 | (ann ((lambda ([f : (-> Integer Integer Exact-Rational)]) (f 1 1)) /) Real) 96 | 1) 97 | 98 | (check-equal? 99 | (let ([n 4] [m 12]) 100 | (ann (- (/ m n) 3) Zero)) 101 | 0) 102 | 103 | (check-equal? 104 | (let () 105 | (define n 2) 106 | (define m -8) 107 | (ann (+ (/ m n) 4) Zero)) 108 | 0)) 109 | 110 | (test-case "nested-arithmetic" 111 | (check-equal? 112 | (ann (+ (+ 1 1) (+ 1 1 1) 1) Index) 113 | 6) 114 | (check-equal? 115 | (ann (* (+ 9 1) (- 6 3 2 1) 1) Zero) 116 | 0) 117 | (check-equal? 118 | (ann (/ (+ 1 2 3 4) (+ (- 3 2) (+ 1))) Natural) 119 | 5)) 120 | 121 | (test-case "let-bound-vars" 122 | (let ([n 0]) 123 | (check-equal? (ann (+ n 1 2 3 4) Natural) 10) 124 | (check-equal? (ann (- n n) Integer) 0) 125 | (check-equal? (ann (* n 8 1 4 13 1) Natural) 0) 126 | (check-equal? (ann (/ n 1) Exact-Rational) 0)) 127 | 128 | (check-equal? (ann (let ([n 2]) (+ n -2)) Integer) 0) 129 | (check-equal? (ann (let ([n 5]) (* n 1/5 1)) Exact-Rational) 1) 130 | (check-equal? (ann (let ([n 5]) (* 3 n (+ -1 2))) Natural) 15) 131 | (check-equal? (ann (let ([n 4]) (/ n n)) Positive-Exact-Rational) 1)) 132 | 133 | (test-case "add1/sub1" 134 | (let ([h -1]) 135 | (check-equal? (ann (+ (add1 h) 1) One) 1)) 136 | 137 | (let ([h 1]) 138 | (check-equal? (ann (+ (sub1 h) 1) One) 1))) 139 | 140 | (test-case "expt" 141 | (check-equal? 142 | (ann (expt 5 3) Index) 143 | 125) 144 | (check-equal? 145 | (ann (expt 99 0) One) 146 | 1) 147 | (check-equal? 148 | (ann (expt (+ 5 -5) 78) Zero) 149 | 0) 150 | (check-equal? 151 | (ann (- (expt (* 2 2) (expt 2 2)) 256) Zero) 152 | 0) 153 | (check-equal? 154 | (ann (expt (* 2 2) (expt 2 2)) Natural) ;; Not an index 155 | 256) 156 | (check-equal? 157 | (let ([n1 5] [n2 4]) 158 | (ann (- (expt n1 n2) 625) Zero)) 159 | 0) 160 | (check-equal? 161 | (let () 162 | (define n1 8) 163 | (define n2 2) 164 | (ann (- (expt n1 n2) 64) Zero)) 165 | 0) 166 | (check-true 167 | (and (ann (lambda ([n : Natural]) (expt n 0)) (-> Natural One)) #t)) 168 | (check-true 169 | (and (ann (lambda ([n : Index]) (expt n 1)) (-> Index Index)) #t))) 170 | 171 | (test-case "quotient" 172 | (check-equal? 173 | (ann (quotient 9 9) One) 174 | 1) 175 | (check-equal? 176 | (ann (quotient (+ 99 99) (+ 32 1)) Index) 177 | 6)) 178 | 179 | ) 180 | -------------------------------------------------------------------------------- /test/logging.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module+ test 4 | (require rackunit trivial trivial/private/test-common) 5 | 6 | (test-case "format" 7 | (check-trivial-log-sequence 8 | (begin (format "yo ~a lo ~a~n" 1 'two) 9 | (printf "wepa") 10 | ((lambda (x) (format x "hi")) "~s bye")) 11 | '((CHECK+ format) 12 | (CHECK+ printf) 13 | (INFER+ lambda) 14 | (CHECK- format)))) 15 | 16 | (test-case "function" 17 | (check-trivial-log-sequence 18 | (begin (lambda (x) x) 19 | (curry (lambda (x y) x)) 20 | (((curry (lambda (x y) x)) 'A) 'B)) 21 | '((INFER+ lambda) 22 | (INFER+ lambda) 23 | (CHECK+ curry) 24 | (INFER+ lambda) 25 | (CHECK+ curry)))) 26 | 27 | (test-case "integer" 28 | (check-trivial-log-sequence 29 | (begin (+ 9 9) 30 | (- 9 9) 31 | (* 9 9) 32 | (/ 9 9) 33 | (expt 9 9) 34 | (expt (current-seconds) 9) 35 | (quotient 9 9)) 36 | '((CHECK+ +) 37 | (CHECK+ -) 38 | (CHECK+ *) 39 | (CHECK+ /) 40 | (CHECK+ expt) 41 | (CHECK+ expt) 42 | (CHECK+ quotient))) 43 | 44 | (check-trivial-log-sequence 45 | (begin (+ (current-seconds) 9) 46 | (- (current-seconds) 9) 47 | (* (current-seconds) 9) 48 | (/ (current-seconds) 9) 49 | (expt 9 (current-seconds)) 50 | (quotient (current-seconds) 9)) 51 | '((CHECK- +) 52 | (CHECK- -) 53 | (CHECK- *) 54 | (CHECK- /) 55 | (CHECK- expt) 56 | (CHECK- quotient)))) 57 | 58 | (test-case "regexp" 59 | (check-trivial-log-sequence 60 | (begin (regexp "()") 61 | (pregexp "()") 62 | (byte-regexp "()") 63 | (byte-pregexp "()")) 64 | '((CHECK+ regexp) 65 | (CHECK+ pregexp) 66 | (CHECK+ byte-regexp) 67 | (CHECK+ byte-pregexp))) 68 | 69 | (check-trivial-log-sequence 70 | (begin (regexp-match "()" "yo") 71 | (regexp-match (symbol->string 'abc) "yo")) 72 | '((CHECK+ regexp-match) 73 | (CHECK+ list) 74 | (CHECK- regexp-match)))) 75 | 76 | (test-case "vector" 77 | 78 | (check-trivial-log-sequence 79 | (begin (vector 0) 80 | (build-vector 0 (λ (x) x)) 81 | (make-vector 0)) 82 | '((CHECK+ vector) 83 | (INFER+ lambda) 84 | (CHECK+ build-vector) 85 | (CHECK+ make-vector1))) 86 | 87 | (check-trivial-log-sequence 88 | (begin (vector-length (vector 1 2 3)) 89 | (vector-length (current-command-line-arguments))) 90 | '((CHECK+ vector) 91 | (CHECK+ vector-length) 92 | (CHECK- vector-length))) 93 | 94 | (check-trivial-log-sequence 95 | (begin (vector-ref (vector 1 2 3) 0) 96 | (vector-ref (current-command-line-arguments) 0)) 97 | '((CHECK+ vector) 98 | (CHECK+ vector-ref) 99 | (CHECK- vector-ref))) 100 | 101 | (check-trivial-log-sequence 102 | (begin (vector-set! (vector 0) 0 1) 103 | (vector-set! (current-command-line-arguments) 0 0)) 104 | '((CHECK+ vector) 105 | (CHECK+ vector-set!) 106 | (CHECK- vector-set!))) 107 | 108 | (check-trivial-log-sequence 109 | (begin (vector-map values (vector 1 2 3)) 110 | (vector-map values (current-command-line-arguments))) 111 | '((CHECK+ vector) 112 | (CHECK+ vector-map) 113 | (CHECK- vector-map))) 114 | 115 | (check-trivial-log-sequence 116 | (begin (vector-map! values (vector 1 2 3)) 117 | (vector-map! values (current-command-line-arguments))) 118 | '((CHECK+ vector) 119 | (CHECK+ vector-map!) 120 | (CHECK- vector-map!))) 121 | 122 | (check-trivial-log-sequence 123 | (begin (vector-append #(0) #(1)) 124 | (vector-append (current-command-line-arguments) #(1))) 125 | '((CHECK+ vector-append) 126 | (CHECK- vector-append))) 127 | 128 | (check-trivial-log-sequence 129 | (begin (vector->list #(0 0)) 130 | (vector->list (current-command-line-arguments))) 131 | '((CHECK+ vector->list) 132 | (CHECK- vector->list))) 133 | 134 | (check-trivial-log-sequence 135 | (begin (vector->immutable-vector #(1 2 3)) 136 | (vector->immutable-vector (current-command-line-arguments))) 137 | '((CHECK+ vector->immutable-vector) 138 | (CHECK- vector->immutable-vector))) 139 | 140 | (check-trivial-log-sequence 141 | (begin (vector-fill! #(1 2 3) 0) 142 | (vector-fill! (current-command-line-arguments) 0)) 143 | '((CHECK+ vector-fill!) 144 | (CHECK- vector-fill!))) 145 | 146 | (check-trivial-log-sequence 147 | (begin (vector-take #(3) 1) 148 | (vector-take (current-command-line-arguments) 0)) 149 | '((CHECK+ vector-take) 150 | (CHECK- vector-take))) 151 | 152 | (check-trivial-log-sequence 153 | (begin (vector-take-right #(9 3) 1) 154 | (vector-take-right (current-command-line-arguments) 0)) 155 | '((CHECK+ vector-take-right) 156 | (CHECK- vector-take-right))) 157 | 158 | (check-trivial-log-sequence 159 | (begin (vector-drop #(3) 1) 160 | (vector-drop (current-command-line-arguments) 0)) 161 | '((CHECK+ vector-drop) 162 | (CHECK- vector-drop))) 163 | 164 | (check-trivial-log-sequence 165 | (begin (vector-drop-right #(3) 1) 166 | (vector-drop-right (current-command-line-arguments) 0)) 167 | '((CHECK+ vector-drop-right) 168 | (CHECK- vector-drop-right)))) 169 | 170 | ) 171 | -------------------------------------------------------------------------------- /trivial/private/tailoring.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide 4 | define-tailoring 5 | ;tailored-out 6 | (for-syntax 7 | typed/untyped-id 8 | (rename-out 9 | [typed/untyped-id τλ])) 10 | ) 11 | 12 | (require 13 | (for-syntax 14 | racket/pretty 15 | racket/base 16 | racket/syntax 17 | syntax/parse 18 | typed/untyped-utils 19 | ;racket/provide-transform 20 | trivial/private/common)) 21 | 22 | ;; ============================================================================= 23 | 24 | (begin-for-syntax 25 | (define-syntax-rule (typed/untyped-id t u) 26 | (if (syntax-local-typed-context?) t u)) 27 | 28 | (define-syntax-class elab-> 29 | (pattern (~datum ~>)) 30 | (pattern (~datum ⇝))) 31 | 32 | (define-syntax-class map-> 33 | (pattern (~datum ->)) 34 | (pattern (~datum ↦))) 35 | 36 | ;; TODO ignore keywords 37 | (define-splicing-syntax-class elaboration 38 | (pattern (e0:id _:elab-> e0+:id (φ0:id [k*:id (~optional _:map->) v*:id] ...)) 39 | #:with (e ...) #'((~var e0 ~>)) 40 | #:with (e+ ...) #`(#:with e0+ #'#,(format-id #'e0 "~a.~~>" (syntax-e #'e0))) 41 | #:with (φ ...) #'((define φ0 (φ #'e0+)) 42 | (define v* 43 | (let ([v (φ-ref φ0 k*)]) 44 | (if (⊤? k* v) (raise-user-error '~> (⊤-msg v)) v))) 45 | ...) 46 | ) 47 | (pattern (~seq (e*:id _:elab-> e+*:id (φ*:id [k**:id (~optional _:map->) v**:id] ...)) (~datum ...)) 48 | #:with e... (format-id #'e* "...") 49 | #:with (e ...) #'((~var e* ~>) e...) 50 | #:with (e+ ...) #`(#:with (e+* e...) 51 | #'(#,(format-id #'e* "~a.~~>" (syntax-e #'e*)) e...)) 52 | #:with (φ ...) #'((define φ* 53 | (map φ (syntax-e #'(e+* e...)))) 54 | (define-values (v** ...) 55 | (values (for/list ([φi (in-list φ*)]) 56 | (let ([v (φ-ref φi k**)]) 57 | (if (⊤? k** v) (raise-user-error '~> (⊤-msg v)) v))) 58 | ...)))) 59 | ) 60 | 61 | (define-splicing-syntax-class guard 62 | (pattern (~seq #:with e1 e2) 63 | #:with (g ...) #'(#:with e1 e2)) 64 | (pattern (~seq #:when e) 65 | #:with (g ...) #'(#:when e)) 66 | (pattern (~seq #:fail-unless e1 e2) 67 | #:with (g ...) #'(#:fail-unless e1 e2))) 68 | 69 | (define-syntax-class definition 70 | (pattern ((~literal define) . e*) 71 | #:with d #'(define . e*))) 72 | 73 | ) 74 | 75 | (define-syntax (define-tailoring stx) 76 | (syntax-parse stx 77 | [(_ (tailored-id:id pat*:elaboration ...) 78 | grd*:guard ... 79 | dfn*:definition ... 80 | (~optional (~seq #:= g= e=) 81 | #:defaults ([g= #'#f] [e= #'#f])) 82 | (~optional (~seq #:+ g+ e+) 83 | #:defaults ([g+ #'#f] [e+ #'#f])) 84 | (~optional (~seq #:- g- e-) 85 | #:defaults ([g- #'#t] [e- #'(error 'tailored-id "cond failure")])) 86 | #:φ prop-expr) 87 | #:with error-id (string->symbol (substring (symbol->string (syntax-e #'tailored-id)) 1)) 88 | #:with τ-tailored-id (format-id stx "τ~a" (syntax-e #'tailored-id)) 89 | #:with λ-tailored-id (format-id stx "λ~a" (syntax-e #'tailored-id)) 90 | #:with τλ-tailored-id (format-id stx "τλ~a" (syntax-e #'tailored-id)) 91 | (syntax/loc stx 92 | (define-syntax (tailored-id new-stx) 93 | (syntax-parse new-stx 94 | [(_ pat*.e ... ...) 95 | grd*.g ... ... 96 | pat*.e+ ... ... 97 | pat*.φ ... ... 98 | dfn*.d ... 99 | (⊢ (cond 100 | [g= (log-ttt-check- 'error-id new-stx) (quasisyntax/loc new-stx e=)] 101 | [g+ (log-ttt-check+ 'error-id new-stx) (quasisyntax/loc new-stx e+)] 102 | [g- (raise-user-error 'error-id e-)]) 103 | prop-expr)] 104 | [(_ . e*) 105 | #:with τλ-tailored-id (if (syntax-local-typed-context?) 106 | (syntax/loc new-stx τ-tailored-id) 107 | (syntax/loc new-stx λ-tailored-id)) 108 | (syntax/loc new-stx 109 | (τλ-tailored-id . e*))] 110 | [_:id 111 | #:with τλ-tailored-id (if (syntax-local-typed-context?) 112 | (syntax/loc new-stx τ-tailored-id) 113 | (syntax/loc new-stx λ-tailored-id)) 114 | (syntax/loc new-stx 115 | τλ-tailored-id)]))) ] 116 | [(_ tailored-id:id 117 | grd*:guard ... 118 | dfn*:definition ... 119 | (~optional (~seq #:= g= e=) 120 | #:defaults ([g= #'#f] [e= #'#f])) 121 | (~optional (~seq #:+ g+ e+) 122 | #:defaults ([g+ #'#f] [e+ #'#f])) 123 | (~optional (~seq #:- g- e-) 124 | #:defaults ([g- #'#t] [e- #'(error 'tailored-id "cond failure")])) 125 | #:φ prop-expr) 126 | #:with error-id (string->symbol (substring (symbol->string (syntax-e #'tailored-id)) 1)) 127 | (syntax/loc stx 128 | (define-syntax (tailored-id new-stx) 129 | (syntax-parse new-stx 130 | [_:id 131 | grd*.g ... ... 132 | dfn*.d ... 133 | (⊢ (cond 134 | [g= (log-ttt-check- 'error-id new-stx) (quasisyntax/loc new-stx e=)] 135 | [g+ (log-ttt-check+ 'error-id new-stx) (quasisyntax/loc new-stx e+)] 136 | [g- (raise-user-error 'error-id e-)]) 137 | prop-expr)])))])) 138 | 139 | ;(define-syntax tailored-out 140 | ; (make-provide-pre-transformer 141 | ; (lambda (stx modes) 142 | ; (syntax-parse stx 143 | ; [(_ nm:id clause* ...) 144 | ; #:with tmp (gensym (syntax-e #'nm)) 145 | ; ;; Move type declarations to the toplevel 146 | ; (printf "deifning ~a\n" (syntax-e #'tmp)) 147 | ; (syntax-local-lift-module-end-declaration 148 | ; (syntax/loc stx 149 | ; (define (tmp stx) 150 | ; (syntax-parse stx 151 | ; clause* ... )))) 152 | ; ;; Collect a flat list of provide specs & expand 153 | ; (expand-export #'(rename-out [tmp nm]) modes)])))) 154 | -------------------------------------------------------------------------------- /trivial/private/raco-command.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Usage: 4 | ;; raco trivial FILE.rkt 5 | ;; Will report all the optimizations that took place in it. 6 | 7 | ;; TODO 8 | ;; - automatically (require trivial) 9 | 10 | (provide 11 | collect-and-summarize 12 | ) 13 | 14 | (require 15 | (only-in racket/file delete-directory/files) 16 | (only-in racket/format ~a ~r) 17 | (only-in racket/list last) 18 | (only-in racket/logging with-intercepted-logging) 19 | (only-in racket/string string-split string-prefix? string-contains?) 20 | (only-in racket/system process) 21 | (only-in trivial trivial-logger) 22 | racket/path 23 | syntax/modread 24 | ) 25 | 26 | ;; ============================================================================= 27 | 28 | (define *ANNIHILATE* (make-parameter #f)) 29 | (define TRIVIAL-LOG-PREFIX "ttt:") 30 | 31 | (define-syntax-rule (debug msg arg* ...) 32 | (begin 33 | (display "[DEBUG] ") 34 | (printf msg arg* ...) 35 | (newline))) 36 | 37 | (define (log->data ln) 38 | ;(printf "parsing ~a~n" ln) 39 | (string->symbol 40 | (cadr (regexp-match #rx"CHECK. '(.+?)'" ln)))) 41 | 42 | (define (rnd n) 43 | (~r n #:precision '(= 2))) 44 | 45 | (define (summarize fname H M) 46 | (summarize-sexp fname H M)) 47 | 48 | (define (summarize-sexp fname H M) 49 | (define-values (kv* pad-to) (hash->kv+pad H)) 50 | (cons fname 51 | (for/list ([kv (in-list (sort kv* > #:key cdr))]) 52 | (define k (car kv)) 53 | (define num-hits (cdr kv)) 54 | (define num-miss (hash-ref M k 0)) 55 | (define total (+ num-hits num-miss)) 56 | (define pct (rnd (* 100 (/ num-hits total)))) 57 | (list (~a k #:min-width pad-to) num-hits num-miss pct)))) 58 | 59 | (define (summarize-ascii H) 60 | (define msg "Summary of trivial CHECK+S:") 61 | (displayln msg) 62 | (displayln (make-string (string-length msg) #\=)) 63 | (define-values (kv* pad-to) (hash->kv+pad H)) 64 | (for ([kv (in-list (sort kv* > #:key cdr))]) 65 | (displayln (string-append 66 | "- " 67 | (~a (car kv) #:min-width pad-to) 68 | "\t" 69 | (number->string (cdr kv)))))) 70 | 71 | (define (hash->kv+pad H) 72 | (for/fold ([acc '()] 73 | [pad-to 0]) 74 | ([(k v) (in-hash H)]) 75 | (values (cons (cons k v) acc) (max pad-to (string-length (symbol->string k)))))) 76 | 77 | (define (hit? line) 78 | (string-contains? line "CHECK+")) 79 | 80 | (define (miss? line) 81 | (string-contains? line "CHECK-")) 82 | 83 | (define (make-counter) 84 | (let* ([H (make-hasheq)] 85 | [H++ (lambda (k) 86 | (define old (hash-ref H k (lambda () #f))) 87 | (if old 88 | (hash-set! H k (+ old 1)) 89 | (hash-set! H k 1)))]) 90 | (values H H++))) 91 | 92 | (define ((compile-file path+fname)) 93 | (define-values (path fname) 94 | (let ([po (path-only path+fname)]) 95 | (if po 96 | (values po (file-name-from-path path+fname)) 97 | (values (current-directory) (if (path? path+fname) 98 | path+fname 99 | (string->path path+fname)))))) 100 | (parameterize ([current-namespace (make-base-namespace)] 101 | [current-directory path]) 102 | (with-module-reading-parameterization 103 | (λ () 104 | (expand 105 | (with-input-from-file fname 106 | ;; TODO 2016-10-30 : gives bad error messages because no srcloc 107 | (λ () (read-syntax fname (current-input-port))))) 108 | (void))))) 109 | 110 | ;; ----------------------------------------------------------------------------- 111 | ;; 2016-12-07 : copied from racket/logging v6.7.0.1 112 | (define (receiver-thread receiver stop-chan intercept) 113 | (thread 114 | (lambda () 115 | (define (clear-events) 116 | (let ([l (sync/timeout 0 receiver)]) 117 | (when l ; still something to read 118 | (intercept l) ; interceptor gets the whole vector 119 | (clear-events)))) 120 | (let loop () 121 | (let ([l (sync receiver stop-chan)]) 122 | (cond [(eq? l 'stop) 123 | ;; we received all the events we were supposed 124 | ;; to get, read them all (w/o waiting), then 125 | ;; stop 126 | (clear-events)] 127 | [else ; keep going 128 | (intercept l) 129 | (loop)])))))) 130 | 131 | (define (with-intercepted-logging interceptor proc #:logger [logger #f] 132 | . log-spec) 133 | (let* ([orig-logger (current-logger)] 134 | ;; Unless we're provided with an explicit logger to monitor we 135 | ;; use a local logger to avoid getting messages that didn't 136 | ;; originate from proc. Since it's a child of the original logger, 137 | ;; the rest of the program still sees the log entries. 138 | [logger (or logger (make-logger #f orig-logger))] 139 | [receiver (apply make-log-receiver logger log-spec)] 140 | [stop-chan (make-channel)] 141 | [t (receiver-thread receiver stop-chan interceptor)]) 142 | (begin0 143 | (parameterize ([current-logger logger]) 144 | (proc)) 145 | (channel-put stop-chan 'stop) ; stop the receiver thread 146 | (thread-wait t)))) 147 | 148 | ;; end copy 149 | ;; ----------------------------------------------------------------------------- 150 | 151 | (define (collect-and-summarize fname) 152 | (define-values (H H++) (make-counter)) 153 | (define-values (M M++) (make-counter)) 154 | (define num-lines (box 0)) 155 | (with-intercepted-logging 156 | (λ (le) 157 | (when (and (eq? 'info (vector-ref le 0)) (string-prefix? (vector-ref le 1) "ttt:")) 158 | (define line (vector-ref le 1)) 159 | (set-box! num-lines (+ 1 (unbox num-lines))) 160 | (cond 161 | [(regexp-match? #rx"CHECK" line) 162 | (cond 163 | [(miss? line) 164 | (M++ (log->data line))] 165 | [else 166 | (H++ (log->data line))] 167 | #;[else 168 | (printf "WARNING: failed to parse log message ~a\n" line)])] 169 | [else 170 | (void)]))) 171 | (compile-file fname) 172 | #:logger trivial-logger 'info) 173 | ;; -- 174 | (summarize fname H M)) 175 | 176 | ;; ----------------------------------------------------------------------------- 177 | 178 | (module+ main 179 | (require racket/cmdline racket/pretty) 180 | (command-line 181 | #:once-each 182 | [("--clean" "--all") "Make clean before running" (*ANNIHILATE* #t)] 183 | #:args (fname) 184 | (define v (collect-and-summarize fname)) 185 | (pretty-display v) 186 | (void))) 187 | -------------------------------------------------------------------------------- /trivial/private/db/schema.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; Reflective datatype for database schemas 3 | 4 | ;; -- schema = ((DB-NAME (ROW-TYPE ...)) 5 | ;; ...) 6 | 7 | (provide 8 | schema-parser 9 | resolve-wildcard 10 | condition*->type* 11 | row-mem 12 | table-mem 13 | ) 14 | 15 | (require 16 | trivial/private/common 17 | trivial/private/db/mysql 18 | ; trivial/private/db/postgres ;; TODO 19 | (only-in racket/string string-split) 20 | ) 21 | 22 | ;; ============================================================================= 23 | 24 | ;; EXAMPLE SCHEMA 25 | ;(define db 26 | ; (mysql-connect #:user "user" 27 | ; #:database "Pets" 28 | ; #:schema [Cats 29 | ; [(id : Integer) 30 | ; (name : String) 31 | ; (breed : String)]])) 32 | 33 | (define (schema-parser stx) 34 | (define x* (syntax->datum stx)) 35 | (cond 36 | [(and (list? x*) 37 | (table-parser? x*)) 38 | (list x*)] 39 | [(and (list? x*) 40 | (andmap table-parser? x*)) 41 | x*] 42 | [else #f])) 43 | 44 | (define (table-parser? x*) 45 | (and (list? x*) 46 | (= 2 (length x*)) 47 | (symbol? (car x*)) 48 | (list? (cadr x*)) 49 | (for/and ([r (in-list (cadr x*))]) 50 | (and (triple? r) 51 | (symbol? (car r)) 52 | (eq? ': (cadr r)) 53 | (symbol? (caddr r)))))) 54 | 55 | (define (triple? x) 56 | (and (pair? x) 57 | (let ((x (cdr x))) 58 | (and (pair? x) 59 | (let ((x (cdr x))) 60 | (and (pair? x) 61 | (null? (cdr x)))))))) 62 | 63 | ;; ----------------------------------------------------------------------------- 64 | 65 | ;(: table-mem (-> DbSchema TableName (Option TableSchema))) 66 | (define (table-mem schema tbl) 67 | (for/first ;: (Option TableSchema) 68 | ([tbl-schema (in-list schema)] 69 | #:when (eq? tbl (car tbl-schema))) 70 | (cadr tbl-schema))) 71 | 72 | (define (row-mem tbl-schema row) 73 | (for/first ([row-schema (in-list tbl-schema)] 74 | #:when (eq? (car row-schema) row)) 75 | (caddr row-schema))) 76 | 77 | (define (resolve-wildcard tbl-schema row) 78 | (cond 79 | [(or (eq? row '*) 80 | (and (list? row) (not (null? row)) (null? (cdr row)) (eq? '* (car row)))) 81 | (map car tbl-schema)] 82 | [(list? row) 83 | row] 84 | [else 85 | (list row)])) 86 | 87 | (define (row-ref->type schema qrow) 88 | (define q* (string-split qrow ".")) 89 | (case (length q*) 90 | [(1) 91 | ;; Make sure that row exists SOMEWHERE in table 92 | (global-row-mem schema (string->symbol (car q*)))] 93 | [(2) 94 | ;; Have table name + row name, make sure they match 95 | (let ([tbl (table-mem schema (string->symbol (car q*)))]) 96 | (and tbl (row-mem tbl (string->symbol (cadr q*)))))] 97 | [else 98 | (error 'internal-error "Failed to parse query-row '~a'" qrow)])) 99 | 100 | (define (global-row-mem schema row) 101 | (let loop ([acc #f] 102 | [schema schema]) 103 | (cond 104 | [(null? schema) 105 | acc] 106 | [(row-mem (cadr (car schema)) row) 107 | => (lambda (t) 108 | (if acc #f (loop t (cdr schema))))] 109 | [else 110 | (loop acc (cdr schema))]))) 111 | 112 | (define (condition*->type* schema condition* #:src stx) 113 | (define *mysql-varnum (box 1)) 114 | (define unsorted 115 | (for/fold ([acc '()]) 116 | ([condition (in-list condition*)]) 117 | (define typ (row-ref->type schema (car condition))) 118 | (unless typ 119 | (raise-syntax-error 'query-row: 120 | "Failed to resolve type for row" (syntax->datum stx) condition)) 121 | (define val (cdr condition)) 122 | ;; (define varnum (postgres-parameter? val)) 123 | (define varnum 124 | (if (mysql-parameter? val) 125 | (let ((nn (unbox *mysql-varnum))) 126 | (set-box! *mysql-varnum (+ 1 nn)) 127 | nn) 128 | #false)) 129 | (if varnum 130 | (cons (cons typ varnum) acc) 131 | acc))) 132 | (for/list ([typ+num (sort unsorted < #:key cdr)] 133 | [num (in-naturals 1)]) 134 | (unless (= (cdr typ+num) num) 135 | (raise-syntax-error 'query-row: 136 | (format "Missing query parameter '~a'" num) 137 | (syntax->datum stx))) 138 | (car typ+num))) 139 | 140 | ;; ----------------------------------------------------------------------------- 141 | ;; TODO , but it's more work than I can do now (2016-03-09) 142 | ;(define (schema->sql schema) 143 | ; (map tbl-schema->sql schema)) 144 | ; 145 | ;(define (tbl-schema->sql tbl-schema) 146 | ; (format "CREATE TABLE ~a" 'foo)) 147 | 148 | ;; ============================================================================= 149 | 150 | (module+ test 151 | (require rackunit rackunit-abbrevs) 152 | 153 | (check-false* schema-parser 154 | [#'#f] 155 | [#'"hello"] 156 | [#'(a b c d)] 157 | ) 158 | 159 | (check-true* (lambda (x) (and (schema-parser x) #t)) 160 | [#'(Foo ())] 161 | [#'(Foo ((Bar : Baz)))] 162 | ) 163 | 164 | (check-apply* table-mem 165 | ['((a ((b : c)))) 'a 166 | => '((b : c))] 167 | ['((a ((a1 : a2) 168 | (a3 : a4))) 169 | (b ((b1 : b2)))) 170 | 'b 171 | => '((b1 : b2))] 172 | ) 173 | 174 | (check-apply* row-mem 175 | ['((a1 : a2) (a3 : a4)) 176 | 'a3 177 | => 'a4] 178 | ) 179 | 180 | (check-apply* resolve-wildcard 181 | ['((b : c) (d : e)) 182 | 'x 183 | => '(x)] 184 | ['((b : c) (d : e)) 185 | '(a i r) 186 | => '(a i r)] 187 | ['((b : c) (d : e)) 188 | '* 189 | => '(b d)] 190 | ) 191 | 192 | (let ([sc '((a ((a1 : a2))) 193 | (b ((b1 : b2) (b3 : b4))))]) 194 | (check-apply* row-ref->type 195 | [sc 196 | "a.a1" 197 | => 'a2] 198 | [sc 199 | "a1" 200 | => 'a2] 201 | [sc 202 | "b.b3" 203 | => 'b4] 204 | [sc 205 | "b.b5" 206 | => #f] 207 | [sc 208 | "x" 209 | => #f] 210 | )) 211 | (check-exn #rx"internal-error" 212 | (lambda () (row-ref->type '() ".."))) 213 | (check-exn #rx"internal-error" 214 | (lambda () (row-ref->type '() "a.b.c"))) 215 | 216 | (check-apply* global-row-mem 217 | ['((a ((b : c)))) 218 | 'b 219 | => 'c] 220 | ['() 221 | 'a 222 | => #f] 223 | ['((a ((b : c)))) 224 | 'a 225 | => #f] 226 | ['((a ((b : c))) 227 | (a2 ((b : c)))) 228 | 'b 229 | => #f] 230 | ) 231 | 232 | (let ([sc '((a ((b : c))) 233 | (d ((e : f))))]) 234 | (check-apply* condition*->type* 235 | [sc 236 | '(("a.b" . "?")) 237 | #:src #'f 238 | => '(c)] 239 | [sc 240 | '(("b" . "?")) 241 | #:src #'f 242 | => '(c)] 243 | [sc 244 | '(("b" . "yolo")) 245 | #:src #'f 246 | => '()] 247 | ) 248 | ) 249 | 250 | ;; TODO postgres 251 | ;(let ([sc '((a ((b . c))) 252 | ; (d ((e . f))))]) 253 | ; (check-apply* condition*->type* 254 | ; [sc 255 | ; '(("a.b" . "$1")) 256 | ; #:src #'f 257 | ; => '(c)] 258 | ; [sc 259 | ; '(("b" . "$1")) 260 | ; #:src #'f 261 | ; => '(c)] 262 | ; [sc 263 | ; '(("b" . "yolo")) 264 | ; #:src #'f 265 | ; => '()] 266 | ; ) 267 | ; (check-exn #rx"Missing query parameter" 268 | ; (lambda () (condition*->type* sc '(("a.b" . "$3")) #:src #'#f))) 269 | ;) 270 | 271 | ) 272 | 273 | -------------------------------------------------------------------------------- /trivial/private/list.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide 4 | (rename-out 5 | [-make-list make-list] 6 | [-build-list build-list] 7 | [-cons cons] 8 | [-car car] 9 | [-cdr cdr] 10 | [-first first] 11 | [-second second] 12 | [-third third] 13 | [-list list] 14 | [-length length] 15 | [-list-ref list-ref] 16 | [-list-tail list-tail] 17 | [-append append] 18 | [-reverse reverse] 19 | [-map map] 20 | [-sort sort] 21 | #;[-andmap andmap] 22 | #;[-ormap ormap] 23 | #;[-for-each for-each] 24 | #;[-foldl foldl] 25 | #;[-foldr foldr] 26 | #;[-filter filter] 27 | #;[-remove remove] 28 | #;[-remq remq] 29 | #;[-remv remv] 30 | #;[-remove* remove*] 31 | #;[-remq* remq*] 32 | #;[-remv* remv*] 33 | #;[-member member]) 34 | ) 35 | 36 | ;; ----------------------------------------------------------------------------- 37 | 38 | (module typed-list typed/racket 39 | (require 40 | typed/racket/unsafe 41 | (only-in racket/unsafe/ops 42 | unsafe-car 43 | unsafe-cdr)) 44 | 45 | ;; Thank you based Asumu 46 | (unsafe-require/typed racket/unsafe/ops 47 | (unsafe-cons-list (All (A B) 48 | (-> A B (Pairof A B)))) 49 | (unsafe-list-ref (All (A B) 50 | (-> (Listof A) B A))) 51 | (unsafe-list-tail (All (A B C) 52 | (-> (Pairof A B) C B)))) 53 | 54 | (unsafe-provide 55 | unsafe-cons-list unsafe-list-ref unsafe-list-tail) 56 | 57 | (provide 58 | unsafe-car unsafe-cdr null make-list build-list cons car cdr length list 59 | first second third 60 | list-ref list-tail append reverse map sort) 61 | ) 62 | 63 | (module untyped-list racket/base 64 | (require 65 | racket/list 66 | racket/unsafe/ops) 67 | (provide 68 | unsafe-cons-list unsafe-list-ref unsafe-list-tail 69 | unsafe-car unsafe-cdr null make-list build-list cons car cdr length list 70 | first second third 71 | list-ref list-tail append reverse map sort) 72 | ) 73 | 74 | ;; ----------------------------------------------------------------------------- 75 | 76 | (require 77 | (prefix-in τ- 'typed-list) 78 | (prefix-in λ- 'untyped-list) 79 | trivial/private/function 80 | trivial/private/integer 81 | trivial/private/tailoring 82 | (for-syntax 83 | typed/untyped-utils 84 | syntax/parse 85 | racket/base 86 | racket/syntax 87 | (only-in trivial/private/sequence-domain 88 | φ*-null? make-φ* format-bounds-error) 89 | (rename-in trivial/private/sequence-domain 90 | [list-domain L-dom] 91 | [vector-domain V-dom] 92 | [list-domain->I-dom L->I] 93 | [I-dom->list-domain I->L] 94 | [list-domain-cons L-cons] 95 | [list-domain-car L-car] 96 | [list-domain-first L-first] 97 | [list-domain-second L-second] 98 | [list-domain-third L-third] 99 | [list-domain-cdr L-cdr] 100 | [list-domain-reverse L-reverse] 101 | [list-domain-length L-length] 102 | [list-domain-ref L-ref] 103 | [list-domain-set L-set] 104 | [list-domain-append* L-append*] 105 | [list-domain->vector-domain L->V] 106 | [list-domain-slice L-slice]) 107 | trivial/private/common)) 108 | 109 | ;; ============================================================================= 110 | 111 | (define-tailoring (-make-list [e1 ~> e1+ (φ1 [I-dom ↦ i])] 112 | [e2 ~> e2+ (φ2)]) 113 | #:with +ml (τλ #'τ-make-list #'λ-make-list) 114 | #:= (⊥? I-dom i) 115 | (+ml e1+ e2+) 116 | #:+ #t 117 | (+ml e1+ e2+) 118 | #:φ (φ-set (φ-init) L-dom (make-φ* i φ2))) 119 | 120 | (define-tailoring (-build-list [e1 ~> e1+ (φ1 [I-dom ↦ i])] 121 | [e2 ~> e2+ (φ2 [A-dom ↦ a])]) 122 | #:with +bl (τλ #'τ-build-list #'λ-build-list) 123 | (define arity-ok? (or (⊥? A-dom a) (= (length a) 1))) 124 | (define i-⊥? (⊥? I-dom i)) 125 | #:= (and i-⊥? arity-ok?) 126 | (+bl e1+ e2+) 127 | #:+ (and (not i-⊥?) arity-ok?) 128 | (+bl e1+ e2+) 129 | #:- #t 130 | (format-arity-error #'e2+ 1) 131 | #:φ (φ-set (φ-init) L-dom (I->L i))) 132 | 133 | (define-tailoring (-cons [e1 ~> e1+ (φ1)] 134 | [e2 ~> e2+ (φ2 [L-dom ↦ l])]) 135 | #:with +cons (τλ #'τ-cons #'λ-cons) 136 | #:= (⊥? L-dom l) 137 | (+cons e1+ e2+) 138 | #:+ #t 139 | (+cons e1+ e2+) 140 | #:φ (φ-set (φ-init) L-dom (L-cons φ1 l))) 141 | 142 | (define-tailoring (-list [e* ~> e+* (φ*)] ...) 143 | #:with +list (τλ #'τ-list #'λ-list) 144 | #:+ #t (+list e+* ...) 145 | #:φ (φ-set (φ-init) L-dom φ*)) 146 | 147 | (define-tailoring -null 148 | #:with +null (τλ #'τ-null #'λ-null) 149 | #:+ #t +null 150 | #:φ (φ-set (φ-init) L-dom '())) 151 | 152 | (define-tailoring (-car [e ~> e+ (φ [L-dom ↦ l])]) 153 | #:with +car (τλ #'τ-car #'λ-car) 154 | #:with +unsafe-car (τλ #'τ-unsafe-car #'λ-unsafe-car) 155 | #:= (⊥? L-dom l) 156 | (+car e+) 157 | #:+ (not (φ*-null? l)) 158 | (+unsafe-car e+) 159 | #:- #t 160 | (format-bounds-error #'e+ 0) 161 | #:φ (L-car l)) 162 | 163 | (define-tailoring (-cdr [e ~> e+ (φ [L-dom ↦ l])]) 164 | #:with +cdr (τλ #'τ-cdr #'λ-cdr) 165 | #:with +unsafe-cdr (τλ #'τ-unsafe-cdr #'λ-unsafe-cdr) 166 | #:= (⊥? L-dom l) 167 | (+cdr e+) 168 | #:+ (not (φ*-null? l)) 169 | (+unsafe-cdr e+) 170 | #:- #t 171 | (format-bounds-error #'e+ 0) 172 | #:φ (φ-set (φ-init) L-dom (L-cdr l))) 173 | 174 | (define-tailoring (-first [e ~> e+ (φ [L-dom ↦ l])]) 175 | #:with +first (τλ #'τ-first #'λ-first) 176 | #:= (⊥? L-dom l) 177 | (+first e+) 178 | #:+ (not (φ*-null? l)) 179 | (+first e+) ;; TODO make unsafe 180 | #:- #t 181 | (format-bounds-error #'e+ 1) 182 | #:φ (L-first l)) 183 | 184 | (define-tailoring (-second [e ~> e+ (φ [L-dom ↦ l])]) 185 | #:with +second (τλ #'τ-second #'λ-second) 186 | #:= (⊥? L-dom l) 187 | (+second e+) 188 | #:+ (not (φ*-null? l)) 189 | (+second e+) ;; TODO make unsafe 190 | #:- #t 191 | (format-bounds-error #'e+ 1) 192 | #:φ (L-second l)) 193 | 194 | (define-tailoring (-third [e ~> e+ (φ [L-dom ↦ l])]) 195 | #:with +third (τλ #'τ-third #'λ-third) 196 | #:= (⊥? L-dom l) 197 | (+third e+) 198 | #:+ (not (φ*-null? l)) 199 | (+third e+) ;; TODO make unsafe 200 | #:- #t 201 | (format-bounds-error #'e+ 2) 202 | #:φ (L-third l)) 203 | 204 | (define-tailoring (-length [e ~> e+ (φ [L-dom ↦ l])]) 205 | #:with +length (τλ #'τ-length #'λ-length) 206 | (define n (L-length l)) 207 | #:= (⊥? L-dom l) 208 | (+length e+) 209 | #:+ #t '#,n 210 | #:φ (φ-set (φ-init) I-dom n)) 211 | 212 | (define-tailoring (-list-ref [e1 ~> e1+ (φ1 [L-dom ↦ l])] 213 | [e2 ~> e2+ (φ2 [I-dom ↦ i])]) 214 | #:with +list-ref (τλ #'τ-list-ref #'λ-list-ref) 215 | #:with +unsafe-list-ref (τλ #'τ-unsafe-list-ref #'λ-unsafe-list-ref) 216 | (define n (L-length l)) 217 | #:= (or (⊥? I-dom n) (⊥? I-dom i)) 218 | (+list-ref e1+ e2+) 219 | #:+ (and (<= 0 i) (< i n)) 220 | (+unsafe-list-ref e1+ e2+) 221 | #:- #t 222 | (format-bounds-error #'e1+ i) 223 | #:φ (L-ref l i)) 224 | 225 | (define-tailoring (-list-tail [e1 ~> e1+ (φ1 [L-dom ↦ l])] 226 | [e2 ~> e2+ (φ2 [I-dom ↦ i])]) 227 | #:with +list-tail (τλ #'τ-list-tail #'λ-list-tail) 228 | #:with +unsafe-list-tail (τλ #'τ-unsafe-list-tail #'λ-unsafe-list-tail) 229 | #:= (or (⊥? L-dom l) (⊥? I-dom i)) 230 | (+list-tail e1+ e2+) 231 | #:+ (and (<= 0 i) (< i (L-length l))) 232 | (+unsafe-list-tail e1+ e2+) 233 | #:- #t 234 | (format-bounds-error #'e1+ i) 235 | #:φ (φ-set (φ-init) L-dom (L-slice l i (L-length l)))) 236 | 237 | (define-tailoring (-append [e* ~> e+* (φ* [L-dom l*])] ...) 238 | #:with +append (τλ #'τ-append #'λ-append) 239 | #:= (for/or ([l (in-list l*)]) (⊥? L-dom l)) 240 | (+append e+* ...) 241 | #:+ #t 242 | (+append e+* ...) 243 | #:φ (φ-set (φ-init) L-dom (L-append* l*))) 244 | 245 | (define-tailoring (-reverse [e ~> e+ (φ [L-dom l])]) 246 | #:with +reverse (τλ #'τ-reverse #'λ-reverse) 247 | #:= (⊥? L-dom l) 248 | (+reverse e+) 249 | #:+ #t (+reverse e+) 250 | #:φ (φ-set (φ-init) L-dom (L-reverse l))) 251 | 252 | (define-tailoring (-map [f ~> f+ (φ1 [A-dom a])] 253 | [e* ~> e+* (φ* [L-dom l*])] ...) 254 | #:with +map (τλ #'τ-map #'λ-map) 255 | (define expected-arity (length l*)) 256 | (define arity-ok? (or (⊥? A-dom a) (= (length a) expected-arity))) 257 | (define n* (map L->I l*)) 258 | #:= (and (⊥? I-dom (⊓* I-dom n*)) arity-ok?) 259 | (+map f+ e+* ...) 260 | #:+ arity-ok? 261 | (+map f+ e+* ...) 262 | #:- #t 263 | (format-arity-error #'f+ expected-arity) 264 | #:φ (φ-set (φ-init) L-dom (I->L (⊓* I-dom n*)))) 265 | 266 | (define-tailoring (-sort [e ~> e+ (φ [L-dom ↦ l])] 267 | [e* ~> e+* (φ*)] ...) 268 | #:with +sort (τλ #'τ-sort #'λ-sort) 269 | #:= (⊥? L-dom l) 270 | (+sort e+ e+* ...) 271 | #:+ #t (+sort e+ e+* ...) 272 | #:φ (φ-set (φ-init) L-dom (if (⊥? L-dom l) l (make-φ* (L-length l))))) 273 | -------------------------------------------------------------------------------- /test/vector-pass.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | 3 | (module+ test 4 | (require 5 | trivial/integer 6 | trivial/vector 7 | trivial/define 8 | trivial/integer 9 | typed/rackunit) 10 | 11 | (test-case "vector-length" 12 | (check-equal? 13 | (vector-length '#()) 0) 14 | (check-equal? 15 | (vector-length (vector 1 2 2)) 3) 16 | (check-equal? 17 | (ann (- (vector-length (vector 5 5 5 5 5)) 4) 18 | One) 19 | 1) 20 | (let ([v1 (vector 2 3 4)] 21 | [v2 (vector 4 3 2)]) 22 | (check-equal? 23 | (ann (+ 1 (- (* 5 (vector-length v1)) (+ (* 4 3) (vector-length v2)))) 24 | One) 25 | 1)) 26 | (let () 27 | (define v1 (vector 2 3 4)) 28 | (define v2 (vector 4 3 2)) 29 | (check-equal? 30 | (ann (* 5 (- (vector-length v1) (* 1 1 (vector-length v2) 1))) 31 | Zero) 32 | 0)) 33 | 34 | (check-equal? (vector-ref (vector 1) 0) 1) 35 | 36 | (let ([v (vector 2)]) 37 | (check-equal? (vector-ref v 0) 2)) 38 | 39 | (let () 40 | (define v (vector "a" "bee" "sea")) 41 | (check-equal? (vector-ref v 2) "sea")) 42 | 43 | (check-equal? 44 | ((lambda (v) (vector-ref v 3)) (vector 8 2 19 3 0)) 45 | 3) 46 | 47 | (check-exn exn:fail:contract? 48 | (lambda () 49 | ((lambda ([f : (-> (Vectorof Any) Natural Any)]) 50 | (f (vector 0 1 2) 10)) vector-ref))) 51 | 52 | (let ([v1 (vector 'X)]) 53 | (let ([v2 (vector v1)]) 54 | (check-equal? (vector-ref (vector-ref v2 0) 0) 'X)))) 55 | 56 | (test-case "vector-set" 57 | (check-equal? (vector-set! (vector 1) 0 8) (void)) 58 | 59 | (let ([v (vector 2)]) 60 | (vector-set! v 0 3) 61 | (check-equal? (vector-ref v 0) 3)) 62 | 63 | (let () 64 | (define v (vector "a" "bee" "sea")) 65 | (vector-set! v 1 "bye") 66 | (check-equal? (vector-ref v 1) "bye")) 67 | 68 | (check-equal? 69 | ((lambda (v) (vector-set! v 3 4) (vector-ref v 3)) (vector 8 2 19 3 0)) 70 | 4) 71 | 72 | (check-exn exn:fail:contract? 73 | (lambda () 74 | ((lambda ([f : (-> (Vectorof Any) Natural Any Void)]) 75 | (f (vector 0 1 2) 10 9)) vector-set!)))) 76 | 77 | (test-case "vector-map" 78 | (check-equal? (vector-map add1 (vector 1)) (vector 2)) 79 | 80 | (check-equal? 81 | (let ([v : (Vectorof (Vectorof Integer)) 82 | (vector (vector 1) (vector 2 2) 83 | (vector 3 3 3) (vector 4 4 4 4))]) 84 | (vector-map vector-length v)) 85 | (vector 1 2 3 4)) 86 | 87 | (check-equal? 88 | (vector-map add1 (vector-map add1 (vector-map add1 (vector 0 0 0)))) 89 | (vector 3 3 3)) 90 | 91 | #;(check-equal? 92 | ((lambda ([v : (Vectorof (Vectorof Integer))]) 93 | (vector-map vector-length v)) 94 | (vector (vector 1) (vector 2 2) (vector 3 3 3) (vector 4 4 4 4))) 95 | (vector 1 2 3 4)) 96 | 97 | (let ([v* (make-vector 200 #f)]) 98 | (check-true (for/and ([v (in-vector (vector-map not v*))]) v))) 99 | 100 | (check-equal? 101 | ((lambda ([f : (-> (-> Symbol String) (Vectorof Symbol) (Vectorof String))]) 102 | (f symbol->string '#(x yy z))) 103 | vector-map) 104 | (vector "x" "yy" "z")) 105 | 106 | (check-exn exn:fail:contract? 107 | (lambda () 108 | ((lambda ([f : (-> (-> Integer Integer) (Vectorof Integer) (Vectorof Integer))]) 109 | (vector-ref (f add1 (vector 0 0)) 3)) 110 | vector-map)))) 111 | 112 | (test-case "vector-map!" 113 | (check-equal? (vector-map! add1 (vector 1)) (vector 2)) 114 | 115 | (check-equal? 116 | (let () 117 | (: v (Vectorof (Vectorof Integer))) 118 | (define v (vector (vector 1) (vector 2 2) (vector 3 3 3) (vector 4 4 4 4))) 119 | (vector-map! (lambda ([x : (Vectorof Integer)]) (vector (vector-length x))) v)) 120 | '#(#(1) #(2) #(3) #(4))) 121 | 122 | (check-equal? 123 | (vector-map! add1 (vector-map! add1 (vector-map! add1 (vector 0 0 0)))) 124 | (vector 3 3 3)) 125 | 126 | #;(check-equal? 127 | ((lambda ([v : (Vectorof (Vectorof Integer))]) 128 | (vector-map! (lambda ([x : (Vectorof Any)]) (vector (vector-ref x 0))) v)) 129 | (vector (vector 1) (vector 2 2) (vector 3 3 3) (vector 4 4 4 4))) 130 | '#(#(1) #(2) #(3) #(4))) 131 | 132 | (let ([v* (ann (make-vector 200 #f) (Vectorof Boolean))]) 133 | (vector-map! not v*) 134 | (check-true (for/and ([v (in-vector v*)]) v))) 135 | 136 | (check-equal? 137 | ((lambda ([f : (-> (-> Symbol Symbol) (Vectorof Symbol) (Vectorof Symbol))]) 138 | (f (lambda (x) 'hi) (vector 'x 'yy 'z))) 139 | vector-map!) 140 | (vector 'hi 'hi 'hi)) 141 | 142 | (check-exn exn:fail:contract? 143 | (lambda () 144 | ((lambda ([f : (-> (-> Integer Integer) (Vectorof Integer) (Vectorof Integer))]) 145 | (vector-ref (f add1 (vector 0 0)) 3)) 146 | vector-map!)))) 147 | 148 | (test-case "vector-append" 149 | (let ([v (vector 0 0 8)] 150 | [v2 (vector 1 2)]) 151 | (check-equal? 152 | (vector-ref (vector-append v2 v) 4) 153 | 8))) 154 | 155 | (test-case "vector->list" 156 | (let ([v (vector 8 8 8 1 8)]) 157 | (check-equal? 158 | (vector->list v) 159 | '(8 8 8 1 8))) 160 | 161 | (check-equal? 162 | (vector->list (ann (make-vector 300 '()) (Vectorof (Listof Any)))) 163 | (build-list 300 (lambda (i) '())))) 164 | 165 | (test-case "vector->immutable-vector" 166 | (check-equal? 167 | (vector-ref (vector->immutable-vector (vector 'a 'd 'e)) 0) 168 | 'a) 169 | (check-equal? 170 | (vector-ref (vector->immutable-vector (vector 9 9 4)) 0) 171 | 9)) 172 | 173 | (test-case "vector-fill!" 174 | (let ([v (vector 2 3 1)]) 175 | (check-equal? (vector-fill! v 9) (void)) 176 | (check-equal? (vector-ref v 2) 9))) 177 | 178 | (test-case "take" 179 | (let ([v (vector 2 3 1)]) 180 | (check-equal? (vector-take v 3) v) 181 | (check-equal? (vector-take v 2) (vector 2 3)) 182 | (check-equal? (vector-take v 1) (vector 2)) 183 | (check-equal? (vector-take v 0) (vector)))) 184 | 185 | (test-case "vector-take-right" 186 | (let ([v (vector 2 3 1)]) 187 | (check-equal? (vector-take-right v 3) v) 188 | (check-equal? (vector-take-right v 2) (vector 3 1)) 189 | (check-equal? (vector-take-right v 1) (vector 1)) 190 | (check-equal? (vector-take-right v 0) (vector)))) 191 | 192 | (test-case "vector-drop-right" 193 | (let ([v (vector 2 3 1)]) 194 | (check-equal? (vector-drop-right v 0) v) 195 | (check-equal? (vector-drop-right v 1) (vector 2 3)) 196 | (check-equal? (vector-drop-right v 2) (vector 2)) 197 | (check-equal? (vector-drop-right v 3) (vector)))) 198 | 199 | (test-case "vector-drop" 200 | (let ([v (vector 2 3 1)]) 201 | (check-equal? (vector-drop v 0) v) 202 | (check-equal? (vector-drop v 1) (vector 3 1)) 203 | (check-equal? (vector-drop v 2) (vector 1)) 204 | (check-equal? (vector-drop v 3) (vector)))) 205 | 206 | (test-case "vector:define" 207 | (let () 208 | (define v (vector 1 1 2 2)) 209 | (check-equal? (vector-ref v 0) 1)) 210 | (let () 211 | (define v (vector 2 1 3)) 212 | (define w (vector 2 1 3)) 213 | (check-equal? (vector-length v) 3) 214 | (check-equal? (vector-length w) 3) 215 | (check-equal? 216 | ((lambda ([z : (Vectorof Integer)]) 217 | (vector-length z)) v) 218 | 3))) 219 | 220 | ;; ----------------------------------------------------------------------------- 221 | 222 | (test-case "vector-length:more" 223 | (check-equal? 224 | (ann (vector-length #()) Zero) 225 | 0) 226 | (check-equal? 227 | (ann (- (vector-length '#(1 2)) 2) Zero) 228 | 0) 229 | (check-equal? 230 | (ann (- (vector-length '#(1 2 3 4)) 4) Zero) 231 | 0) 232 | (check-equal? 233 | (ann (- (vector-length #(a b c e s aue d al)) 8) Zero) 234 | 0) 235 | ;; --- vector 236 | (check-equal? 237 | (ann (vector-length (vector)) Zero) 238 | 0) 239 | (check-equal? 240 | (ann (- (vector-length (vector 0 1)) 2) Zero) 241 | 0) 242 | ;; --- make-vector 243 | (check-equal? 244 | (ann (vector-length (make-vector 0 8)) Zero) 245 | 0) 246 | (check-equal? 247 | (ann (- (vector-length (make-vector 3 3)) 3) Zero) 248 | 0) 249 | (check-equal? 250 | (ann (- (vector-length (make-vector 99)) 99) Zero) 251 | 0) 252 | ;; --- build-vector 253 | (check-equal? 254 | (ann (vector-length (build-vector 0 (lambda (x) x))) Zero) 255 | 0) 256 | (check-equal? 257 | (ann (- (vector-length (build-vector 3 (lambda (x) 8))) 3) Zero) 258 | 0) 259 | (check-equal? 260 | (ann (- (vector-length (build-vector 61 add1)) 61) Zero) 261 | 0)) 262 | 263 | (test-case "nested:vector-ref" 264 | (check-equal? ;; b/c vector-length is the only way to cash in 265 | (ann (vector-length (vector-ref (vector (vector) (vector)) 0)) 266 | Zero) 267 | 0) 268 | (check-equal? ;; b/c vector-length is the only way to cash in 269 | (ann (- (vector-ref (vector-append (vector 0 1) (vector 3 4)) 3) 4) 270 | Zero) 271 | 0)) 272 | ) 273 | -------------------------------------------------------------------------------- /trivial/private/string.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Strings, Byte Strings, and Characters (for now, the chars should move) 4 | 5 | (provide 6 | (for-syntax C-dom S-dom B-dom) 7 | (rename-out 8 | [-string-length string-length] 9 | [-string-ref string-ref] 10 | #;[-string-set! string-set!] 11 | [-substring substring] 12 | [-string-append string-append] 13 | [-string->number string->number] 14 | [-bytes-length bytes-length] 15 | [-bytes-ref bytes-ref] 16 | #;[-bytes-set! bytes-set!] 17 | [-subbytes subbytes] 18 | [-bytes-append bytes-append])) 19 | 20 | ;; ----------------------------------------------------------------------------- 21 | 22 | (require 23 | syntax/parse 24 | trivial/private/tailoring 25 | (only-in trivial/private/integer 26 | I-dom) 27 | (prefix-in τ- (only-in typed/racket/base 28 | string-length 29 | string-ref 30 | string-set! 31 | substring 32 | string-append 33 | string->number assert complex? 34 | ;; --- 35 | bytes-length 36 | bytes-ref 37 | bytes-set! 38 | subbytes 39 | bytes-append)) 40 | (prefix-in λ- (only-in racket/base 41 | string-length 42 | string-ref 43 | string-set! 44 | substring 45 | string-append 46 | string->number 47 | ;; --- 48 | bytes-length 49 | bytes-ref 50 | bytes-set! 51 | subbytes 52 | bytes-append)) 53 | (for-syntax 54 | typed/untyped-utils 55 | syntax/parse 56 | racket/syntax 57 | racket/base 58 | trivial/private/common 59 | (only-in trivial/private/sequence-domain 60 | format-bounds-error 61 | format-slice-error))) 62 | 63 | ;; ============================================================================= 64 | 65 | (define-for-syntax C-dom 66 | (make-abstract-domain C 67 | [c:char 68 | (syntax-e #'c)])) 69 | 70 | ;; ----------------------------------------------------------------------------- 71 | 72 | (define-for-syntax S-dom 73 | ;; TODO use sets, so regexp patterns "[0-9]" can cover many 74 | (make-abstract-domain S 75 | [s:str 76 | (syntax-e #'s)])) 77 | 78 | (define-tailoring (-string-length [e ~> e+ (φ [S-dom ↦ s])]) 79 | #:with +string-length (τλ #'τ-string-length #'λ-string-length) 80 | #:= (⊥? S-dom s) 81 | (+string-length e+) 82 | #:+ #t 83 | '#,(string-length s) 84 | #:φ (φ-set (φ-init) I-dom (if (⊥? S-dom s) (⊥ I-dom) (string-length s)))) 85 | 86 | (define-tailoring (-string-ref [e0 ~> e0+ (φ0 [S-dom ↦ s])] [e1 ~> e1+ (φ1 [I-dom ↦ k])]) 87 | #:with +string-ref (τλ #'τ-string-ref #'λ-string-ref) 88 | (define any-bot? (or (⊥? S-dom s) (⊥? I-dom k))) 89 | #:= any-bot? 90 | (+string-ref e0+ e1+) 91 | #:+ (and (<= 0 k) (< k (string-length s))) 92 | '#,(string-ref s k) 93 | #:- #true 94 | (format-bounds-error #'e0+ k) 95 | #:φ (φ-set (φ-init) C-dom (if any-bot? (⊥ C-dom) (string-ref s k)))) 96 | 97 | (define-tailoring (-string-set! [e0 ~> e0+ (φ0 [S-dom ↦ s])] [e1 ~> e1+ (φ1 [I-dom ↦ k])] [e2 ~> e2+ (φ2 [C-dom ↦ c])]) 98 | #:with +string-set! (τλ #'τ-string-set! #'λ-string-set!) 99 | (define any-bot? (or (⊥? S-dom s) (⊥? I-dom k) (⊥? C-dom c))) 100 | (define safe? (and (<= 0 k) (< k (string-length s)))) 101 | (define str+ 102 | (if (or any-bot? (not safe?)) 103 | (⊥ S-dom) 104 | (string-append (substring s 0 k) (string c) (substring s (+ k 1))))) 105 | #:= any-bot? 106 | (+string-set! e0+ e1+ e2+) 107 | #:+ safe? 108 | (+string-set! e0+ e1+ e2+) 109 | #:- #true 110 | (format-bounds-error #'e0+ k) 111 | #:φ (φ-set (φ-init) S-dom (if any-bot? (⊥ S-dom) str+))) 112 | 113 | (define-tailoring (-substring1 [e0 ~> e0+ (φ0 [S-dom ↦ s])] [e1 ~> e1+ (φ1 [I-dom ↦ i])]) 114 | #:with +substring (τλ #'τ-substring #'λ-substring) 115 | (define any-bot? (or (⊥? S-dom s) (⊥? I-dom i))) 116 | #:= any-bot? 117 | (+substring e0+ e1+) 118 | #:+ (and (<= 0 i) (< i (string-length s))) 119 | '#,(substring s i) 120 | #:- #true 121 | (format-bounds-error #'e0+ i) 122 | #:φ (φ-set (φ-init) S-dom (if any-bot? (⊥ S-dom) (substring s i)))) 123 | 124 | (define-tailoring (-substring2 [e0 ~> e0+ (φ0 [S-dom ↦ s])] [e1 ~> e1+ (φ1 [I-dom ↦ i1])] [e2 ~> e2+ (φ2 [I-dom ↦ i2])]) 125 | #:with +substring (τλ #'τ-substring #'λ-substring) 126 | (define any-bot? (or (⊥? S-dom s) (⊥? I-dom i1) (⊥? I-dom i2))) 127 | #:= any-bot? 128 | (+substring e0+ e1+ e2+) 129 | #:+ (and (<= 0 i1) (<= i1 i2) (<= i2 (string-length s))) 130 | '#,(substring s i1 i2) 131 | #:- #true 132 | (cond 133 | [(or (< i1 0) (<= (string-length s) i1)) 134 | (format-bounds-error #'e0+ i1)] 135 | [(or (< i2 0) (< (string-length s) i2)) 136 | (format-bounds-error #'e0+ i2)] 137 | [else 138 | (format-slice-error #'e0+ i1 i2)]) 139 | #:φ (φ-set (φ-init) S-dom (if any-bot? (⊥ S-dom) (substring s i1 i2)))) 140 | 141 | (define-syntax (-substring stx) 142 | (syntax-parse stx 143 | [(_ e0 e1) 144 | (syntax/loc stx (-substring1 e0 e1))] 145 | [(_ . e*) 146 | (syntax/loc stx (-substring2 . e*))] 147 | [_:id 148 | (syntax/loc stx -substring2)])) 149 | 150 | (define-tailoring (-string-append [e* ~> e+* (φ [S-dom ↦ s*])] ...) 151 | #:with +string-append (τλ #'τ-string-append #'λ-string-append) 152 | #:= (for/or ([s (in-list s*)]) 153 | (⊥? S-dom s)) 154 | (+string-append e+* ...) 155 | #:+ #t 156 | '#,(apply string-append s*) 157 | #:φ (φ-set (φ-init) S-dom (reduce* S-dom string-append "" s*))) 158 | 159 | (define-tailoring (-string->number [e ~> e+ (φ [S-dom ↦ s])]) 160 | #:with +string->number (τλ #'τ-string->number #'λ-string->number) 161 | #:= (or (⊥? S-dom s) 162 | (not (syntax-local-typed-context?)) 163 | (not (string->number s))) 164 | (+string->number e+) 165 | #:+ #t 166 | (τ-assert (+string->number e+) τ-complex?) 167 | #:φ (φ-init)) 168 | 169 | ;; ----------------------------------------------------------------------------- 170 | 171 | (define-for-syntax B-dom 172 | (make-abstract-domain B 173 | [b 174 | (let ([v (syntax-e #'b)]) 175 | (and (bytes? v) v))])) 176 | 177 | (define-for-syntax (format-bytes-error stx) 178 | (format "[~a:~a] expected a byte in '~a'" 179 | (syntax-source stx) 180 | (syntax-line stx) 181 | (syntax->datum stx))) 182 | 183 | (define-tailoring (-bytes-length [e ~> e+ (φ [B-dom ↦ b])]) 184 | #:with +bytes-length (τλ #'τ-bytes-length #'λ-bytes-length) 185 | #:= (⊥? B-dom b) 186 | (+bytes-length e+) 187 | #:+ #t 188 | '#,(bytes-length b) 189 | #:φ (φ-set (φ-init) I-dom (if (⊥? B-dom b) (⊥ I-dom) (bytes-length b)))) 190 | 191 | (define-tailoring (-bytes-ref [e0 ~> e0+ (φ0 [B-dom ↦ b])] [e1 ~> e1+ (φ1 [I-dom ↦ k])]) 192 | #:with +bytes-ref (τλ #'τ-bytes-ref #'λ-bytes-ref) 193 | (define any-bot? (or (⊥? B-dom b) (⊥? I-dom k))) 194 | #:= any-bot? 195 | (+bytes-ref e0+ e1+) 196 | #:+ (and (<= 0 k) (< k (bytes-length b))) 197 | '#,(bytes-ref b k) 198 | #:- #true 199 | (format-bounds-error #'e0+ k) 200 | #:φ (φ-set (φ-init) I-dom (if any-bot? (⊥ I-dom) (bytes-ref b k)))) 201 | 202 | (define-tailoring (-bytes-set! [e0 ~> e0+ (φ0 [B-dom ↦ b])] [e1 ~> e1+ (φ1 [I-dom ↦ k])] [e2 ~> e2+ (φ2 [I-dom ↦ i])]) 203 | #:with +bytes-set! (τλ #'τ-bytes-set! #'λ-bytes-set!) 204 | (define any-bot? (or (⊥? B-dom b) (⊥? I-dom k) (⊥? I-dom i))) 205 | (define safe? (and (<= 0 k) (< k (bytes-length b)) (<= 0 i 256))) 206 | (define bytes+ 207 | (if (or any-bot? (not safe?)) 208 | (⊥ B-dom) 209 | (bytes-append (subbytes b 0 k) (bytes i) (subbytes b (+ k 1))))) 210 | #:= any-bot? 211 | (+bytes-set! e0+ e1+ e2+) 212 | #:+ safe? 213 | '#,bytes+ 214 | #:- #true 215 | (cond 216 | [(or (< k 0) (<= (bytes-length b) k)) 217 | (format-bounds-error #'e0+ k)] 218 | [else 219 | (format-bytes-error #'e2+ i)]) 220 | #:φ (φ-set (φ-init) B-dom (if any-bot? (⊥ B-dom) bytes+))) 221 | 222 | (define-tailoring (-subbytes1 [e0 ~> e0+ (φ0 [B-dom ↦ b])] [e1 ~> e1+ (φ1 [I-dom ↦ i])]) 223 | #:with +subbytes (τλ #'τ-subbytes #'λ-subbytes) 224 | (define any-bot? (or (⊥? B-dom b) (⊥? I-dom i))) 225 | #:= any-bot? 226 | (+subbytes e0+ e1+) 227 | #:+ (and (<= 0 i) (< i (bytes-length b))) 228 | '#,(subbytes b i) 229 | #:- #true 230 | (format-bounds-error #'e0+ i) 231 | #:φ (φ-set (φ-init) B-dom (if any-bot? (⊥ B-dom) (subbytes b i)))) 232 | 233 | (define-tailoring (-subbytes2 [e0 ~> e0+ (φ0 [B-dom ↦ b])] [e1 ~> e1+ (φ1 [I-dom ↦ i1])] [e2 ~> e2+ (φ2 [I-dom ↦ i2])]) 234 | #:with +subbytes (τλ #'τ-subbytes #'λ-subbytes) 235 | (define any-bot? (or (⊥? B-dom b) (⊥? I-dom i1) (⊥? I-dom i2))) 236 | #:= any-bot? 237 | (+subbytes e0+ e1+ e2+) 238 | #:+ (and (<= 0 i1) (<= i1 i2) (<= i2 (bytes-length b))) 239 | '#,(subbytes b i1 i2) 240 | #:- #true 241 | (cond 242 | [(or (< i1 0) (<= (bytes-length b) i1)) 243 | (format-bounds-error #'e0+ i1)] 244 | [(or (< i2 0) (< (bytes-length b) i2)) 245 | (format-bounds-error #'e0+ i2)] 246 | [else 247 | (format-slice-error #'e0+ i1 i2)]) 248 | #:φ (φ-set (φ-init) B-dom (if any-bot? (⊥ B-dom) (subbytes b i1 i2)))) 249 | 250 | (define-syntax (-subbytes stx) 251 | (syntax-parse stx 252 | [(_ e0 e1) 253 | (syntax/loc stx (-subbytes1 e0 e1))] 254 | [(_ . e*) 255 | (syntax/loc stx (-subbytes2 . e*))] 256 | [_:id 257 | (syntax/loc stx -subbytes2)])) 258 | 259 | (define-tailoring (-bytes-append [e* ~> e+* (φ [B-dom ↦ b*])] ...) 260 | #:with +bytes-append (τλ #'τ-bytes-append #'λ-bytes-append) 261 | #:= (for/or ([b (in-list b*)]) 262 | (⊥? B-dom b)) 263 | (+bytes-append e+* ...) 264 | #:+ #t 265 | '#,(apply bytes-append b*) 266 | #:φ (φ-set (φ-init) B-dom (reduce* B-dom bytes-append #"" b*))) 267 | 268 | -------------------------------------------------------------------------------- /test/db-fail.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;(require trivial/private/test-common 3 | ; (only-in typed/racket/base 4 | ; with-handlers raise lambda : -> Any List String Natural Integer Vector)) 5 | ; 6 | ;;; === HOLY BOILERPLATE BATMAN 7 | ; 8 | ;(module+ test (test-compile-error 9 | ; #:require trivial/private/db 10 | ; #:exn #rx"query-row::|Type Checker" 11 | ; 12 | ; ;; =========================================================================== 13 | ; ;; === TEST reference missing table 14 | ; (let ([fish-sql "CREATE TABLE fish ( id serial PRIMARY KEY, name text UNIQUE NOT NULL, weight int NOT NULL);"] 15 | ; [cube-sql "CREATE TABLE cube ( id serial PRIMARY KEY, length smallint NOT NULL, width integer NOT NULL, height bigint NOT NULL);"]) 16 | ; (let-schema: ([schema '((fish ((id . Natural) (name . String) (weight . Integer))) (cube ((id . Natural) (length . Integer) (width . Integer) (height . Integer))))]) 17 | ; (let-connection: ([conn (postgresql-connect: schema #:user "postgres" #:database "travis_ci_test")]) 18 | ; (let ([with-transaction (lambda ([thunk : (-> Any)]) 19 | ; (define maybe-exn 20 | ; (with-handlers ([exn? (lambda ([e : exn]) e)]) 21 | ; (start-transaction conn) 22 | ; (thunk) 23 | ; #f)) 24 | ; (rollback-transaction conn) 25 | ; (if maybe-exn (raise maybe-exn) (void)))] 26 | ; [insert-fish (lambda ([x : (List String Natural)]) 27 | ; (query-exec conn "INSERT INTO fish (name, weight) VALUES ($1, $2);" (car x) (cadr x)))] 28 | ; [insert-cube (lambda ([x : (List Integer Integer Integer)]) 29 | ; (query-exec conn "INSERT INTO cube (length, width, height) VALUES ($1, $2, $3);" (car x) (cadr x) (caddr x)))]) 30 | ; (query-exec conn fish-sql) 31 | ; (query-exec conn cube-sql) 32 | ; (define f1 '("Marlin" 8)) 33 | ; (define c1 '(2 4 8)) 34 | ; (insert-fish f1) 35 | ; (insert-cube c1) 36 | ; ;; ------------------------------------------------------------------- 37 | ; (query-row: conn "SELECT * FROM fake_table"))))) 38 | ; 39 | ; ;; =========================================================================== 40 | ; ;; === TEST missing row 41 | ; (let ([fish-sql "CREATE TABLE fish ( id serial PRIMARY KEY, name text UNIQUE NOT NULL, weight int NOT NULL);"] 42 | ; [cube-sql "CREATE TABLE cube ( id serial PRIMARY KEY, length smallint NOT NULL, width integer NOT NULL, height bigint NOT NULL);"]) 43 | ; (let-schema: ([schema '((fish ((id . Natural) (name . String) (weight . Integer))) (cube ((id . Natural) (length . Integer) (width . Integer) (height . Integer))))]) 44 | ; (let-connection: ([conn (postgresql-connect: schema #:user "postgres" #:database "travis_ci_test")]) 45 | ; (let ([with-transaction (lambda ([thunk : (-> Any)]) 46 | ; (define maybe-exn 47 | ; (with-handlers ([exn? (lambda ([e : exn]) e)]) 48 | ; (start-transaction conn) 49 | ; (thunk) 50 | ; #f)) 51 | ; (rollback-transaction conn) 52 | ; (if maybe-exn (raise maybe-exn) (void)))] 53 | ; [insert-fish (lambda ([x : (List String Natural)]) 54 | ; (query-exec conn "INSERT INTO fish (name, weight) VALUES ($1, $2);" (car x) (cadr x)))] 55 | ; [insert-cube (lambda ([x : (List Integer Integer Integer)]) 56 | ; (query-exec conn "INSERT INTO cube (length, width, height) VALUES ($1, $2, $3);" (car x) (cadr x) (caddr x)))]) 57 | ; (query-exec conn fish-sql) 58 | ; (query-exec conn cube-sql) 59 | ; (define f1 '("Marlin" 8)) 60 | ; (define c1 '(2 4 8)) 61 | ; (insert-fish f1) 62 | ; (insert-cube c1) 63 | ; ;; ------------------------------------------------------------------- 64 | ; (query-row: conn "SELECT * FROM fish where fish.fry = 1"))))) 65 | ; 66 | ; ;; =========================================================================== 67 | ; ;; === TEST missing actual parameter 68 | ; (let ([fish-sql "CREATE TABLE fish ( id serial PRIMARY KEY, name text UNIQUE NOT NULL, weight int NOT NULL);"] 69 | ; [cube-sql "CREATE TABLE cube ( id serial PRIMARY KEY, length smallint NOT NULL, width integer NOT NULL, height bigint NOT NULL);"]) 70 | ; (let-schema: ([schema '((fish ((id . Natural) (name . String) (weight . Integer))) (cube ((id . Natural) (length . Integer) (width . Integer) (height . Integer))))]) 71 | ; (let-connection: ([conn (postgresql-connect: schema #:user "postgres" #:database "travis_ci_test")]) 72 | ; (let ([with-transaction (lambda ([thunk : (-> Any)]) 73 | ; (define maybe-exn 74 | ; (with-handlers ([exn? (lambda ([e : exn]) e)]) 75 | ; (start-transaction conn) 76 | ; (thunk) 77 | ; #f)) 78 | ; (rollback-transaction conn) 79 | ; (if maybe-exn (raise maybe-exn) (void)))] 80 | ; [insert-fish (lambda ([x : (List String Natural)]) 81 | ; (query-exec conn "INSERT INTO fish (name, weight) VALUES ($1, $2);" (car x) (cadr x)))] 82 | ; [insert-cube (lambda ([x : (List Integer Integer Integer)]) 83 | ; (query-exec conn "INSERT INTO cube (length, width, height) VALUES ($1, $2, $3);" (car x) (cadr x) (caddr x)))]) 84 | ; (query-exec conn fish-sql) 85 | ; (query-exec conn cube-sql) 86 | ; (define f1 '("Marlin" 8)) 87 | ; (define c1 '(2 4 8)) 88 | ; (insert-fish f1) 89 | ; (insert-cube c1) 90 | ; ;; ------------------------------------------------------------------- 91 | ; (query-row: conn "SELECT * FROM fish where fish.name = $1"))))) 92 | ; 93 | ; ;; =========================================================================== 94 | ; ;; === TEST wrong type for actual parameter 95 | ; (let ([fish-sql "CREATE TABLE fish ( id serial PRIMARY KEY, name text UNIQUE NOT NULL, weight int NOT NULL);"] 96 | ; [cube-sql "CREATE TABLE cube ( id serial PRIMARY KEY, length smallint NOT NULL, width integer NOT NULL, height bigint NOT NULL);"]) 97 | ; (let-schema: ([schema '((fish ((id . Natural) (name . String) (weight . Integer))) (cube ((id . Natural) (length . Integer) (width . Integer) (height . Integer))))]) 98 | ; (let-connection: ([conn (postgresql-connect: schema #:user "postgres" #:database "travis_ci_test")]) 99 | ; (let ([with-transaction (lambda ([thunk : (-> Any)]) 100 | ; (define maybe-exn 101 | ; (with-handlers ([exn? (lambda ([e : exn]) e)]) 102 | ; (start-transaction conn) 103 | ; (thunk) 104 | ; #f)) 105 | ; (rollback-transaction conn) 106 | ; (if maybe-exn (raise maybe-exn) (void)))] 107 | ; [insert-fish (lambda ([x : (List String Natural)]) 108 | ; (query-exec conn "INSERT INTO fish (name, weight) VALUES ($1, $2);" (car x) (cadr x)))] 109 | ; [insert-cube (lambda ([x : (List Integer Integer Integer)]) 110 | ; (query-exec conn "INSERT INTO cube (length, width, height) VALUES ($1, $2, $3);" (car x) (cadr x) (caddr x)))]) 111 | ; (query-exec conn fish-sql) 112 | ; (query-exec conn cube-sql) 113 | ; (define f1 '("Marlin" 8)) 114 | ; (define c1 '(2 4 8)) 115 | ; (insert-fish f1) 116 | ; (insert-cube c1) 117 | ; ;; ------------------------------------------------------------------- 118 | ; (query-row: conn "SELECT * FROM fish where fish.name = $1" 666))))) 119 | ; 120 | ; ;; =========================================================================== 121 | ; ;; === TEST skipping query parameter 122 | ; (let ([fish-sql "CREATE TABLE fish ( id serial PRIMARY KEY, name text UNIQUE NOT NULL, weight int NOT NULL);"] 123 | ; [cube-sql "CREATE TABLE cube ( id serial PRIMARY KEY, length smallint NOT NULL, width integer NOT NULL, height bigint NOT NULL);"]) 124 | ; (let-schema: ([schema '((fish ((id . Natural) (name . String) (weight . Integer))) (cube ((id . Natural) (length . Integer) (width . Integer) (height . Integer))))]) 125 | ; (let-connection: ([conn (postgresql-connect: schema #:user "postgres" #:database "travis_ci_test")]) 126 | ; (let ([with-transaction (lambda ([thunk : (-> Any)]) 127 | ; (define maybe-exn 128 | ; (with-handlers ([exn? (lambda ([e : exn]) e)]) 129 | ; (start-transaction conn) 130 | ; (thunk) 131 | ; #f)) 132 | ; (rollback-transaction conn) 133 | ; (if maybe-exn (raise maybe-exn) (void)))] 134 | ; [insert-fish (lambda ([x : (List String Natural)]) 135 | ; (query-exec conn "INSERT INTO fish (name, weight) VALUES ($1, $2);" (car x) (cadr x)))] 136 | ; [insert-cube (lambda ([x : (List Integer Integer Integer)]) 137 | ; (query-exec conn "INSERT INTO cube (length, width, height) VALUES ($1, $2, $3);" (car x) (cadr x) (caddr x)))]) 138 | ; (query-exec conn fish-sql) 139 | ; (query-exec conn cube-sql) 140 | ; (define f1 '("Marlin" 8)) 141 | ; (define c1 '(2 4 8)) 142 | ; (insert-fish f1) 143 | ; (insert-cube c1) 144 | ; ;; ------------------------------------------------------------------- 145 | ; (query-row: conn "SELECT * FROM fish where fish.name = $3" "Marlin"))))) 146 | ; 147 | ;)) 148 | -------------------------------------------------------------------------------- /trivial/scribblings/using-tailorings.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @require[ 3 | scribble/example 4 | (for-label 5 | racket/base 6 | racket/contract 7 | racket/function 8 | (only-in typed/untyped-utils syntax-local-typed-context?)) 9 | ] 10 | 11 | @(define (make-typed-eval) (make-base-eval #:lang 'typed/racket '(begin (require trivial)))) 12 | 13 | @; ============================================================================= 14 | @title[#:tag "ttt:tutorial"]{Using Tailorings} 15 | 16 | The following tailorings are all provided by the @racketmodname[trivial] module. 17 | Note that these tailorings have the same name as their Racket and Typed Racket equivalents to make this library a drop-in replacement for existing code. 18 | 19 | The descriptions below assume familiarity with the Racket reference and describe only the new behavior of the tailored function or form. 20 | Click the name of any tailoring to see its definition in the Racket reference. 21 | 22 | @section{Built-in Tailorings} 23 | 24 | @subsection{Definitions} 25 | @defmodule[trivial/define] 26 | 27 | @bold{WARNING} the static analysis implemented by @racket[trivial/define] is unsound in the presence of @racket[set!]. 28 | Do not @racket[set!] in a module that uses @racket[trivial/define]. 29 | 30 | @deftogether[( 31 | @defform[#:id define (define id expr)]{} 32 | @defform/none[(define (head args) expr)]{} 33 | )]{ 34 | Forces local expansion of @racket[expr] and associates any inferred properties with @racket[id] for the rest of expansion. 35 | } 36 | 37 | @deftogether[( 38 | @defform[#:id let (let ([id val-expr] ...) body ...+)]{} 39 | @defform[#:id let* (let* ([id val-expr] ...) body ...+)]{} 40 | )]{ 41 | Forces local expansion of each @racket[val-expr] and associates any inferred properties with the respective @racket[id] in the context of @racket[body ...+]. 42 | } 43 | 44 | @subsection{Format Strings} 45 | @defmodule[trivial/format] 46 | 47 | @deftogether[( 48 | @defproc[(format [form string?] [v any/c] ...) string?]{} 49 | @defproc[(printf [form string?] [v any/c] ...) void?]{} 50 | )]{ 51 | When the string @racket[form] is available during expansion, checks the number of values @racket[v ...] against the number of formatting escapes in @racket[form] that require arguments. 52 | When used in a Typed Racket module, annotates each @racket[v] with the type required by the corresponding formatting escape. 53 | } 54 | 55 | 56 | @subsection{Functions} 57 | @defmodule[trivial/function] 58 | 59 | @defform[#:id curry (curry f)]{ 60 | This form does not have a Typed Racket equivalent. 61 | 62 | When the arity of the procedure @racket[f] is available during expansion, expands to a curried version of @racket[f]. 63 | In other words, if @racket[f] is a function of @racket[N] arguments then @racket[(curry f)] is a chain of @math{N} one-argument functions. 64 | 65 | For example, 66 | @racketblock[ 67 | (curry (λ (x y z) (+ (* x y) z))) 68 | ] 69 | 70 | behaves the same as: 71 | @racketblock[ 72 | (λ (x) 73 | (λ (y) 74 | (λ (z) 75 | (+ (* x y) z)))) 76 | ] 77 | } 78 | 79 | @deftogether[( 80 | @defform[#:id lambda (lambda (id ...) body)]{} 81 | @defform[#:id λ (λ (id ...) body)]{} 82 | )]{ 83 | Expands to an anonymous function with known arity. 84 | Other tailorings can access this arity. 85 | } 86 | 87 | 88 | @subsection{Integer Arithmetic} 89 | @defmodule[trivial/integer] 90 | 91 | @deftogether[( 92 | @defproc[(+ [n integer?] ...) integer?]{} 93 | @defproc[(- [n integer?] ...) integer?]{} 94 | @defproc[(* [n integer?] ...) integer?]{} 95 | )]{ 96 | Constant-folding arithmetic functions. 97 | When all arguments @racket[n ...] have integer values available during expansion, expands to a constant integer (or bignum). 98 | When only some arguments have available values, reduces the expression accordingly. 99 | } 100 | 101 | @deftogether[( 102 | @defproc[(/ [n integer?] ...) real?]{} 103 | @defproc[(quotient [n integer?] ...) integer?]{} 104 | )]{ 105 | Constant-folding division. 106 | Raises a syntax error @racket{division by zero} when the final argument is @racket[zero?] during expansion. 107 | } 108 | 109 | @deftogether[( 110 | @defproc[(add1 [n integer?]) integer?]{} 111 | @defproc[(sub1 [n integer?]) integer?]{} 112 | )]{ 113 | Increment and decrement functions that propagate the value of their argument. 114 | } 115 | 116 | @defproc[(expt [n1 integer?] [n2 integer?]) integer?]{ 117 | Constant-folding exponentiation. 118 | If the value of @racket[n1] is unknown, checks whether the value of @racket[n2] is @racket[zero?] or a small constant. 119 | In the latter case, unfolds to repeated multiplication of @racket[n1]. 120 | } 121 | 122 | 123 | @subsection{List Operations} 124 | @defmodule[trivial/list] 125 | 126 | @deftogether[( 127 | @defproc[(make-list [k exact-nonnegative-integer?] [v any/c]) list?]{} 128 | @defproc[(build-list [k exact-nonnegative-integer?] [proc (-> exact-nonnegative-integer? any/c)]) list?]{} 129 | @defproc[(cons [a any/c] [d any/c]) pair?]{} 130 | @defproc[(car [p pair?]) any/c]{} 131 | @defproc[(cdr [p pair?]) any/c]{} 132 | @defproc[(list [v any/c] ...) list?]{} 133 | @defproc[(length [lst list?]) exact-nonnegative-integer?]{} 134 | @defproc[(list-ref [lst pair?] [pos exact-nonnegative-integer?]) any/c]{} 135 | @defproc[(list-tail [lst pair?] [pos exact-nonnegative-integer?]) any/c]{} 136 | @defproc[(append [lst list?] ...) list?]{} 137 | @defproc[(reverse [lst list?]) list?]{} 138 | @defproc[(map [proc procedure?] [lst list?] ...) list?]{} 139 | @defproc[(sort [lst list?] [less-than? (-> any/c any/c any/c)]) list?]{} 140 | )]{ 141 | Length-aware and content-aware list operations. 142 | Operations that build lists propagate the length of their arguments. 143 | Operations that access lists check for bounds errors and propagate information about cells within a list. 144 | 145 | Higher-order list functions check the arity of their functional argument; in particular, @racket[map] includes a static check that the arity of its first argument includes the number of lists supplied at the call-site. 146 | 147 | These Typed Racket examples demonstrate terms that would not typecheck without the @racketmodname[trivial] library. 148 | 149 | @examples[#:eval (make-typed-eval) 150 | (ann (- (length '(1 2 3)) 3) Zero) 151 | (ann (list-ref (make-list 5 0) 2) Zero) 152 | (ann (list-ref (list-ref '((A)) 0) 0) 'A) 153 | ] 154 | } 155 | 156 | 157 | @subsection{Regular Expressions} 158 | @defmodule[trivial/regexp] 159 | 160 | @deftogether[( 161 | @defproc[(regexp [str string?]) regexp?]{} 162 | @defproc[(pregexp [str string?]) pregexp?]{} 163 | @defproc[(byte-regexp [byt bytes?]) byte-regexp?]{} 164 | @defproc[(byte-pregexp [byt bytes?]) byte-pregexp?]{} 165 | )]{ 166 | Regexp constructors; when their argument value is known during expansion, these constructors record the number of groups specified by the argument. 167 | } 168 | 169 | @defproc[(regexp-match [pattern (or/c string? bytes? regexp? byte-regexp?)] [input (or/c string? bytes? path? input-port?)]) 170 | (if (and (or (string? pattern) (regexp? pattern)) 171 | (or (string? input) (path? input))) 172 | (or/c #f (cons/c string? (listof (or/c string? #f)))) 173 | (or/c #f (cons/c bytes? (listof (or/c bytes? #f)))))]{ 174 | When possible, the type of the result list (in the case of a successful match) matches the number of groups in @racket[pattern]. 175 | 176 | @margin-note{This example is adapted from @racketmodname[scribble/html-render]} 177 | @examples[#:eval (make-typed-eval) 178 | (: parse-font-size : String -> (List String String (U #f String) String)) 179 | (define (parse-font-size str) 180 | (or (regexp-match #rx"^([0-9]*\\.?([0-9]+)?)(em|ex|pt|%|)$" str) 181 | (error 'malformed-input))) 182 | ] 183 | } 184 | 185 | 186 | @subsection{String Operations} 187 | @defmodule[trivial/string] 188 | 189 | @deftogether[( 190 | @defproc[(string-length [str string?]) exact-nonnegative-integer?]{} 191 | @defproc[(string-ref [str string?] [k exact-nonnegative-integer?]) char?]{} 192 | @defproc[(substring [str string?] [start exact-nonnegative-integer?] [end exact-nonnegative-integer? (string-length str)]) string?]{} 193 | @defproc[(string-append [str string?] ...) string?]{} 194 | )] 195 | @deftogether[( 196 | @defproc[(bytes-length [bstr bytes?]) exact-nonnegative-integer?]{} 197 | @defproc[(bytes-ref [bstr bytes?] [k exact-nonnegative-integer?]) byte?]{} 198 | @defproc[(subbytes [bstr bytes?] [start exact-nonnegative-integer?] [end exact-nonnegative-integer? (bytes-length bstr)]) bytes?]{} 199 | @defproc[(bytes-append [bstr bytes?] ...) bytes?]{} 200 | )]{ 201 | String and byte string operations that track the value of their arguments. 202 | 203 | @examples[#:eval (make-typed-eval) 204 | (regexp-match (string-append "(" "a*" ")") "aaa") 205 | ] 206 | } 207 | 208 | 209 | @subsection{Vector Operations} 210 | @defmodule[trivial/vector] 211 | 212 | @deftogether[( 213 | @defproc[(vector [v any/c] ...) vector?]{} 214 | @defproc[(make-vector [k exact-nonnegative-integer?] [v any/c]) vector?]{} 215 | @defproc[(build-vector [k exact-nonnegative-integer?] [proc (-> exact-nonnegative-integer? any/c)]) vector?]{} 216 | @defproc[(vector-append [vec vector?] ...) vector?]{} 217 | @defproc[(vector-ref [vec vector?] [pos exact-nonnegative-integer?]) any/c]{} 218 | @defproc[(vector-length [vec vector?]) exact-nonnegative-integer?]{} 219 | @defproc[(vector-set! [vec vector?] [pos exact-nonnegative-integer?] [v any/c]) vector?]{} 220 | @defproc[(vector-map [proc procedure?] [vec vector?] ...) vector?]{} 221 | @defproc[(vector-map! [proc procedure?] [vec vector?] ...) void?]{} 222 | @defproc[(vector->list [vec vector?]) list?]{} 223 | @defproc[(vector->immutable-vector [vec vector?]) vector?]{} 224 | @defproc[(vector-fill! [vec vector?] [v any/c]) void?]{} 225 | @defproc[(vector-take [vec vector?] [pos exact-nonnegative-integer?]) vector?]{} 226 | @defproc[(vector-take-right [vec vector?] [pos exact-nonnegative-integer?]) vector?]{} 227 | @defproc[(vector-drop [vec vector?] [pos exact-nonnegative-integer?]) vector?]{} 228 | @defproc[(vector-drop-right [vec vector?] [pos exact-nonnegative-integer?]) vector?]{} 229 | )]{ 230 | Length-aware and content-aware vector operations. 231 | } 232 | 233 | 234 | @section{Typed / Untyped Interaction} 235 | 236 | @; @margin-note{The implementation is a little ugly, but it works for now.} 237 | The macros provided by @racketmodname[trivial] and related submodules are all untyped, but should work @bold{with no problems} in Typed Racket modules. 238 | Under the hood, these macros keep two copies of every tailored identifier and use @racket[syntax-local-typed-context?] to choose the appropriate identifiers and whether to expand to type-annotated code. 239 | 240 | -------------------------------------------------------------------------------- /trivial/private/regexp.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Stronger types for regular expression matching. 4 | 5 | ;; Specification: 6 | ;; - Racket docs: 7 | ;; http://docs.racket-lang.org/reference/regexp.html 8 | ;; 9 | ;; - Pregexp docs: 10 | ;; http://ds26gte.github.io/pregexp/index.html 11 | ;; 12 | ;; - Racket source: 13 | ;; https://github.com/racket/racket/blob/master/racket/src/racket/src/regexp.c 14 | 15 | (provide 16 | (for-syntax R-dom) 17 | (rename-out 18 | [-regexp regexp] 19 | [-pregexp pregexp] 20 | [-byte-regexp byte-regexp] 21 | [-byte-pregexp byte-pregexp] 22 | [-regexp-match regexp-match])) 23 | 24 | (require 25 | (prefix-in τ- (only-in typed/racket/base 26 | car and or list-ref let regexp-match regexp pregexp byte-regexp byte-pregexp)) 27 | (prefix-in λ- (only-in racket/base 28 | car and or list-ref let regexp-match regexp pregexp byte-regexp byte-pregexp)) 29 | (prefix-in ttt- (only-in trivial/private/list list)) 30 | trivial/private/tailoring 31 | (only-in trivial/private/string S-dom B-dom) 32 | (for-syntax 33 | (rename-in trivial/private/sequence-domain 34 | [list-domain L-dom]) 35 | (only-in racket/syntax format-id) 36 | racket/base 37 | (only-in racket/list range) 38 | (only-in racket/format ~a) 39 | syntax/parse 40 | typed/untyped-utils 41 | trivial/private/common)) 42 | 43 | ;; ============================================================================= 44 | 45 | (begin-for-syntax 46 | 47 | (define (format-group-error stx str reason) 48 | (format 49 | "[~a:~a] Invalid regexp pattern (unmatched ~a) in ~s" 50 | (syntax-line stx) 51 | (syntax-column stx) 52 | reason 53 | str)) 54 | 55 | ;; Dispatch for counting groups 56 | ;; On success, return (Listof Boolean) 57 | ;; - booleans indicating "always succeeds" (#t) and "may fail" (#f) 58 | (define (parse-groups v-stx) 59 | (define v (syntax-e v-stx)) 60 | (cond 61 | [(string? v) (parse-groups/string v #:src v-stx)] 62 | [(regexp? v) (parse-groups/regexp v #:src v-stx)] 63 | [(pregexp? v) (parse-groups/pregexp v #:src v-stx)] 64 | [(bytes? v) (parse-groups/bytes v #:src v-stx)] 65 | [(byte-regexp? v) (parse-groups/byte-regexp v #:src v-stx)] 66 | [(byte-pregexp? v) (parse-groups/byte-pregexp v #:src v-stx)] 67 | [else (⊥ R-dom)])) 68 | 69 | (define (parse-groups/string str #:src stx) 70 | (parse-groups/untyped str #:src stx)) 71 | 72 | (define (parse-groups/bytes b #:src stx) 73 | (parse-groups/untyped (~a b) #:src stx)) 74 | 75 | (define (parse-groups/regexp rx #:src stx) 76 | (parse-groups/string (~a rx) #:src stx)) 77 | 78 | (define parse-groups/pregexp 79 | parse-groups/regexp) 80 | 81 | (define (parse-groups/byte-regexp bx #:src stx) 82 | (parse-groups/bytes (~a bx) #:src stx)) 83 | 84 | (define parse-groups/byte-pregexp 85 | parse-groups/byte-regexp) 86 | 87 | ;; (-> String #:src Syntax (Listof Boolean)) 88 | (define (parse-groups/untyped str #:src stx) 89 | (define char->pos* 90 | (let ([H (unescaped-pos* str '(#\[ #\] #\( #\) #\| #\?))]) 91 | (lambda (c) 92 | (hash-ref H c (lambda () (raise-user-error 'parse-groups "No position data for '~a' character" c)))))) 93 | ;; -- check that [] are matched 94 | (define brack-ivl* 95 | (let* ([l-brack-pos* (char->pos* #\[)] 96 | [r-brack-pos* (char->pos* #\])] 97 | [r (pair-up l-brack-pos* r-brack-pos*)]) 98 | ;; ?? okay for brackets to nest? 99 | (if (list? r) 100 | r 101 | (let ([brack-char (if (memv r l-brack-pos*) "[" "]")]) 102 | (⊤ R-dom (format-group-error stx str (format "'~a' at index ~a" brack-char r))))))) 103 | (cond 104 | [(⊤? R-dom brack-ivl*) 105 | brack-ivl*] 106 | [else 107 | ;; -- ignore characters between a pair of brackets 108 | (define-values (l-paren-pos* r-paren-pos* pipe-pos* ?-pos*) 109 | (apply values 110 | (for/list ([c (in-list '(#\( #\) #\| #\?))]) 111 | (ivl-remove* brack-ivl* (char->pos* c))))) 112 | ;; -- check that () are matched 113 | (define paren-ivl* 114 | (let ([r (pair-up l-paren-pos* r-paren-pos*)]) 115 | (if (list? r) 116 | r 117 | (let ([paren-char (if (memv r l-paren-pos*) "(" ")")]) 118 | (⊤ R-dom (format-group-error stx str (format "'~a' at index ~a" paren-char r))))))) 119 | (cond 120 | [(⊤? R-dom paren-ivl*) ;; jeez we need a monad 121 | paren-ivl*] 122 | [else 123 | ;; -- groups = #parens. 124 | ;; may fail to capture if has | outside (that are not nested in other parens) 125 | ;; or ? after close 126 | (for/list ([ivl (in-list paren-ivl*)] 127 | #:when (not (has-?-before ivl ?-pos*))) 128 | (and 129 | (not (has-unguarded-pipe-before-or-after ivl paren-ivl* pipe-pos*)) 130 | (not (has-*-after ivl str)) 131 | (not (has-?-after ivl ?-pos*)) 132 | (let ((ivl-str (substring str (+ 1 (car ivl)) (cdr ivl)))) 133 | (and (< 0 (string-length ivl-str)) 134 | (unsound-choose-bracket ivl-str)))))])])) 135 | 136 | (define (unsound-choose-bracket str) 137 | (define L (string-length str)) 138 | (if (and (eq? #\[ (string-ref str 0)) 139 | (eq? #\] (string-ref str (- L 1)))) 140 | (string (string-ref str (- L 2))) 141 | str)) 142 | 143 | (define (has-?-before ivl ?-pos*) 144 | (define pos-before (+ 1 (car ivl))) ;; Well, just inside the paren. 145 | (for/or ([?pos (in-list ?-pos*)]) 146 | (= pos-before ?pos))) 147 | 148 | (define (has-?-after ivl ?-pos*) 149 | (define pos-after (+ 1 (cdr ivl))) 150 | (for/or ([?pos (in-list ?-pos*)]) 151 | (= pos-after ?pos))) 152 | 153 | (define (has-*-after ivl str) 154 | (let ([i (+ 1 (cdr ivl))]) 155 | (and (< i (string-length str)) 156 | (eq? #\* (string-ref str i))))) 157 | 158 | (define (has-unguarded-pipe-before-or-after ivl paren-ivl* pipe-pos*) 159 | (define other-paren-ivl* 160 | (for/list ([ivl2 (in-list paren-ivl*)] 161 | #:when (not (ivl< ivl ivl2))) 162 | ivl2)) 163 | (define dangerous-pipe* (ivl-remove* other-paren-ivl* pipe-pos*)) 164 | (not (null? dangerous-pipe*))) 165 | 166 | ;; Does not work for #\\ character 167 | (define (unescaped-pos* str c*) 168 | (define L (string-length str)) 169 | (define escaped? (box #f)) 170 | (define most-recent-char (box #f)) 171 | (define (have-char-at-index? c i hist) 172 | (memv i (hash-ref hist c))) 173 | (define h-rev 174 | (for/fold ([hist (for/hasheq ([c (in-list c*)]) (values c '()))]) 175 | ([i (in-range L)]) 176 | (define char (string-ref str i)) 177 | (cond 178 | [(unbox escaped?) 179 | (when (or (not (eq? #\\ char)) 180 | (eq? #\[ (unbox most-recent-char))) 181 | (set-box! escaped? #f)) 182 | hist] 183 | [(eq? #\\ char) 184 | (set-box! escaped? #t) 185 | hist] 186 | ;; --- special case for singleton , 187 | ;; documented at `http://docs.racket-lang.org/reference/regexp.html` 188 | [(and (eq? #\] char) 189 | (or (have-char-at-index? #\[ (- i 1) hist) ;; []] pattern 190 | (and (have-char-at-index? #\[ (- i 2) hist) 191 | (eq? #\^ (string-ref str (- i 1)))))) ;; [^]] pattern 192 | hist] 193 | [else 194 | (let ([i* (hash-ref hist char #f)]) 195 | (if i* 196 | (begin 197 | (set-box! most-recent-char char) 198 | (hash-set hist char (cons i i*))) 199 | hist))]))) 200 | ;; -- reverse all saved lists 201 | (for/hasheq ([(c i*) (in-hash h-rev)]) 202 | (values c (reverse i*)))) 203 | 204 | ;; (define-type Ivl (Pairof Natural Natural)) 205 | 206 | ;; Match a list of left indices with a list of right indices. 207 | ;; Return a list of pairs on success 208 | ;; and the unmatched index on failure. 209 | ;; (-> (Listof Natural) (Listof Natural) (U Natural (Listof Ivl))) 210 | (define (pair-up l* r*) 211 | (let loop ([i 0] [l* l*] [r* r*] [prev* '()]) 212 | (cond 213 | [(null? r*) 214 | (if (null? l*) 215 | (if (null? prev*) 216 | '() ;; good 217 | (car prev*)) ;; bad 218 | (car l*))] ;; bad 219 | [(= i (car r*)) 220 | (if (null? prev*) 221 | i 222 | (let ([r (loop (+ i 1) l* (cdr r*) (cdr prev*))]) 223 | (if (integer? r) 224 | r 225 | (ivl-insert (cons (car prev*) i) r))))] 226 | [(or (null? l*) (< i (car l*))) 227 | (loop (+ i 1) l* r* prev*)] 228 | [(= i (car l*)) 229 | (loop (+ i 1) (cdr l*) r* (cons i prev*))]))) 230 | 231 | ;; Assume `ivl*` is sorted by left position 232 | ;; Insert `ivl` in sorted order 233 | ;; (-> Ivl (Listof Ivl) (Listof Ivl)) 234 | (define (ivl-insert ivl ivl*) 235 | (cond 236 | [(null? ivl*) 237 | (list ivl)] 238 | [(< (car ivl) (caar ivl*)) 239 | (cons ivl ivl*)] 240 | [else 241 | (cons (car ivl*) (ivl-insert ivl (cdr ivl*)))])) 242 | 243 | (define (ivl-remove* ivl* i*) 244 | (for/list ([i (in-list i*)] 245 | #:when (not (for/or ([ivl (in-list ivl*)]) (in-ivl? ivl i)))) 246 | i)) 247 | 248 | (define (ivl< ivl1 ivl2) 249 | (and (< (car ivl2) (car ivl1)) 250 | (< (cdr ivl1) (cdr ivl2)))) 251 | 252 | (define (in-ivl? ivl i) 253 | (and (< (car ivl) i) 254 | (< i (cdr ivl)))) 255 | 256 | (define R-dom 257 | (make-abstract-domain R 258 | [x 259 | (let* ([φ (φ #'x)] 260 | [s (φ-ref φ S-dom)]) 261 | (if (or (string? s) (bytes? s)) 262 | (parse-groups #'#,s) 263 | (parse-groups #'x)))])) 264 | 265 | ) 266 | 267 | ;; ----------------------------------------------------------------------------- 268 | 269 | (define-syntax (define-matcher stx) 270 | (syntax-parse stx 271 | [(_ tid:id) 272 | #:with -tid (format-id stx "-~a" (syntax-e #'tid)) 273 | #:with τ-tid (format-id stx "τ~a" (syntax-e #'-tid)) 274 | #:with λ-tid (format-id stx "λ~a" (syntax-e #'-tid)) 275 | (syntax/loc stx 276 | (define-tailoring (-tid [e ~> e+ (φ [R-dom ↦ g])]) 277 | #:with +tid (τλ (syntax τ-tid) (syntax λ-tid)) 278 | #:= (⊥? R-dom g) 279 | (+tid e+) 280 | #:+ #t 281 | (+tid e+) 282 | #:φ φ))])) 283 | 284 | (define-matcher regexp) 285 | (define-matcher pregexp) 286 | (define-matcher byte-regexp) 287 | (define-matcher byte-pregexp) 288 | 289 | (define-tailoring (-regexp-match [pat ~> pat+ (φ [R-dom ↦ capture?*])] 290 | [e* ~> e+* (φ*)] ...) 291 | #:with +list-ref (τλ #'τ-list-ref #'λ-list-ref) 292 | #:with +rxm (τλ #'τ-regexp-match #'λ-regexp-match) 293 | #:with +let (τλ #'τ-let #'λ-let) 294 | #:with +car (τλ #'τ-car #'λ-car) 295 | #:with +and (τλ #'τ-and #'λ-and) 296 | #:with +or (τλ #'τ-or #'λ-or) 297 | #:= (⊥? R-dom capture?*) 298 | (+rxm pat+ e+* ...) 299 | #:+ #t 300 | (+let ([maybe-match (+rxm pat+ e+* ...)]) 301 | (+and maybe-match 302 | (+let ([rxm-error (lambda (i) (error 'regexp-match: "Internal error: expected group ~a to capture based on rx pattern '~a', but capture failed.\n Please report to 'http://github.com/bennn/trivial/issues' and use Racket's regexp-match in the meantime." i 'pat+))]) 303 | (ttt-list 304 | (+car maybe-match) 305 | #,@(for/list ([capture?-stx (in-list capture?*)] 306 | [i (in-naturals 1)]) 307 | (if capture?-stx 308 | (⊢ 309 | (quasisyntax/loc #'pat 310 | (+or (+list-ref maybe-match '#,i) 311 | (rxm-error '#,i))) 312 | (φ-set (φ-init) S-dom capture?-stx)) 313 | #`(+list-ref maybe-match '#,i))))))) 314 | #:φ (if (⊥? R-dom capture?*) 315 | (φ-init) 316 | (φ-set (φ-init) 317 | L-dom 318 | (cons (φ-init) 319 | (for/list ((cc (in-list capture?*))) 320 | (φ-set (φ-init) S-dom cc)))))) 321 | 322 | -------------------------------------------------------------------------------- /trivial/private/vector.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide 4 | (rename-out 5 | [-vector vector] 6 | [-build-vector build-vector] 7 | [-make-vector make-vector] 8 | [-vector-append vector-append] 9 | [-vector-ref vector-ref] 10 | [-vector-length vector-length] 11 | [-vector-set! vector-set!] 12 | [-vector-map vector-map] 13 | [-vector-map! vector-map!] 14 | [-vector->list vector->list] 15 | [-vector->immutable-vector vector->immutable-vector] 16 | [-vector-fill! vector-fill!] 17 | [-vector-take vector-take] 18 | [-vector-take-right vector-take-right] 19 | [-vector-drop vector-drop] 20 | [-vector-drop-right vector-drop-right] 21 | #;[-vector-split-at vector-split-at] 22 | #;[-vector-split-at-right vector-split-at-right])) 23 | 24 | ;; ----------------------------------------------------------------------------- 25 | 26 | (module typed-vector typed/racket 27 | (require 28 | racket/vector 29 | (only-in racket/unsafe/ops unsafe-vector-set! unsafe-vector-ref)) 30 | (provide 31 | λ : Integer 32 | vector build-vector make-vector vector-ref vector-length 33 | vector-append vector-set! vector-map vector-map! vector->list 34 | vector->immutable-vector vector-fill! vector-take vector-take-right 35 | vector-drop vector-drop-right unsafe-vector-set! unsafe-vector-ref)) 36 | 37 | (module untyped-vector typed/racket 38 | (require 39 | racket/vector 40 | (only-in racket/unsafe/ops unsafe-vector-set! unsafe-vector-ref)) 41 | (provide 42 | λ 43 | vector build-vector make-vector vector-ref vector-length 44 | vector-append vector-set! vector-map vector-map! vector->list 45 | vector->immutable-vector vector-fill! vector-take vector-take-right 46 | vector-drop vector-drop-right unsafe-vector-set! unsafe-vector-ref)) 47 | 48 | ;(module optimized-vector racket 49 | ; ;; VECTOR-MAP 50 | ; (with-syntax ([(i* ...) (range n)]) 51 | ; (syntax/loc stx (+let ([f+ f.~>] [v+ v.~>]) 52 | ; (-vector (f+ (-vector-ref v+ 'i*)) ...)))) 53 | ; (quasisyntax/loc stx 54 | ; (+let ([f+ f.~>] [v+ v.~>]) 55 | ; (+build-vector '#,n (+λ (#,(if (syntax-local-typed-context?) 56 | ; (syntax/loc stx [i : Integer]) 57 | ; (syntax/loc stx i))) 58 | ; (f+ (+unsafe-vector-ref v+ i))))))) 59 | ; ;; VECTOR-APPEND 60 | ; (if (and (ok-to-unfold? (quotient n1 2)) (ok-to-unfold? (quotient n2 2))) 61 | ; (with-syntax ([(i1* ...) (range n1)] 62 | ; [(i2* ...) (range n2)]) 63 | ; (syntax/loc stx 64 | ; (+let ([v1+ v1.~>] [v2+ v2.~>]) 65 | ; (-vector (-vector-ref v1+ i1*) ... (-vector-ref v2+ i2*) ...)))) 66 | ; (quasisyntax/loc stx 67 | ; (+let ([v1+ v1.~>] [v2+ v2.~>]) 68 | ; (+build-vector '#,n1+n2 69 | ; (+λ (#,(if (syntax-local-typed-context?) 70 | ; (syntax/loc stx [i : Integer]) 71 | ; (syntax/loc stx i))) 72 | ; (if (< i '#,n1) 73 | ; ;; TODO should use -vector-ref (but we're under a λ) 74 | ; (+unsafe-vector-ref v1+ i) 75 | ; (+unsafe-vector-ref v2+ i))))))) 76 | ; VECTOR->LIST 77 | ; (with-syntax ([(i* ...) (range n)]) 78 | ; (syntax/loc stx (+let ([v+ v.~>]) 79 | ; (list (+unsafe-vector-ref v+ i*) ...)))) 80 | ; (quasisyntax/loc stx 81 | ; (+let ([v+ v.~>]) 82 | ; (build-list '#,n 83 | ; (+λ (#,(if (syntax-local-typed-context?) 84 | ; (syntax/loc stx [i : Integer]) 85 | ; (syntax/loc stx i))) 86 | ; (+unsafe-vector-ref v+ i)))))) 87 | ; VECTOR-FILL! 88 | ; #`(+let ([v+ v.~>] [e+ e.~>]) 89 | ; (for ([i (in-range '#,n)]) 90 | ; (+unsafe-vector-set! v+ i e+))) 91 | ; SLICE 92 | ; (with-syntax ([hi-lo (- hi lo)]) 93 | ; (quasisyntax/loc stx 94 | ; (+let ([v+ e1.~>]) 95 | ; (-build-vector 'hi-lo 96 | ; (+λ (#,(if (syntax-local-typed-context?) 97 | ; (syntax/loc stx [i : Integer]) 98 | ; (syntax/loc stx i))) 99 | ; (+unsafe-vector-ref v+ (+ i '#,lo))))))) 100 | ;) 101 | 102 | (require 103 | (only-in racket/unsafe/ops 104 | unsafe-vector-set! 105 | unsafe-vector-ref) 106 | (prefix-in τ- 'typed-vector) 107 | (prefix-in λ- 'untyped-vector) 108 | trivial/private/function 109 | trivial/private/integer 110 | trivial/private/tailoring 111 | (for-syntax 112 | (only-in trivial/private/sequence-domain 113 | make-φ* format-bounds-error) 114 | (rename-in trivial/private/sequence-domain 115 | [vector-domain V-dom] 116 | [list-domain L-dom] 117 | [vector-domain->I-dom V->I] 118 | [I-dom->vector-domain I->V] 119 | [vector-domain-length V-length] 120 | [vector-domain-ref V-ref] 121 | [vector-domain-set V-set] 122 | [vector-domain-append* V-append*] 123 | [vector-domain->list-domain V->L] 124 | [vector-domain-slice V-slice]) 125 | typed/untyped-utils 126 | syntax/parse 127 | racket/base 128 | racket/syntax 129 | (only-in racket/list range) 130 | trivial/private/common)) 131 | 132 | ;; ============================================================================= 133 | 134 | (define-tailoring (-vector [e* ~> e+* (φ*)] ...) 135 | #:with +v (τλ #'τ-vector #'λ-vector) 136 | #:+ #t (+v e+* ...) 137 | #:φ (φ-set (φ-init) V-dom φ*)) 138 | 139 | (define-tailoring (-make-vector1 [e1 ~> e1+ (φ1 [I-dom ↦ i])]) 140 | #:with +mv (τλ #'τ-make-vector #'λ-make-vector) 141 | #:= (⊥? I-dom i) 142 | (+mv e1+) 143 | #:+ #t 144 | (+mv e1+) 145 | #:φ (φ-set (φ-init) V-dom (I->V i))) 146 | 147 | (define-tailoring (-make-vector2 [e1 ~> e1+ (φ1 [I-dom ↦ i])] 148 | [e2 ~> e2+ (φ2)]) 149 | #:with +mv (τλ #'τ-make-vector #'λ-make-vector) 150 | #:= (⊥? I-dom i) 151 | (+mv e1+ e2+) 152 | #:+ #t 153 | (+mv e1+ e2+) 154 | #:φ (φ-set (φ-init) V-dom (make-φ* i φ2 #:dom V-dom))) 155 | 156 | (define-syntax (-make-vector stx) 157 | (syntax-parse stx 158 | [(_ e1) 159 | (syntax/loc stx 160 | (-make-vector1 e1))] 161 | [(_ . e*) 162 | (syntax/loc stx 163 | (-make-vector2 . e*))] 164 | [_:id 165 | #:with +mv (τλ #'τ-make-vector #'λ-make-vector) 166 | (syntax/loc stx 167 | +mv)])) 168 | 169 | (define-tailoring (-build-vector [e1 ~> e1+ (φ1 [I-dom ↦ i])] 170 | [e2 ~> e2+ (φ2 [A-dom ↦ a])]) 171 | #:with +bv (τλ #'τ-build-vector #'λ-build-vector) 172 | (define arity-ok? (or (⊥? A-dom a) (= (length a) 1))) 173 | (define i-⊥? (⊥? I-dom i)) 174 | #:= (and i-⊥? arity-ok?) 175 | (+bv e1+ e2+) 176 | #:+ (and (not i-⊥?) arity-ok?) 177 | (+bv e1+ e2+) 178 | #:- #t 179 | (format-arity-error #'e2+ 1) 180 | #:φ (φ-set (φ-init) V-dom (I->V i))) 181 | 182 | (define-tailoring (-vector-ref [e1 ~> e1+ (φ1 [V-dom ↦ v])] 183 | [e2 ~> e2+ (φ2 [I-dom ↦ i])]) 184 | #:with +vector-ref (τλ #'τ-vector-ref #'λ-vector-ref) 185 | #:with +unsafe-vector-ref (τλ #'τ-unsafe-vector-ref #'λ-unsafe-vector-ref) 186 | (define n (V-length v)) 187 | #:= (or (⊥? V-dom v) (⊥? I-dom i)) 188 | (+vector-ref e1+ e2+) 189 | #:+ (and (<= 0 i) (< i n)) 190 | (+unsafe-vector-ref e1+ e2+) 191 | #:- #t 192 | (format-bounds-error #'e1+ i) 193 | #:φ (V-ref v i)) 194 | 195 | (define-tailoring (-vector-length [e ~> e+ (φ [V-dom v])]) 196 | #:with +vl (τλ #'τ-vector-length #'λ-vector-length) 197 | (define n (V-length v)) 198 | #:= (⊥? V-dom v) 199 | (+vl e+) 200 | #:+ #t '#,n 201 | #:φ (φ-set (φ-init) I-dom n)) 202 | 203 | (define-tailoring (-vector-set! [e1 ~> e1+ (φ1 [V-dom v])] 204 | [e2 ~> e2+ (φ2 [I-dom i])] 205 | [e3 ~> e3+ (φ3)]) 206 | #:with +vs (τλ #'τ-vector-set! #'λ-vector-set!) 207 | (define n (V-length v)) 208 | #:= (or (⊥? V-dom v) (⊥? I-dom i)) 209 | (+vs e1+ e2+ e3+) 210 | #:+ (and (<= 0 i) (< i n)) 211 | (+vs e1+ e2+ e3+) 212 | #:- #t 213 | (format-bounds-error #'e1+ i) 214 | #:φ (φ-set φ1 V-dom (V-set φ1 i φ3))) 215 | 216 | (define-tailoring (-vector-map [f ~> f+ (φ1 [A-dom a])] 217 | [e* ~> e+* (φ* [V-dom v*])] ...) 218 | #:with +vector-map (τλ #'τ-vector-map #'λ-vector-map) 219 | (define n* (map V->I v*)) 220 | (define expected-arity (length n*)) 221 | (define arity-ok? (or (⊥? A-dom a) (= (length a) expected-arity))) 222 | #:= (and (⊥? I-dom (⊓* I-dom n*)) arity-ok?) 223 | (+vector-map f+ e+* ...) 224 | #:+ arity-ok? 225 | (+vector-map f+ e+* ...) 226 | #:- #t 227 | (format-arity-error #'f+ expected-arity) 228 | #:φ (φ-set (φ-init) V-dom (I->V (⊓* I-dom n*)))) 229 | 230 | (define-tailoring (-vector-map! [f ~> f+ (φ1 [A-dom a])] 231 | [e* ~> e+* (φ* [V-dom v*])] ...) 232 | #:with +vector-map! (τλ #'τ-vector-map! #'λ-vector-map!) 233 | (define n* (map V->I v*)) 234 | (define expected-arity (length n*)) 235 | (define arity-ok? (or (⊥? A-dom a) (= (length a) expected-arity))) 236 | (define n-⊥? (⊥? I-dom (⊓* I-dom n*))) 237 | #:= (and n-⊥? arity-ok?) 238 | (+vector-map! f+ e+* ...) 239 | #:+ (and (not n-⊥?) arity-ok?) 240 | (+vector-map! f+ e+* ...) 241 | #:- #t 242 | (format-arity-error #'f+ expected-arity) 243 | #:φ (φ-set (φ-init) V-dom (I->V (⊓* I-dom n*)))) 244 | 245 | (define-tailoring (-vector-append [e* ~> e+* (φ* [V-dom v*])] ...) 246 | #:with +vector-append (τλ #'τ-vector-append #'λ-vector-append) 247 | (define n* (map V->I v*)) 248 | #:= (⊥? I-dom (⊓* I-dom n*)) 249 | (+vector-append e+* ...) 250 | #:+ #t 251 | (+vector-append e+* ...) 252 | #:φ (φ-set (φ-init) V-dom (V-append* v*))) 253 | 254 | (define-tailoring (-vector->list [e ~> e+ (φ [V-dom v])]) 255 | #:with +vector->list (τλ #'τ-vector->list #'λ-vector->list) 256 | #:= (⊥? V-dom v) 257 | (+vector->list e+) 258 | #:+ #t 259 | (+vector->list e+) 260 | #:φ (φ-set (φ-init) L-dom (V->L v))) 261 | 262 | (define-tailoring (-vector->immutable-vector [e ~> e+ (φ [V-dom ↦ v])]) 263 | #:with +vi (τλ #'τ-vector->immutable-vector #'λ-vector->immutable-vector) 264 | #:= (⊥? V-dom v) (+vi e+) 265 | #:+ #t (+vi e+) 266 | #:φ φ) 267 | 268 | (define-tailoring (-vector-fill! [e1 ~> e1+ (φ1 [V-dom ↦ v])] 269 | [e2 ~> e2+ (φ2)]) 270 | #:with +vf (τλ #'τ-vector-fill! #'λ-vector-fill!) 271 | #:= (⊥? V-dom v) (+vf e1+ e2+) 272 | #:+ #t (+vf e1+ e2+) 273 | #:φ (φ-set (φ-init) V-dom (make-φ* (V-length v) φ2 #:dom V-dom))) 274 | 275 | (define-tailoring (-vector-take [e1 ~> e1+ (φ1 [V-dom ↦ v])] 276 | [e2 ~> e2+ (φ2 [I-dom ↦ i])]) 277 | #:with +vt (τλ #'τ-vector-take #'λ-vector-take) 278 | (define n (V-length v)) 279 | #:= (or (⊥? V-dom v) (⊥? I-dom i)) 280 | (+vt e1+ e2+) 281 | #:+ (<= 0 i n) 282 | (+vt e1+ e2+) 283 | #:- #t 284 | (format-bounds-error #'e1+ i) 285 | #:φ (φ-set (φ-init) V-dom (V-slice v 0 i))) 286 | 287 | (define-tailoring (-vector-take-right [e1 ~> e1+ (φ1 [V-dom ↦ v])] 288 | [e2 ~> e2+ (φ2 [I-dom ↦ i])]) 289 | #:with +vt (τλ #'τ-vector-take-right #'λ-vector-take-right) 290 | (define n (V-length v)) 291 | #:= (or (⊥? V-dom v) (⊥? I-dom i)) 292 | (+vt e1+ e2+) 293 | #:+ (<= 0 i n) 294 | (+vt e1+ e2+) 295 | #:- #t 296 | (format-bounds-error #'e1+ i) 297 | #:φ (φ-set (φ-init) V-dom (V-slice v (reduce I-dom - n i) n))) 298 | 299 | (define-tailoring (-vector-drop [e1 ~> e1+ (φ1 [V-dom ↦ v])] 300 | [e2 ~> e2+ (φ2 [I-dom ↦ i])]) 301 | #:with +vt (τλ #'τ-vector-drop #'λ-vector-drop) 302 | (define n (V-length v)) 303 | #:= (or (⊥? V-dom v) (⊥? I-dom i)) 304 | (+vt e1+ e2+) 305 | #:+ (<= 0 i n) 306 | (+vt e1+ e2+) 307 | #:- #t 308 | (format-bounds-error #'e1+ i) 309 | #:φ (φ-set (φ-init) V-dom (V-slice v i n))) 310 | 311 | (define-tailoring (-vector-drop-right [e1 ~> e1+ (φ1 [V-dom ↦ v])] 312 | [e2 ~> e2+ (φ2 [I-dom ↦ i])]) 313 | #:with +vt (τλ #'τ-vector-drop-right #'λ-vector-drop-right) 314 | (define n (V-length v)) 315 | #:= (or (⊥? V-dom v) (⊥? I-dom i)) 316 | (+vt e1+ e2+) 317 | #:+ (<= 0 i n) 318 | (+vt e1+ e2+) 319 | #:- #t 320 | (format-bounds-error #'e1+ i) 321 | #:φ (φ-set (φ-init) V-dom (V-slice v 0 (reduce I-dom - n i)))) 322 | 323 | -------------------------------------------------------------------------------- /test/regexp-pass.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | 3 | ;; Well-typed use of regexp 4 | 5 | (module+ test 6 | 7 | (require 8 | trivial/regexp 9 | trivial/string 10 | trivial/define 11 | typed/rackunit) 12 | 13 | ;; -- TODO (handle regexp . format) 14 | ; (define re:normal-name (regexp (format "~a*<([^>]*)>~a*" blank blank))) 15 | 16 | ;; -- regexps, from the world 17 | (test-case "regexp-misc" 18 | 19 | (let () ;; -- from klocker? anyway the unicode will segfault `unsafe-string-ref` 20 | (check-equal? 21 | (ann (regexp-match #rx"⇒" "yolo") (U #f (List String))) 22 | #f)) 23 | 24 | (let ([str "dont care"]) ;; from `tests/racket/contract/multi-file.rkt` 25 | (check-equal? 26 | (ann 27 | (regexp-match #rx"[/\\]([-a-z0-9.]*)[^/\\]*$" str) 28 | (U #f (List String String))) 29 | #f)) 30 | 31 | (let ([l "dont care"]) ;; from `morse-code-table.rkt` 32 | (check-equal? 33 | (ann 34 | (regexp-match #rx"[]] [^]]" l) 35 | (U #f (List String))) 36 | #f) 37 | (check-equal? 38 | (ann 39 | (regexp-match #px"^\\| \\[\\[[^]]*\\]\\] \\[([^]]*)\\] \\|\\| '''([^']*)'''" l) 40 | (U #f (List String String String))) 41 | #f)) 42 | 43 | (let ([str "1cm"]) ;; from html-render.rkt 44 | (check-equal? 45 | (ann (regexp-match #rx"^([+-]?[0-9]*\\.?([0-9]+)?)(em|ex|px|in|cm|mm|pt|pc|%|)$" str) 46 | (U #f (List String String (U #f String) String))) 47 | (list str "1" #f "cm"))) 48 | 49 | (let ([expr "x+y*x"]) ;; from racket-doc/guide/scribblings/arith.rkt 50 | (check-equal? 51 | (ann (regexp-match #px"^([a-z]|[0-9]+)(?:[-+*/]([a-z]|[0-9]+))*(?![-+*/])" expr) 52 | (U #f (List String String String))) 53 | (list expr "x" "x"))) 54 | 55 | (let ([str "(this and that!)"]) ;; from load-one.rkt 56 | (check-equal? 57 | (ann (regexp-match #rx"^[(].*[)]$" str) (U #f (List String))) 58 | (list str))) 59 | 60 | (let () 61 | (check-true (and (regexp "^(\r|\n|(\r\n))") #t))) 62 | 63 | (let ([str "Pete would gain 4."]) ;; from Matthew Butterick's Advent of Code solutions 64 | (check-equal? 65 | (ann (regexp-match #px"^(.*?) would (gain|lose) (\\d+)\\.$" str) 66 | (U #f (List String String String String))) 67 | (list str "Pete" "gain" "4"))) 68 | 69 | (let ([str "| yo"]) ;; from John Clement's morse-code-trainer 70 | (check-equal? 71 | (ann (regexp-match #px"hey [|] (yo)" str) 72 | (U #f (List String String))) 73 | #f)) 74 | 75 | (let ([l "0 afAF09 AF09af ABSD_asdf ="]) ;; from racket/src/worksp/gendef.rkt 76 | (define m : (U #f (List String String String)) 77 | (regexp-match 78 | #rx"([0-9]+) +(?:[0-9A-Fa-f]+) +(?:[0-9A-Fa-f]+) +([_A-Za-z][_A-Za-z0-9]*) +=" 79 | l)) 80 | (check-equal? m (list l "0" "ABSD_asdf")))) 81 | 82 | (test-case "regexp-match" 83 | (check-equal? 84 | (ann (regexp-match (regexp "he") "hellooo") 85 | (U #f (List String))) 86 | (list "he")) 87 | 88 | (check-equal? 89 | (ann (let () 90 | (define rx (regexp "he(l*)(o*)")) 91 | (regexp-match rx "hellooo")) 92 | (U #f (List String String String))) 93 | (list "hellooo" "ll" "ooo")) 94 | 95 | (check-equal? 96 | (ann (let () 97 | (define rx "he(l*)(o*)") 98 | (regexp-match rx "helloooooooo")) 99 | (U #f (List String String String))) 100 | (list "helloooooooo" "ll" "oooooooo")) 101 | 102 | (check-equal? 103 | (ann 104 | (regexp-match "hello" "hello world") 105 | (U #f (List String))) 106 | '("hello")) 107 | 108 | (check-equal? 109 | (ann (regexp-match "\\(a+\\)([ab]*)" "(aa)bb") 110 | (U #f (List String String))) 111 | '("(aa)bb" "bb")) 112 | 113 | (check-equal? 114 | (ann 115 | (regexp-match "hello" "world") 116 | (U #f (List String))) 117 | #f) 118 | 119 | (check-equal? 120 | (ann 121 | (regexp-match "he(l*)o" "hellllloooo") 122 | (U #f (List String String))) 123 | '("helllllo" "lllll")) 124 | 125 | (check-equal? 126 | (ann 127 | (regexp-match #rx"he(l*)o" "helllooo") 128 | (U #f (List String String))) 129 | '("helllo" "lll")) 130 | 131 | (check-equal? 132 | (ann 133 | (regexp-match #rx"h(e(l*))(o)" "helllooo") 134 | (U #f (List String String String String))) 135 | '("helllo" "elll" "lll" "o")) 136 | 137 | (check-equal? 138 | (ann 139 | (regexp-match #px"h(e(l*))(o)" "helllooo") 140 | (U #f (List String String String String))) 141 | '("helllo" "elll" "lll" "o")) 142 | 143 | (check-equal? 144 | (ann 145 | (regexp-match #rx#"h(e(l*))(o)" "helllooo") 146 | (U #f (List Bytes Bytes Bytes Bytes))) 147 | '(#"helllo" #"elll" #"lll" #"o")) 148 | 149 | (check-equal? 150 | (ann 151 | (regexp-match #px#"h(e(l*))(o)" "helllooo") 152 | (U #f (List Bytes Bytes Bytes Bytes))) 153 | '(#"helllo" #"elll" #"lll" #"o"))) 154 | 155 | (test-case "higher-order" 156 | (check-equal? 157 | ((lambda ([f : (-> String String (U #f (Listof (U #f String))))]) 158 | (f "hi" "ahi tuna")) 159 | regexp-match) 160 | '("hi")) 161 | 162 | (check-exn exn:fail:contract? 163 | (lambda () 164 | ((lambda ([f : (-> String String Any)]) 165 | (f "ah(oy" "ahoy")) 166 | regexp-match)))) 167 | 168 | (test-case "regexp" 169 | (check-equal? 170 | ((lambda ([f : (-> String Regexp)]) 171 | (f "aloha")) 172 | regexp) 173 | (regexp "aloha")) 174 | 175 | (check-exn exn:fail:contract? 176 | (lambda () 177 | ((lambda ([f : (-> String Regexp)]) 178 | (f "ah(oy")) 179 | regexp)))) 180 | 181 | (test-case "pregexp" 182 | (check-equal? 183 | ((lambda ([f : (-> String PRegexp)]) 184 | (f "aloha")) 185 | pregexp) 186 | (pregexp "aloha")) 187 | 188 | (check-exn exn:fail:contract? 189 | (lambda () 190 | ((lambda ([f : (-> String PRegexp)]) 191 | (f "ah(oy")) 192 | pregexp)))) 193 | 194 | (test-case "byte-regexp" 195 | (check-true ;;bg; bug in 6.3 196 | (equal? 197 | ((lambda ([f : (-> Bytes Byte-Regexp)]) 198 | (f #"aloha")) 199 | byte-regexp) 200 | (byte-regexp #"aloha"))) 201 | 202 | (check-exn exn:fail:contract? 203 | (lambda () 204 | ((lambda ([f : (-> Bytes Byte-Regexp)]) 205 | (f #"ah(oy")) 206 | byte-regexp)))) 207 | 208 | (test-case "byte-pregexp" 209 | (check-true 210 | (equal? 211 | ((lambda ([f : (-> Bytes Byte-PRegexp)]) 212 | (f #"aloha")) 213 | byte-pregexp) 214 | (byte-pregexp #"aloha"))) 215 | 216 | (check-exn exn:fail:contract? 217 | (lambda () 218 | ((lambda ([f : (-> Bytes Byte-PRegexp)]) 219 | (f #"ah(oy")) 220 | byte-pregexp)))) 221 | 222 | (test-case "regexp:let" 223 | (check-equal? 224 | (ann 225 | (let ([rx #rx"^y(o+)lo$"]) 226 | (cond 227 | [(regexp-match rx "yolo") 228 | => (lambda ([x* : (List String String)]) 229 | (cadr x*))] 230 | ;=> cadr] 231 | [else 232 | (raise-user-error 'nope)])) 233 | String) 234 | "o") 235 | 236 | (check-equal? 237 | (ann 238 | (let ([rx1 #rx"^y(o+)lo$"] 239 | [rx2 #rx"^w(e+)pa$"] 240 | [rx3 #rx"^y(e+)rrr$"]) 241 | (cond 242 | [(regexp-match rx1 "wepa") 243 | => cadr] 244 | [(regexp-match rx2 "yolo") 245 | => cadr] 246 | [(regexp-match rx3 "yeeeeeerrr") 247 | => cadr] 248 | [else 249 | (raise-user-error 'nope)])) 250 | String) 251 | "eeeeee") 252 | 253 | (check-equal? 254 | (ann 255 | (let ([rx "\\(\\)he(l*)(o*)"]) 256 | (regexp-match rx "helllooo")) 257 | (U #f (List String String String))) 258 | #f)) 259 | 260 | (test-case "regexp:define" 261 | (check-equal? 262 | (ann 263 | (let () 264 | (define rx "\\(\\)he(l*)(o*)") 265 | (regexp-match rx "helllooo")) 266 | (U #f (List String String String))) 267 | #f) 268 | 269 | (check-equal? 270 | (ann 271 | (let () 272 | (define rx #rx"he(l*)(o*)") 273 | (regexp-match rx "helllooo")) 274 | (U #f (List String String String))) 275 | '("helllooo" "lll" "ooo")) 276 | 277 | (check-equal? 278 | (ann 279 | (let () 280 | (define rx #rx"h(?=e)(l*)(o*)") 281 | (regexp-match rx "hello")) 282 | (U #f (List String String String))) 283 | '("h" "" "")) 284 | 285 | (check-equal? 286 | (ann 287 | (let () 288 | (regexp-match (regexp "he(l*)(o*)") "hellooo")) 289 | (U #f (List String String String))) 290 | '("hellooo" "ll" "ooo")) 291 | 292 | (check-equal? 293 | (ann 294 | (let () 295 | (define rx (regexp "he(l*)(o*)")) 296 | (regexp-match rx "hellooo")) 297 | (U #f (Listof (U #f String)))) 298 | '("hellooo" "ll" "ooo")) 299 | 300 | (check-equal? 301 | (ann 302 | (let () 303 | (regexp-match (pregexp "he(l*)(o*)") "hellooo")) 304 | (U #f (List String String String))) 305 | '("hellooo" "ll" "ooo")) 306 | 307 | (check-equal? 308 | (ann 309 | (regexp-match #rx#"he(l*)(o*)" #"helllooo") 310 | (U #f (List Bytes Bytes Bytes))) 311 | '(#"helllooo" #"lll" #"ooo")) 312 | 313 | (check-equal? 314 | (ann 315 | (let () 316 | (regexp-match (byte-regexp #"he(l*)(o*)") "hellooo")) 317 | (U #f (List Bytes Bytes Bytes))) 318 | '(#"hellooo" #"ll" #"ooo")) 319 | 320 | (check-equal? 321 | (ann 322 | (regexp-match #px#"he(l*)(o*)" "helllooo") 323 | (U #f (List Bytes Bytes Bytes))) 324 | '(#"helllooo" #"lll" #"ooo")) 325 | 326 | (check-equal? 327 | (ann 328 | (let () 329 | (regexp-match (byte-pregexp #"he(l*)(o*)") "hellooo")) 330 | (U #f (List Bytes Bytes Bytes))) 331 | '(#"hellooo" #"ll" #"ooo"))) 332 | 333 | (test-case "regexp:special" 334 | (check-equal? 335 | (ann 336 | (regexp-match "((a)b)" "ab") 337 | (U #f (List String String String))) 338 | '("ab" "ab" "a"))) 339 | 340 | (test-case "regexp:|" 341 | (check-equal? 342 | (ann 343 | (regexp-match "this(group)|that" "that") 344 | (U #f (Listof (U #f String)))) 345 | '("that" #f))) 346 | 347 | (test-case "regexp:gtp" 348 | (let ([NODE_REGEXP 349 | #rx"^\\\\node *\\(([0-9]+)\\) *(\\[.*\\])? *\\{\\\\rkt\\{([0-9]+)\\}\\{(.+)\\}\\};$"]) 350 | (regexp-match NODE_REGEXP "hai") 351 | (void)) 352 | 353 | (let ([EDGE_REGEXP 354 | #rx"^\\\\draw\\[.*\\]? *\\(([0-9]+)\\)[^(]*\\(([0-9]+)\\);$"]) 355 | (regexp-match EDGE_REGEXP "bye") 356 | (void))) 357 | 358 | (test-case "regexp:return-type" 359 | (check-equal? 360 | (regexp-match #rx"hello" #"world") 361 | ;; Would be a type error if we annotated wrong 362 | #f)) 363 | 364 | (test-case "regexp:starred-group" 365 | (check-equal? 366 | (ann 367 | (regexp-match "(poo )*" "poo poo platter") 368 | (U #f (List String (U #f String)))) 369 | '("poo poo " "poo ")) 370 | 371 | (check-equal? 372 | (ann 373 | (regexp-match "([a-z ]+;)*" "lather; rinse; repeat;") 374 | (U #f (List String (U #f String)))) 375 | '("lather; rinse; repeat;" " repeat;"))) 376 | 377 | (test-case "regexp:()?" 378 | (let ([date-re (pregexp "([a-z]+) +([0-9]+,)? *([0-9]+)")]) 379 | (check-equal? 380 | (ann 381 | (regexp-match date-re "jan 1, 1970") 382 | (U #f (List String String (U #f String) String))) 383 | '("jan 1, 1970" "jan" "1," "1970")) 384 | 385 | (check-equal? 386 | (ann 387 | (regexp-match date-re "jan 1970") 388 | (U #f (List String String (U #f String) String))) 389 | '("jan 1970" "jan" #f "1970")))) 390 | 391 | (test-case "regexp:?()" 392 | (check-equal? 393 | (ann 394 | (regexp-match "^(?:[a-z]*/)*([a-z]+)$" "/usr/local/bin/mzscheme") 395 | (U #f (List String String))) 396 | '("/usr/local/bin/mzscheme" "mzscheme")) 397 | 398 | (check-equal? 399 | (ann 400 | (regexp-match #px"(?i:AloT)" "alot") 401 | (U #f (List String))) 402 | '("alot"))) 403 | 404 | (test-case "regexp:pipes-min-groups" 405 | ; -- pipes = take min groups 406 | ; 2016-06-08: currently disabled 407 | (check-equal? 408 | (ann 409 | (regexp-match "^(a*)|(b*)$" "aaa") 410 | (U #f (List String (U #f String) (U #f String)))) 411 | '("aaa" "aaa" #f)) 412 | 413 | (check-equal? 414 | (ann 415 | (regexp-match "^(aa*)(c*)|(b*)$" "b") 416 | (U #f (List String (U #f String) (U #f String) (U #f String)))) 417 | '("b" #f #f "b"))) 418 | 419 | (test-case "regexp:nested-groups" 420 | (check-equal? 421 | (ann 422 | (regexp-match "((a)b)" "abc") 423 | (U #f (List String String String))) 424 | '("ab" "ab" "a"))) 425 | 426 | (test-case "regexp:string" 427 | (let ([s0 "a*"] 428 | [s1 "b*"]) 429 | (check-equal? 430 | (ann 431 | (regexp-match (string-append "(" s0 ")" s1) "aaab") 432 | (U #f (List String String))) 433 | '("aaab" "aaa")))) 434 | ) 435 | -------------------------------------------------------------------------------- /trivial/private/sequence-domain.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Domains for Racket sequence types 4 | 5 | ;; TODO 6 | ;; - define lifted functions with contracts? to return ⊥ if pre-conditions not met 7 | ;; - vector->list homomorphism 'automatically' 8 | ;; - ⊓ should be over "lengths", not over I-dom 9 | ;; - ⊤ is already covered when these are called. Safe in general??? 10 | 11 | (provide 12 | list-domain 13 | ;; Elements are <φ1 ... φn> 14 | ;; i.e. finite sequences of proposition maps 15 | ;; Ordered by `φ*<=?` 16 | 17 | list-domain->I-dom 18 | I-dom->list-domain 19 | ;; Composing forgets the contents of φ in the list domain element 20 | 21 | vector-domain 22 | ;; Elements & order are the same as `list-domain` 23 | 24 | φ*-null? 25 | 26 | vector-domain->I-dom 27 | I-dom->vector-domain 28 | 29 | vector-domain->list-domain 30 | list-domain->vector-domain 31 | 32 | (rename-out [I->φ* make-φ*]) 33 | ;; (-> Natural X [Dom X]) 34 | ;; Make a sequence, just like `make-list` 35 | 36 | list-domain-cons 37 | list-domain-car 38 | list-domain-first 39 | list-domain-second 40 | list-domain-third 41 | list-domain-cdr 42 | list-domain-reverse 43 | 44 | list-domain-length 45 | vector-domain-length 46 | 47 | list-domain-ref 48 | vector-domain-ref 49 | 50 | list-domain-set 51 | vector-domain-set 52 | 53 | list-domain-append* 54 | vector-domain-append* 55 | 56 | list-domain-slice 57 | vector-domain-slice 58 | 59 | format-bounds-error 60 | ;; (-> Syntax Integer String) 61 | ;; (format-bounds-error stx i) 62 | ;; Make an error message that says `i` is an invalid access to the value 63 | ;; in the syntax object `stx`. 64 | 65 | format-slice-error 66 | ;; (-> Syntax Integer Integer String) 67 | ;; (format-slice-error stx lo hi) 68 | ;; Make an error message that says `[lo,hi)` is an invalid slice range. 69 | 70 | ) 71 | 72 | (require 73 | syntax/parse 74 | trivial/private/common 75 | (for-meta -1 76 | (only-in trivial/private/integer I-dom)) 77 | racket/list) 78 | 79 | ;; ============================================================================= 80 | 81 | (define (φ*<=? x* y*) 82 | (or (and (null? x*) (null? y*)) 83 | (and (not (null? x*)) 84 | (not (null? y*)) 85 | (and (φ<=? (car x*) (car y*)) 86 | (φ*<=? (cdr x*) (cdr y*)))))) 87 | 88 | (define list-domain 89 | (make-abstract-domain L #:leq φ*<=? 90 | [(~or '(e* ...) (e* ...)) 91 | (init-φ* (syntax-e #'(e* ...)))])) 92 | 93 | (define vector-domain 94 | (make-abstract-domain V #:leq φ*<=? 95 | [(~or #(e* ...) '#(e* ...)) 96 | (init-φ* (syntax-e #'(e* ...)))])) 97 | 98 | (define (init-φ* e*) 99 | (parameterize ([*STOP-LIST* #f]) 100 | (for/list ([e (in-list e*)]) 101 | (syntax-parse #`(quote #,e) 102 | [e:~> (φ #'e.~>)])))) 103 | 104 | (define (list-domain->vector-domain l) 105 | (if (⊥? list-domain l) 106 | (⊥ vector-domain) 107 | l)) 108 | 109 | (define (vector-domain->list-domain v) 110 | (if (⊥? vector-domain v) 111 | (⊥ list-domain) 112 | v)) 113 | 114 | (define (list-domain-cons φ φ*) 115 | (if (or (⊥? list-domain φ*) (⊤? list-domain φ*)) 116 | φ* 117 | (cons φ φ*))) 118 | 119 | (define (list-domain-car φ*) 120 | (if (or (⊥? list-domain φ*) (⊤? list-domain φ*)) 121 | (φ-init) 122 | (car φ*))) 123 | 124 | (define (list-domain-first φ*) 125 | (list-domain-car φ*)) 126 | 127 | (define (list-domain-second φ*) 128 | (if (or (⊥? list-domain φ*) (⊤? list-domain φ*) (< (length φ*) 2)) 129 | (φ-init) 130 | (second φ*))) 131 | 132 | (define (list-domain-third φ*) 133 | (if (or (⊥? list-domain φ*) (⊤? list-domain φ*) (< (length φ*) 3)) 134 | (φ-init) 135 | (third φ*))) 136 | 137 | (define (list-domain-reverse φ*) 138 | (if (or (⊥? list-domain φ*) (⊤? list-domain φ*)) 139 | φ* 140 | (reverse φ*))) 141 | 142 | (define (list-domain-cdr φ*) 143 | (if (or (⊥? list-domain φ*) (⊤? list-domain φ*)) 144 | φ* 145 | (cdr φ*))) 146 | 147 | (define φ*-null? 148 | null?) 149 | 150 | (define φ*? 151 | list?) 152 | 153 | (define (φ*->N φ*) 154 | (length φ*)) 155 | 156 | (define φ*-length 157 | length) 158 | 159 | (define φ*-ref 160 | list-ref) 161 | 162 | (define φ*-set 163 | list-set) 164 | 165 | (define (I->φ* n [φ #f] #:dom [dom #f]) 166 | (if (⊥? I-dom n) 167 | (⊥ (or dom list-domain)) 168 | (make-list n (or φ (φ-init))))) 169 | 170 | (define list-domain->I-dom 171 | (make-dmap list-domain φ*->N I-dom)) 172 | 173 | (define I-dom->list-domain 174 | (make-dmap I-dom I->φ* list-domain)) 175 | 176 | (define vector-domain->I-dom 177 | (make-dmap vector-domain φ*->N I-dom)) 178 | 179 | (define I-dom->vector-domain 180 | (make-dmap I-dom I->φ* vector-domain)) 181 | 182 | (define (list-domain-length φ*) 183 | (cond 184 | [(⊥? list-domain φ*) 185 | (⊥ I-dom)] 186 | [(⊤? list-domain φ*) 187 | (⊤ I-dom (⊤-msg φ*))] 188 | [else 189 | (length φ*)])) 190 | 191 | (define (vector-domain-length φ*) 192 | (cond 193 | [(⊥? vector-domain φ*) 194 | (⊥ I-dom)] 195 | [(⊤? vector-domain φ*) 196 | (⊤ I-dom (⊤-msg φ*))] 197 | [else 198 | (length φ*)])) 199 | 200 | (define (lifted-ref φ* i default) 201 | (if (and (φ*? φ*) (integer? i)) 202 | (φ*-ref φ* i) 203 | default)) 204 | 205 | (define (list-domain-ref l i) 206 | (lifted-ref l i (φ-init) 207 | ;; TODO 208 | #;(⊥ list-domain))) 209 | 210 | (define (vector-domain-ref v i) 211 | (lifted-ref v i (φ-init) 212 | #;(⊥ vector-domain))) 213 | 214 | (define (lifted-set φ* i x default) 215 | (if (and (φ*? φ*) (integer? i)) ;; x should really be a φ 216 | (φ*-set φ* i x) 217 | default)) 218 | 219 | (define (list-domain-set l i x) 220 | (lifted-set l i x (φ-init) 221 | #;(⊥ list-domain))) 222 | 223 | (define (vector-domain-set v i x) 224 | (lifted-set v i x (φ-init) 225 | #;(⊥ vector-domain))) 226 | 227 | (define (list-domain-append* φ**) 228 | (let loop ([x* φ**]) 229 | (cond 230 | [(null? x*) 231 | (append* φ**)] 232 | [(or (⊥? list-domain (car x*)) (⊤? list-domain (car x*))) 233 | (car x*)] 234 | [else 235 | (loop (cdr x*))]))) 236 | 237 | (define (vector-domain-append* φ**) 238 | (let loop ([x* φ**]) 239 | (cond 240 | [(null? x*) 241 | (append* φ**)] 242 | [(or (⊥? vector-domain (car x*)) (⊤? vector-domain (car x*))) 243 | (car x*)] 244 | [else 245 | (loop (cdr x*))]))) 246 | 247 | (define (φ*-slice φ* lo hi) 248 | (for/list ([φ (in-list φ*)] 249 | [i (in-naturals)] 250 | #:when (and (<= lo i) (< i hi))) 251 | φ)) 252 | 253 | (define (list-domain-slice φ* lo hi) 254 | (cond 255 | [(or (⊥? list-domain φ*) (⊤? list-domain φ*)) 256 | φ*] 257 | [(or (⊥? I-dom lo) (⊥? I-dom hi)) 258 | (⊥ list-domain)] 259 | [(⊤? I-dom lo) 260 | (⊤ list-domain (⊤-msg lo))] 261 | [(⊤? I-dom hi) 262 | (⊤ list-domain (⊤-msg hi))] 263 | [else 264 | (φ*-slice φ* lo hi)])) 265 | 266 | (define (vector-domain-slice φ* lo hi) 267 | (cond 268 | [(or (⊥? vector-domain φ*) (⊤? vector-domain φ*)) 269 | φ*] 270 | [(or (⊥? I-dom lo) (⊥? I-dom hi)) 271 | (⊥ vector-domain)] 272 | [(⊤? I-dom lo) 273 | (⊤ vector-domain (⊤-msg lo))] 274 | [(⊤? I-dom hi) 275 | (⊤ vector-domain (⊤-msg hi))] 276 | [else 277 | (φ*-slice φ* lo hi)])) 278 | 279 | (define (format-bounds-error stx i) 280 | (format "[~a:~a] Index '~a' out of range for '~a'" 281 | (syntax-line stx) 282 | (syntax-column stx) 283 | i 284 | (syntax->datum stx))) 285 | 286 | (define (format-slice-error stx lo hi) 287 | (format "[~a:~a] Invalid slice range [~a,~a) for '~a'" 288 | (syntax-line stx) 289 | (syntax-column stx) 290 | lo hi 291 | (syntax->datum stx))) 292 | 293 | ;; ============================================================================= 294 | 295 | (module+ test 296 | (require rackunit) 297 | 298 | (test-case "φ*<=?" 299 | (let ([φ*1 (list (φ-init))] 300 | [φ*2 (list (φ-set (φ-init) I-dom 0))] 301 | [φ*3 (list (φ-set (φ-init) I-dom 1))] 302 | [φ*4 (for/list ([i (in-range 5)]) 303 | (φ-set (φ-init) I-dom i))] 304 | [φ*5 (make-list 5 (φ-set (φ-init) I-dom 5))] 305 | [φ*6 (list (φ-set (φ-set (φ-init) I-dom 1) vector-domain '()))] 306 | [φ*7 (list (φ-set (φ-set (φ-init) I-dom 1) vector-domain (list (φ-init))))]) 307 | (check-true (φ*<=? '() '())) 308 | (check-true (φ*<=? φ*1 φ*1)) 309 | (check-true (φ*<=? φ*1 φ*2)) 310 | (check-true (φ*<=? φ*2 φ*3)) 311 | (check-true (φ*<=? φ*4 φ*5)) 312 | (check-true (φ*<=? φ*3 φ*6)) 313 | 314 | (check-false (φ*<=? '() φ*1)) 315 | (check-false (φ*<=? φ*1 '())) 316 | (check-false (φ*<=? φ*3 φ*2)) 317 | (check-false (φ*<=? φ*5 φ*4)) 318 | (check-false (φ*<=? φ*6 φ*7)) 319 | (check-false (φ*<=? φ*7 φ*1)))) 320 | 321 | (test-case "make-φ*" 322 | (define (check-make-φ* n x) 323 | (define φ* (I->φ* n x)) 324 | (check-equal? (φ*->N φ*) n) 325 | (check-equal? φ* (make-list n x))) 326 | 327 | (check-make-φ* 5 'a) 328 | (check-make-φ* 0 'b) 329 | 330 | (check-equal? (I->φ* (⊥ I-dom) #f) (⊥ list-domain))) 331 | 332 | (test-case "L->N" 333 | (let ([L->N list-domain->I-dom]) 334 | (check-equal? (L->N '()) 0) 335 | (check-equal? (L->N (list (φ-init) (φ-init))) 2) 336 | (check-equal? (L->N (⊥ list-domain)) (⊥ I-dom)))) 337 | 338 | (test-case "I->L" 339 | (let ([I->L I-dom->list-domain]) 340 | (check-equal? (I->L 0) '()) 341 | (check-equal? (I->L 3) (list (φ-init) (φ-init) (φ-init))) 342 | (check-equal? (I->L (⊥ I-dom)) (⊥ list-domain)))) 343 | 344 | (test-case "V->N" 345 | (let ([V->N vector-domain->I-dom]) 346 | (check-equal? (V->N '()) 0) 347 | (check-equal? (V->N (make-list 4 (φ-init))) 4) 348 | (check-equal? (V->N (⊥ vector-domain)) (⊥ I-dom)) 349 | (let* ([msg "dummy"] 350 | [⊤1 (⊤ vector-domain msg)] 351 | [⊤2 (⊤ I-dom msg)]) 352 | (check-equal? (⊤-msg (V->N ⊤1)) (⊤-msg ⊤2))))) 353 | 354 | (test-case "I->V" 355 | (let ([I->V I-dom->vector-domain]) 356 | (check-equal? (I->V 0) '()) 357 | (check-equal? (I->V 3) (list (φ-init) (φ-init) (φ-init))) 358 | (check-equal? (I->V (⊥ I-dom)) (⊥ vector-domain)) 359 | (let* ([msg "yolo"] 360 | [⊤1 (I->V (⊤ I-dom msg))] 361 | [⊤2 (⊤ vector-domain msg)]) 362 | (check-equal? (⊤-msg ⊤1) (⊤-msg ⊤2))))) 363 | 364 | (test-case "V<=>L" 365 | (let ([V->L vector-domain->list-domain] 366 | [L->V list-domain->vector-domain]) 367 | (check-equal? (V->L (⊥ vector-domain)) (⊥ list-domain)) 368 | (check-equal? (L->V (⊥ list-domain)) (⊥ vector-domain)))) 369 | 370 | (test-case "cons car cdr" 371 | ;; TODO 372 | ) 373 | 374 | (test-case "*-domain-length" 375 | (check-equal? (list-domain-length '(0 0 0)) 3) 376 | (check-equal? (list-domain-length (⊥ list-domain)) (⊥ I-dom)) 377 | 378 | (check-equal? (vector-domain-length '(0 0)) 2) 379 | (check-equal? (vector-domain-length (⊥ vector-domain)) (⊥ I-dom))) 380 | 381 | (test-case "*-domain-ref" 382 | (check-equal? (list-domain-ref '(1 2) 0) 1) 383 | ; TODO what is right, should be bot??? 384 | (check-equal? (list-domain-ref (⊥ list-domain) 0) (φ-init)) 385 | (check-equal? (list-domain-ref '(1) 'other-bot) (φ-init)) 386 | (check-equal? (list-domain-ref (⊤ list-domain "yo") 2) (φ-init)) 387 | 388 | (check-equal? (vector-domain-ref '(1 2) 0) 1) 389 | (check-equal? (vector-domain-ref (⊥ vector-domain) 0) (φ-init)) 390 | (check-equal? (vector-domain-ref '(1) 'other-bot) (φ-init)) 391 | (check-equal? (vector-domain-ref (⊤ vector-domain "yo") 2) (φ-init))) 392 | 393 | (test-case "*-domain-set" 394 | (check-equal? (list-domain-set '(1 2) 0 3) '(3 2)) 395 | ; TODO should be bot??? 396 | (check-equal? (list-domain-set (⊥ list-domain) 0 (φ-init)) (φ-init)) 397 | (check-equal? (list-domain-set '(1) 'other-bot (φ-init)) (φ-init)) 398 | (check-equal? (list-domain-set (⊤ list-domain "yo") 2 (φ-init)) (φ-init)) 399 | 400 | (check-equal? (vector-domain-set '(1 2) 0 8) '(8 2)) 401 | (check-equal? (vector-domain-set (⊥ vector-domain) 0 (φ-init)) (φ-init)) 402 | (check-equal? (vector-domain-set '(1) 'other-bot (φ-init)) (φ-init)) 403 | (check-equal? (vector-domain-set (⊤ vector-domain "yo") 2 (φ-init)) (φ-init))) 404 | 405 | (test-case "*-domain-append" 406 | (check-equal? (list-domain-append* '((1 2))) '(1 2)) 407 | (check-equal? (list-domain-append* '((1) (2) (3))) '(1 2 3)) 408 | (check-equal? (list-domain-append* (list (⊥ list-domain) '(2))) (⊥ list-domain)) 409 | (let ([msg (symbol->string (gensym))]) 410 | (check-equal? (⊤-msg (list-domain-append* (list (⊤ list-domain msg) '()))) msg)) 411 | 412 | (check-equal? (vector-domain-append* '((1 2) (3 4) (5))) '(1 2 3 4 5)) 413 | (check-equal? (vector-domain-append* (list (⊥ vector-domain) '())) (⊥ vector-domain)) 414 | (let ([msg "secret"]) 415 | (check-equal? (⊤-msg (vector-domain-append* (list (⊤ vector-domain msg) '() '(3 3)))) msg))) 416 | 417 | (test-case "*-domain-slice" 418 | (define (check-slice slice-op dom) 419 | (check-equal? (slice-op '(1 2) 0 0) '()) 420 | (check-equal? (slice-op '(1 2) 0 1) '(1)) 421 | (check-equal? (slice-op '(1 2) 0 2) '(1 2)) 422 | (check-equal? (slice-op '(1 2) 1 2) '(2)) 423 | (check-equal? (slice-op (⊥ dom) 0 0) (⊥ dom)) 424 | (check-equal? (slice-op '(1) (⊥ I-dom) 1) (⊥ dom)) 425 | (check-equal? (slice-op '(1) 1 (⊥ I-dom)) (⊥ dom)) 426 | (let ([msg "msg"]) 427 | (check-equal? (⊤-msg (slice-op (⊤ dom msg) 2 3)) msg) 428 | (check-equal? (⊤-msg (slice-op '() (⊤ I-dom msg) 3)) msg) 429 | (check-equal? (⊤-msg (slice-op '() 2 (⊤ I-dom msg))) msg))) 430 | 431 | (check-slice list-domain-slice list-domain) 432 | (check-slice vector-domain-slice vector-domain)) 433 | 434 | (test-case "format-bounds-error" 435 | (define (check-bounds-error stx i) 436 | (define msg (format-bounds-error stx i)) 437 | (check-regexp-match ;; has line/column 438 | (format "\\[~a:~a\\]" (syntax-line stx) (syntax-column stx)) 439 | msg) 440 | (check-regexp-match ;; has index 441 | (format " '~a' " i) 442 | msg) 443 | (check-regexp-match ;; says what's wrong 444 | "out of range" 445 | msg) 446 | (void)) ;; don't really care about syntax object 447 | 448 | (check-bounds-error #''(foo bar) 3) 449 | (check-bounds-error #'#f 8) 450 | (check-bounds-error #'4 4)) 451 | 452 | ) 453 | -------------------------------------------------------------------------------- /trivial/private/common.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; - Implements proposition environments 4 | ;; - Implements 'abstract domains' 5 | ;; - Other helpers / parameters 6 | 7 | (provide 8 | ;; --- prop. env. 9 | 10 | φ 11 | ;; (-> Syntax Phi) 12 | ;; gets the proposition map associated with its first argument 13 | 14 | ⊢ 15 | ;; (-> Syntax Phi Syntax) 16 | ;; Attach a proposition map to a syntax object 17 | 18 | φ-tbl 19 | ;; Global table associating proposition environments to `define`d identifiers 20 | ;; Very sad. 21 | 22 | φ-mutated 23 | ;; Global set of set!'d variables. 24 | ;; Also sad. 25 | 26 | φ? 27 | ;; (-> any/c boolean?) 28 | 29 | φ-init 30 | ;; (-> Phi) 31 | ;; Create an empty proposition map 32 | 33 | φ-ref 34 | ;; (-> Phi [AbstractDomain X] [Dom X]) 35 | ;; Functionally extend a proposition map with domain-specific data 36 | 37 | φ-set 38 | ;; (-> Phi [AbstractDomain X] [Dom X] Phi) 39 | ;; Functionally extend a proposition map with domain-specific data 40 | 41 | φ<=? 42 | ;; (-> Phi Phi Boolean) 43 | ;; Precision ordering on φ 44 | ;; returns #true if first argument is less precise than 2nd on all non-⊥ entries 45 | 46 | φ-join 47 | ;; (-> Phi Phi Phi) 48 | 49 | ;; --- abstract domains 50 | 51 | ;; type [AbstractDomain X] 52 | ;; represents a (flat) lattice of information X 53 | 54 | ;; type [Dom X] 55 | ;; (U X ⊤ ⊥) 56 | ;; where ⊥ and ⊤ are the bottom & top elements for the abstract domain 57 | 58 | make-abstract-domain 59 | ;; #(-> Identifier #:leq (-> X X Boolean) [Syntax -> [Dom X]] * [AbstractDomain X]) 60 | ;; Create an 'abstract domain' from: 61 | ;; - an identifier (symbol) 62 | ;; - (optional) an order relation 63 | ;; Compares pairs of "domain information", lifted to handle ⊥/⊤ 64 | ;; The default relation returns #false for every pair 65 | ;; - a sequence of syntax-parse clauses 66 | ;; Describe how to parse "domain information" from **values** 67 | ;; (Use __TODO__ to parse & propagate information from expressions) 68 | 69 | abstract-domain? 70 | 71 | in-domain? 72 | ;; (-> abstract-domain? (-> any/c boolean?)) 73 | 74 | κ 75 | ;; (-> AbstractDomain Symbol) 76 | ;; Return the key for an abstract domain 77 | 78 | ⊥ 79 | ;; (-> AbstractDomain [Dom X]) 80 | ;; Return the bottom element for an abstract domain 81 | 82 | ⊤ 83 | ;; (-> AbstractDomain String [Dom X]) 84 | ;; Convert a domain + error message to a 'top' element 85 | 86 | ⊤-msg 87 | ;; (-> [Dom X] (U #f String)) 88 | ;; Return the error message from a ⊤ value 89 | 90 | ⊥? ⊤? 91 | ;; (-> AbstractDomain [Dom X] Boolean) 92 | ;; Return #true if the argument represents the bot/top element of the given dom. 93 | 94 | ⊓ 95 | ;; (-> AbstractDomain [Dom X] ... [Dom X]) 96 | ;; Greatest lower-bound for a domain 97 | 98 | ⊓* 99 | ;; (-> AbstractDomain [Listof [Dom X]] [Dom X]) 100 | 101 | ⊔ 102 | ;; (-> AbstractDomain [Dom X] ... [Dom X]) 103 | ;; Least upper-bound for a domain 104 | 105 | ⊔* 106 | ;; (-> AbstractDomain [Listof [Dom X]] [Dom X]) 107 | 108 | reduce 109 | ;; (-> AbstractDomain [X X -> X] X [Dom X] ... [Dom X]) 110 | 111 | reduce* 112 | ;; (-> AbstractDomain [X X -> X] X [Listof [Dom X]] [Dom X]) 113 | 114 | make-dmap 115 | ;; (-> AbstractDomain [X -> Y] AbstractDomain (-> [Dom X] [Dom Y])) 116 | ;; Lift a function to a ⊥/⊤-preserving map between domains 117 | 118 | ~> 119 | ;; Syntax class, 120 | ;; fully expand the argument, 121 | ;; store the result in the ~> property 122 | 123 | make-lifted-function 124 | ;; #(-> (-> [Dom X] [Dom X]) [AbstractDomain X] (-> Syntax Syntax)) 125 | ;; Input: 126 | ;; - F : name of a function (arity 1 only) 127 | ;; - D : domain of interest 128 | ;; Returns a 'lifted' version of F 129 | ;; that propagates values in D (statically) 130 | ;; by applying F at phase 1 131 | 132 | ;; --- utils 133 | 134 | *STOP-LIST* 135 | ;; (Parameterof (Listof Identifier)) 136 | ;; Sets the stop-list to use during `local-expand` 137 | 138 | ttt-logger 139 | log-ttt-fatal 140 | log-ttt-error 141 | log-ttt-warning 142 | log-ttt-info 143 | log-ttt-debug 144 | 145 | log-ttt-infer+ 146 | log-ttt-infer- 147 | log-ttt-check+ 148 | log-ttt-check- 149 | ;; (-> Symbol Syntax Log) 150 | ;; Helpers for logging optimization HITs and MISSes 151 | ;; - infer+ : got interpolant from program 152 | ;; - infer- : failed to infer interpolant 153 | ;; - check+ : transformed, using interpolant 154 | ;; - check- : tried to transform, but missing interpolant 155 | 156 | ;; -------------------------------------------------------------------------- 157 | ;; -- inlining 158 | ok-to-unfold? 159 | ) 160 | 161 | ;; ----------------------------------------------------------------------------- 162 | 163 | (require 164 | syntax/id-table 165 | syntax/id-set 166 | syntax/parse 167 | (for-syntax racket/base syntax/parse)) 168 | 169 | ;; ============================================================================= 170 | 171 | (define *STOP-LIST* (make-parameter '())) 172 | (define *abstract-domains* (make-parameter '())) 173 | 174 | (define-logger ttt) 175 | 176 | (define-syntax-rule (log-ttt-optimization sym stx type) 177 | (log-ttt-info "[~a:~a:~a] ~a '~a' in '~a'" 178 | (syntax-source stx) 179 | (syntax-line stx) 180 | (syntax-column stx) 181 | type 182 | sym 183 | (syntax->datum stx))) 184 | 185 | (define-syntax-rule (log-ttt-infer+ sym stx) 186 | (log-ttt-optimization sym stx 'INFER+)) 187 | 188 | (define-syntax-rule (log-ttt-infer- sym stx) 189 | (log-ttt-optimization sym stx 'INFER-)) 190 | 191 | (define-syntax-rule (log-ttt-check+ sym stx) 192 | (log-ttt-optimization sym stx 'CHECK+)) 193 | 194 | (define-syntax-rule (log-ttt-check- sym stx) 195 | (log-ttt-optimization sym stx 'CHECK-)) 196 | 197 | ;; ============================================================================= 198 | 199 | (define φ-key 200 | (gensym 'φ)) 201 | 202 | (define φ-tbl 203 | (make-free-id-table)) 204 | 205 | (define φ-mutated 206 | (mutable-free-id-set)) 207 | 208 | (define (φ stx) 209 | (or (if (identifier? stx) 210 | (and (not (free-id-set-member? φ-mutated stx)) 211 | (or (free-id-table-ref φ-tbl stx #f) 212 | #;(for/first (((k v) (in-free-id-table φ-tbl)) 213 | #:when (free-identifier=? stx k)) 214 | ;; brute-force lookup, see https://github.com/bennn/trivial/issues/52 215 | v) 216 | (syntax-property stx φ-key))) 217 | (syntax-property stx φ-key)) 218 | (φ-init))) 219 | 220 | (define (⊢ stx new-φ) 221 | (syntax-property stx φ-key new-φ)) 222 | 223 | (define (φ? x) 224 | (and (hash? x) 225 | (hash-eq? x))) 226 | 227 | (define (φ-init) 228 | (hasheq)) 229 | 230 | (define (φ-ref φ d) 231 | (hash-ref φ (κ d) (⊥ d))) 232 | 233 | (define (φ-set φ d v) 234 | (hash-set φ (κ d) v)) 235 | 236 | (define (φ<=? φ1 φ2) 237 | (for/and ([(k v) (in-hash φ1)]) 238 | (define D (κ->abstract-domain k)) 239 | (define ⊑/D (abstract-domain-⊑ D)) 240 | (define ⊥/D (abstract-domain-⊥ D)) 241 | (⊑/D v (hash-ref φ2 k ⊥/D)))) 242 | 243 | (define (φ-join φ1 φ2) 244 | ;; TODO do better! 245 | (cond 246 | [(equal? φ1 (φ-init)) 247 | φ2] 248 | [else 249 | φ1])) 250 | 251 | ;; ============================================================================= 252 | 253 | (define-syntax (make-abstract-domain stx) 254 | (syntax-parse stx 255 | [(_ key 256 | (~optional (~seq #:leq maybe-leq) #:defaults ([maybe-leq #'#f])) 257 | clause* ...) 258 | (quasisyntax/loc stx 259 | (let* ([bot '#,(gensym (string->symbol (format "~a-⊥" (syntax-e #'key))))] 260 | [top '#,(gensym (string->symbol (format "~a-⊤" (syntax-e #'key))))] 261 | [α (syntax-parser clause* ... [_ bot])] 262 | [leq (or maybe-leq (λ (v1 v2) #f))] 263 | [⊑ (λ (v1 v2) 264 | (or (eq? v1 bot) 265 | (and (top/reason? v2) (eq? (top/reason-top v2) top)) 266 | (if (or (and (top/reason? v1) (eq? (top/reason-top v1) top)) 267 | (eq? v2 bot)) 268 | #false 269 | (leq v1 v2))))] 270 | [D (abstract-domain 'key bot top α ⊑)]) 271 | (*abstract-domains* (cons D (*abstract-domains*))) 272 | D))])) 273 | 274 | (struct abstract-domain [ 275 | κ 276 | ;; key to distinguish this domain in a proposition map 277 | 278 | ⊥ ⊤ 279 | ;; [Dom X] 280 | ;; distinguished elements 281 | 282 | α 283 | ;; (-> Syntax [Dom X]) 284 | ;; return the "datum processor" for a Dom 285 | ;; parses values and returns an element in [Dom X], 286 | ;; ideally a value but maybe also an "I don't know" or an "impossible" 287 | 288 | ⊑ 289 | ;; (-> [Dom X] Dom TODO) 290 | ]) 291 | 292 | ;; TODO better name 293 | (struct top/reason ( 294 | top ;; Symbol, the top element for a given domain 295 | msg ;; String, an error message 296 | ) #:prefab) 297 | 298 | (define (in-domain? d) 299 | ;; TODO implement me! 300 | (λ (x) #true)) 301 | 302 | (define (κ d) 303 | (abstract-domain-κ d)) 304 | 305 | (define (κ->abstract-domain k) 306 | (define D 307 | (for/first ([d (in-list (*abstract-domains*))] 308 | #:when (eq? k (abstract-domain-κ d))) 309 | d)) 310 | (if D D (error 'κ->abstract-domain "invalid key ~a" k))) 311 | 312 | (define (⊥ d) 313 | (abstract-domain-⊥ d)) 314 | 315 | (define (⊤ d message) 316 | (define top (abstract-domain-⊤ d)) 317 | (top/reason top message)) 318 | 319 | (define (⊤-msg v) 320 | (if (top/reason? v) 321 | (top/reason-msg v) 322 | (raise-argument-error '⊤/reason "⊤ element" v))) 323 | 324 | (define (⊥? d v) 325 | (and (symbol? v) 326 | (eq? (abstract-domain-⊥ d) v))) 327 | 328 | (define (⊤? d v) 329 | (and (top/reason? v) 330 | (eq? (abstract-domain-⊤ d) (top/reason-top v)))) 331 | 332 | (define (⊓ d . v*) 333 | (⊓* d v*)) 334 | 335 | (define (⊓* d v*) 336 | (define ⊥/d (abstract-domain-⊥ d)) 337 | (define ⊤/d (⊤ d "glb")) 338 | (define ⊑/d (abstract-domain-⊑ d)) 339 | (for/fold ([v1 ⊤/d]) 340 | ([v2 (in-list v*)]) 341 | (cond 342 | [(⊑/d v1 v2) v1] 343 | [(⊑/d v2 v1) v2] 344 | [else ⊥/d]))) 345 | 346 | (define (⊔ d . v*) 347 | (⊔* d v*)) 348 | 349 | (define (⊔* d v*) 350 | (define ⊥/d (abstract-domain-⊥ d)) 351 | (define ⊤/d (⊤ d "lub")) 352 | (define ⊑/d (abstract-domain-⊑ d)) 353 | (for/fold ([v1 ⊥/d]) 354 | ([v2 (in-list v*)]) 355 | (cond 356 | [(⊑/d v1 v2) v2] 357 | [(⊑/d v2 v1) v1] 358 | [else ⊤/d]))) 359 | 360 | (define (reduce D f init . v*) 361 | (reduce* D f init v*)) 362 | 363 | (define (reduce* D f init v*) 364 | (if (⊥? D init) 365 | init 366 | (let loop ([acc init] 367 | [v* v*]) 368 | (cond 369 | [(null? v*) 370 | acc] 371 | [else 372 | (let ([v (car v*)] 373 | [v* (cdr v*)]) 374 | (if (or (⊥? D v) (⊤? D v)) 375 | v 376 | (loop (f acc v) v*)))])))) 377 | 378 | (define (make-dmap d1 f d2) 379 | (λ (d1-elem) 380 | (cond 381 | [(⊥? d1 d1-elem) 382 | (⊥ d2)] 383 | [(⊤? d1 d1-elem) 384 | (⊤ d2 (⊤-msg d1-elem))] 385 | [else 386 | (f d1-elem)]))) 387 | 388 | ;; ============================================================================= 389 | 390 | (define (expand-expr stx) 391 | (expand-datum (local-expand stx 'expression (*STOP-LIST*)))) 392 | 393 | (define (expand-datum stx) 394 | (syntax-parse stx 395 | [((~datum quote) v) 396 | (log-ttt-warning "expanding #%datum ~a" (syntax->datum stx)) 397 | (define φ 398 | (for/fold ([φ (φ-init)]) 399 | ([d (in-list (*abstract-domains*))]) 400 | (φ-set φ d ((abstract-domain-α d) #'v)))) 401 | (⊢ stx φ)] 402 | ;; TODO 2016-10-30 : replace variables with their exact value 403 | [_ 404 | stx])) 405 | 406 | (define-syntax-class ~> 407 | #:attributes (~>) 408 | (pattern e 409 | #:attr ~> (expand-expr #'e))) 410 | 411 | ;; TODO should really declare this as a type, using [Dom X] 412 | (define-syntax-rule (make-lifted-function fn dom) 413 | (λ (stx) 414 | (syntax-parse stx 415 | [(_ e:~>) 416 | (define φ-e (φ #'e.~>)) 417 | (define v (φ-ref φ-e dom)) 418 | (cond 419 | [(⊤? dom v) 420 | (raise-user-error 'fn (⊤-msg v))] 421 | [else 422 | (⊢ (syntax/loc stx (fn e.~>)) 423 | (if (⊥? dom v) φ-e (φ-set φ-e dom (fn v))))])] 424 | [(_ . e*) 425 | (syntax/loc stx (fn . e*))] 426 | [_:id 427 | (syntax/loc stx fn)]))) 428 | 429 | ;; ----------------------------------------------------------------------------- 430 | 431 | (define-syntax-rule (ttt-log stx msg arg* ...) 432 | (begin (printf "[LOG:~a:~a] " (syntax-line stx) (syntax-column stx)) (printf msg arg* ...) (newline))) 433 | 434 | ;; Is `v` a small enough integer to unfold an operation using `v`? 435 | ;; e.g., okay to convert `(expt X v)` to `(* X ...v )` 436 | (define (ok-to-unfold? v) 437 | (<= 0 v 20)) 438 | 439 | ;; ============================================================================= 440 | 441 | (module+ test 442 | (require rackunit) 443 | 444 | (define (gen-abstract-domain) 445 | (let ([k (gensym)] 446 | [bot (gensym)] 447 | [top (gensym)]) 448 | (abstract-domain k bot top (λ (stx) bot) (λ (v1 v2) #f)))) 449 | 450 | (define flat-N 451 | (make-abstract-domain flat-N #:leq = 452 | [i:nat (syntax-e #'i)])) 453 | 454 | (define vert-N 455 | (make-abstract-domain vert-N #:leq <= 456 | [i:nat (syntax-e #'i)])) 457 | 458 | 459 | (test-case "φ" 460 | (check-equal? (φ #'#f) (φ-init)) 461 | (check-equal? (φ #'map) (φ-init)) 462 | (check-equal? (φ (syntax-property #'#f φ-key 'val)) 'val)) 463 | 464 | (test-case "⊢" 465 | (let ([stx #'#t] 466 | [val 'val]) 467 | (check-equal? (φ (syntax-property stx φ-key val)) (φ (⊢ stx val))))) 468 | 469 | (test-case "φ?" 470 | (check-true (φ? (φ-init))) 471 | (check-true (φ? (φ-set (φ-init) (gen-abstract-domain) 'v))) 472 | 473 | (check-false (φ? #f)) 474 | (check-false (φ? #'#f)) 475 | (check-false (φ? '()))) 476 | 477 | (test-case "φ-ref" 478 | (let* ([k (gensym)] 479 | [v (gensym)] 480 | [d (abstract-domain k 'bot 'top (λ (stx) 'bot) =)]) 481 | (check-equal? (φ-ref (φ-set (φ-init) d v) d) v))) 482 | 483 | (test-case "φ<=?" 484 | (let* ([φ0 (φ-init)] 485 | [d1 (gen-abstract-domain)] 486 | [v1 (gensym 'v)] 487 | [φ1 (φ-set φ0 d1 v1)] 488 | [d2 (gen-abstract-domain)] 489 | [v2 (gensym 'v)] 490 | [φ2 (φ-set φ1 d2 v2)] 491 | [d3 (let ([k (gensym)] 492 | [bot (gensym)] 493 | [top (gensym)]) 494 | (abstract-domain k bot top (λ (stx) bot) <=))] 495 | [φ3 (φ-set φ0 d3 10)] 496 | [φ4 (φ-set φ0 d3 44)]) 497 | (parameterize ([*abstract-domains* (list d1 d2 d3)]) 498 | (check-true (φ<=? φ0 φ0)) 499 | (check-true (φ<=? φ0 φ1)) 500 | (check-true (φ<=? φ0 φ2)) 501 | (check-true (φ<=? φ3 φ4)) 502 | 503 | (check-false (φ<=? φ1 φ2)) ;; because ⊑ always returns #f 504 | (check-false (φ<=? φ1 φ0)) 505 | (check-false (φ<=? φ2 φ3))))) 506 | 507 | (test-case "κ ⊥ ⊤" 508 | (let* ([key (gensym)] 509 | [d (abstract-domain key 'bot 'top (λ (stx) 'bot) =)]) 510 | (check-equal? (κ d) key)) 511 | 512 | (let* ([bot (gensym)] 513 | [d (abstract-domain 'key bot 'top (λ (stx) 'bot) =)]) 514 | (check-equal? (⊥ d) bot)) 515 | 516 | (let* ([top (gensym)] 517 | [msg "hello"] 518 | [d (abstract-domain 'key 'bot top (λ (stx) 'bot) =)]) 519 | (check-equal? (⊤-msg (⊤ d msg)) msg))) 520 | 521 | (test-case "κ->abstract-domain" 522 | (define (check-failure f) 523 | (check-exn #rx"invalid key" f)) 524 | 525 | (check-failure 526 | (λ () (κ->abstract-domain 'xyz))) 527 | 528 | (parameterize ([*abstract-domains* (list (gen-abstract-domain))]) 529 | (check-failure 530 | (λ () (κ->abstract-domain 'xyz)))) 531 | 532 | (let ([d (gen-abstract-domain)]) 533 | (parameterize ([*abstract-domains* (list d)]) 534 | (check-equal? (κ->abstract-domain (abstract-domain-κ d)) d)))) 535 | 536 | (test-case "⊥? ⊤?" 537 | (let ([d (gen-abstract-domain)]) 538 | (check-true (⊥? d (⊥ d))) 539 | (check-true (⊤? d (⊤ d "hey"))) 540 | 541 | (check-false (⊥? d (⊤ d "hey"))) 542 | (check-false (⊤? d (⊥ d))) 543 | (check-false (⊤? d (abstract-domain-⊤ d))) ;; this is intentional 544 | (check-false (⊥? d #f)) 545 | (check-false (⊤? d #f)))) 546 | 547 | (test-case "⊓ ⊔ reduce" 548 | (check-equal? (⊓ vert-N 1 2 3) 1) 549 | (check-equal? (⊓ vert-N 1 1) 1) 550 | (check-equal? (⊓ vert-N 9 8 (⊥ vert-N)) (⊥ vert-N)) 551 | (check-equal? (⊓ vert-N (⊤ vert-N "hi") 4) 4) 552 | 553 | (check-equal? (⊓ flat-N 1 2 3) (⊥ flat-N)) 554 | (check-equal? (⊓ flat-N 1 1) 1) 555 | (check-equal? (⊓ flat-N (⊥ flat-N) (⊥ flat-N) (⊥ flat-N)) (⊥ flat-N)) 556 | (check-equal? (⊓ flat-N (⊤ flat-N "hi") 4) 4) 557 | 558 | (check-equal? (⊔ vert-N 1 2 3) 3) 559 | (check-equal? (⊔ vert-N 1 1) 1) 560 | (check-equal? (⊔ vert-N 9 8 (⊥ vert-N)) 9) 561 | (check-true (⊤? vert-N (⊔ vert-N (⊤ vert-N "oops")))) 562 | 563 | (check-true (⊤? flat-N (⊔ flat-N 1 2 3))) 564 | (check-equal? (⊔ flat-N 1 1) 1) 565 | (check-true (⊤? flat-N (⊔ flat-N (⊤ flat-N "a") 2))) 566 | 567 | (check-equal? (reduce flat-N + 1 2 3) 6) 568 | (check-equal? (reduce vert-N * 1 2 3 4) 24)) 569 | 570 | (test-case "dmap" 571 | (let ([f (make-dmap flat-N add1 vert-N)] 572 | [g (make-dmap vert-N add1 flat-N)]) 573 | (check-equal? (f (⊥ flat-N)) (⊥ vert-N)) 574 | (check-equal? (g (⊥ vert-N)) (⊥ flat-N)) 575 | (check-equal? (f 1) 2) 576 | (check-equal? (g 2) 3))) 577 | 578 | (test-case "expand-datum" 579 | (check-true (syntax-e (expand-datum #'#t))) 580 | (check-equal? (syntax-e (expand-datum #'2)) 2) 581 | (check-equal? (φ (expand-datum #'2)) (φ-init)) 582 | (parameterize ([*abstract-domains* (list flat-N)]) 583 | (check-equal? (φ-ref (φ (expand-datum #''2)) flat-N) 2))) 584 | 585 | (test-case "ok-to-unfold?" 586 | (check-true (ok-to-unfold? 0)) 587 | 588 | (check-false (ok-to-unfold? (expt 10 5)))) 589 | ) 590 | --------------------------------------------------------------------------------