├── .gitignore ├── toolbox-db-x86_64-linux ├── info.rkt ├── toolbox │ └── db │ │ ├── libsqlite3.so.0 │ │ └── info.rkt └── README.md ├── toolbox-doc ├── scribblings │ ├── info.rkt │ ├── toolbox │ │ ├── draw.scrbl │ │ ├── web.scrbl │ │ ├── format.scrbl │ │ ├── syntax.scrbl │ │ ├── draw │ │ │ ├── color.scrbl │ │ │ └── pict.scrbl │ │ ├── data.scrbl │ │ ├── private │ │ │ └── common.rkt │ │ ├── logging.scrbl │ │ └── db.scrbl │ └── toolbox.scrbl └── info.rkt ├── toolbox-lib ├── toolbox │ ├── logger.rkt │ ├── boolean.rkt │ ├── private │ │ └── logger.rkt │ ├── lift.rkt │ ├── gregor.rkt │ ├── string.rkt │ ├── who.rkt │ ├── box.rkt │ ├── printing-block.rkt │ ├── lazy-require.rkt │ ├── list.rkt │ ├── format.rkt │ └── logging.rkt └── info.rkt ├── toolbox-web-lib ├── info.rkt └── toolbox │ └── web │ └── dispatch.rkt ├── toolbox-db-lib ├── info.rkt └── toolbox │ └── db │ ├── sqlite3.rkt │ ├── base.rkt │ ├── private │ ├── sqlite3 │ │ ├── ffi.rkt │ │ └── explain.rkt │ ├── base.rkt │ └── query.rkt │ ├── sql.rkt │ └── define.rkt ├── toolbox-draw-lib ├── info.rkt └── toolbox │ ├── pict.rkt │ ├── color.rkt │ └── pict │ └── base.rkt ├── LICENSE ├── README.md └── .github └── workflows └── build.yml /.gitignore: -------------------------------------------------------------------------------- 1 | /build/ 2 | compiled/ 3 | doc/ 4 | *~ 5 | -------------------------------------------------------------------------------- /toolbox-db-x86_64-linux/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection 'multi) 4 | (define deps '("base")) 5 | -------------------------------------------------------------------------------- /toolbox-doc/scribblings/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define scribblings 4 | '(["toolbox.scrbl" (multi-page)])) 5 | -------------------------------------------------------------------------------- /toolbox-lib/toolbox/logger.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "private/logger.rkt") 4 | 5 | (provide toolbox-logger) 6 | -------------------------------------------------------------------------------- /toolbox-lib/toolbox/boolean.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide ->boolean) 4 | 5 | (define (->boolean v) 6 | (and v #t)) 7 | -------------------------------------------------------------------------------- /toolbox-db-x86_64-linux/toolbox/db/libsqlite3.so.0: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lexi-lambda/racket-toolbox/HEAD/toolbox-db-x86_64-linux/toolbox/db/libsqlite3.so.0 -------------------------------------------------------------------------------- /toolbox-db-x86_64-linux/toolbox/db/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define install-platform #px"^x86_64-linux") 4 | (define copy-foreign-libs '("libsqlite3.so.0")) 5 | -------------------------------------------------------------------------------- /toolbox-lib/toolbox/private/logger.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "../logging.rkt") 4 | 5 | (provide (logger-out toolbox) 6 | define-toolbox-logger) 7 | 8 | (define-root-logger toolbox) 9 | -------------------------------------------------------------------------------- /toolbox-doc/scribblings/toolbox/draw.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @title[#:tag "draw" #:style 'toc]{Drawing} 4 | 5 | @local-table-of-contents[] 6 | 7 | @include-section["draw/color.scrbl"] 8 | @include-section["draw/pict.scrbl"] 9 | -------------------------------------------------------------------------------- /toolbox-web-lib/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define version "1.0") 4 | (define license 'ISC) 5 | 6 | (define collection 'multi) 7 | 8 | (define deps 9 | '("base" 10 | "web-server-lib")) 11 | (define build-deps 12 | '()) 13 | -------------------------------------------------------------------------------- /toolbox-db-x86_64-linux/README.md: -------------------------------------------------------------------------------- 1 | # toolbox-db-x86_64-linux 2 | 3 | This package provides a version of `libsqlite3.so` built with `SQLITE_ENABLE_STMT_SCANSTATUS`, which allows `query` and related functions from `toolbox/db/base` to report query plans. 4 | -------------------------------------------------------------------------------- /toolbox-lib/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define version "1.0") 4 | (define license 'ISC) 5 | 6 | (define collection 'multi) 7 | 8 | (define deps 9 | '("base" 10 | "gregor-lib" 11 | "mvar-lib")) 12 | (define build-deps 13 | '()) 14 | -------------------------------------------------------------------------------- /toolbox-db-lib/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define version "1.0") 4 | (define license 'ISC) 5 | 6 | (define collection 'multi) 7 | 8 | (define deps 9 | '("base" 10 | ["db-lib" #:version "1.10"] 11 | "gregor-lib" 12 | "threading-lib" 13 | ["toolbox-lib" #:version "1.0"])) 14 | (define build-deps 15 | '()) 16 | -------------------------------------------------------------------------------- /toolbox-draw-lib/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define version "1.0") 4 | (define license 'ISC) 5 | 6 | (define collection 'multi) 7 | 8 | (define deps 9 | '("base" 10 | "draw-lib" 11 | "pict-lib" 12 | "ppict" 13 | "threading-lib" 14 | ["toolbox-lib" #:version "1.0"])) 15 | (define build-deps 16 | '()) 17 | -------------------------------------------------------------------------------- /toolbox-draw-lib/toolbox/pict.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/require 4 | (subtract-in pict "pict/base.rkt") 5 | pict/conditional 6 | ppict/tag 7 | "pict/base.rkt") 8 | 9 | (provide (all-from-out pict 10 | pict/conditional 11 | ppict/tag 12 | "pict/base.rkt")) 13 | -------------------------------------------------------------------------------- /toolbox-lib/toolbox/lift.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base 4 | syntax/parse 5 | syntax/transformer)) 6 | 7 | (provide #%lift) 8 | 9 | (define-syntax #%lift 10 | (make-expression-transformer 11 | (syntax-parser 12 | [(_ e:expr) 13 | (syntax-local-lift-expression 14 | ;; Force expansion to work around racket/racket#4614. 15 | (local-expand #'e 'expression '()))]))) 16 | -------------------------------------------------------------------------------- /toolbox-doc/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define version "1.0") 4 | (define license 'ISC) 5 | 6 | (define collection 'multi) 7 | 8 | (define deps 9 | '("base")) 10 | (define build-deps 11 | '("db-doc" 12 | "db-lib" 13 | "draw-doc" 14 | "draw-lib" 15 | "gregor-doc" 16 | "gregor-lib" 17 | "pict-doc" 18 | "pict-lib" 19 | "ppict" 20 | "racket-doc" 21 | "scribble-doc" 22 | "scribble-lib" 23 | ["toolbox-db-lib" #:version "1.0"] 24 | ["toolbox-draw-lib" #:version "1.0"] 25 | ["toolbox-lib" #:version "1.0"] 26 | ["toolbox-web-lib" #:version "1.0"] 27 | "web-server-doc" 28 | "web-server-lib")) 29 | -------------------------------------------------------------------------------- /toolbox-lib/toolbox/gregor.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require gregor 4 | racket/contract) 5 | 6 | (provide UTC 7 | (contract-out 8 | [posix->moment/utc (-> rational? moment?)] 9 | [jd->moment (->* [rational?] [tz/c] moment?)] 10 | [jd->moment/utc (-> rational? moment?)])) 11 | 12 | ;; ----------------------------------------------------------------------------- 13 | 14 | (define (posix->moment/utc v) 15 | (posix->moment v UTC)) 16 | 17 | (define (jd->moment/utc v) 18 | (with-timezone (jd->datetime v) UTC)) 19 | 20 | (define (jd->moment v [tz (current-timezone)]) 21 | (adjust-timezone (jd->moment/utc v) tz)) 22 | -------------------------------------------------------------------------------- /toolbox-lib/toolbox/string.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base) 4 | syntax/parse/define) 5 | 6 | (provide when/string unless/string) 7 | 8 | ;; ----------------------------------------------------------------------------- 9 | 10 | (define-syntax-parse-rule (when/string cond-e:expr body ...+) 11 | #:with {~var body-e (expr/c #'string? #:name "body")} 12 | (syntax/loc this-syntax 13 | (let () body ...)) 14 | (if cond-e body-e.c "")) 15 | 16 | (define-syntax-parse-rule (unless/string cond-e:expr body ...+) 17 | #:with {~var body-e (expr/c #'string? #:name "body")} 18 | (syntax/loc this-syntax 19 | (let () body ...)) 20 | (if cond-e "" body-e.c)) 21 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | ISC License 2 | 3 | Copyright (c) 2024, Alexis King 4 | 5 | Permission to use, copy, modify, and/or distribute this software 6 | for any purpose with or without fee is hereby granted, provided 7 | that the above copyright notice and this permission notice appear 8 | in all copies. 9 | 10 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL 11 | WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED 12 | WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE 13 | AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 14 | DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA 15 | OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 16 | TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR 17 | PERFORMANCE OF THIS SOFTWARE. 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # toolbox [![Build Status](https://github.com/lexi-lambda/racket-toolbox/actions/workflows/build.yml/badge.svg?branch=master)](https://github.com/lexi-lambda/racket-toolbox/actions/workflows/build.yml) [![Scribble Docs](https://img.shields.io/badge/docs-built-blue)][toolbox-doc] 2 | 3 | This library provides a collection of miscellaneous Racket utilities that I use in my personal projects but I have not felt warrant being published as a separate package. Note that this library is intentionally *not* published on the Racket package server, as **everything in this library should be considered unstable**. In projects that use it, I include this repository as a Git submodule, pinning to a specific version. 4 | 5 | [For more information, see the documentation.][toolbox-doc] 6 | 7 | [toolbox-doc]: https://lexi-lambda.github.io/racket-toolbox/ 8 | -------------------------------------------------------------------------------- /toolbox-doc/scribblings/toolbox/web.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require "private/common.rkt") 4 | 5 | @title[#:tag "web"]{Web} 6 | 7 | @section[#:tag "web:dispatch"]{Dispatch} 8 | @defmodule[toolbox/web/dispatch] 9 | 10 | @defform[(define-enum-bidi-match-expander id syms-expr) 11 | #:contracts ([syms-expr (listof symbol?)])]{ 12 | Binds @racket[id] as a @tech[#:doc '(lib "web-server/scribblings/web-server.scrbl")]{bi-directional match expander} like @racket[symbol-arg], but additionally constrained to be one of the symbols in the list produced by @racket[syms-expr]. 13 | 14 | @(toolbox-examples 15 | (define-enum-bidi-match-expander language-arg '(racket rhombus)) 16 | (eval:check (match "racket" [(language-arg l) l]) 'racket) 17 | (eval:check (match "rhombus" [(language-arg l) l]) 'rhombus) 18 | (eval:error (match "cheesecake" [(language-arg l) l])))} 19 | -------------------------------------------------------------------------------- /toolbox-db-lib/toolbox/db/sqlite3.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require gregor 4 | racket/contract 5 | racket/match 6 | "private/sqlite3/ffi.rkt") 7 | 8 | (provide (contract-out 9 | [sqlite3-stmt-scanstatus-enabled? (-> boolean?)] 10 | 11 | [boolean->integer (-> any/c (or/c 0 1))] 12 | [integer->boolean (-> (or/c 0 1) boolean?)] 13 | 14 | [->posix/integer (-> datetime-provider? exact-integer?)] 15 | [->jd/double (-> datetime-provider? (and/c rational? flonum?))])) 16 | 17 | ;; ----------------------------------------------------------------------------- 18 | 19 | (define (boolean->integer v) 20 | (if v 1 0)) 21 | 22 | (define (integer->boolean v) 23 | (match v [0 #f] [1 #t])) 24 | 25 | (define (->posix/integer v) 26 | (floor (->posix v))) 27 | 28 | (define (->jd/double v) 29 | (real->double-flonum (->jd v))) 30 | -------------------------------------------------------------------------------- /toolbox-lib/toolbox/who.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base 4 | syntax/parse/lib/function-header 5 | syntax/transformer) 6 | racket/splicing 7 | racket/stxparam 8 | syntax/parse/define) 9 | 10 | (provide who define/who) 11 | 12 | (define-syntax-parameter who 13 | (λ (stx) 14 | (raise-syntax-error #f "used out of context" stx))) 15 | 16 | (define-syntax-parser define/who 17 | [(_ name:id rhs:expr) 18 | (syntax/loc this-syntax 19 | (define name 20 | (syntax-parameterize ([who (make-variable-like-transformer (quote-syntax 'name))]) 21 | (#%expression rhs))))] 22 | [(_ header:function-header body ...) 23 | #`(splicing-syntax-parameterize ([who (make-variable-like-transformer (quote-syntax 'header.name))]) 24 | #,(syntax/loc this-syntax 25 | (define header body ...)))]) 26 | -------------------------------------------------------------------------------- /toolbox-lib/toolbox/box.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract) 4 | 5 | (provide (contract-out 6 | [box-cas-update! (-> cas-box/c (-> any/c any/c) any/c)] 7 | [box-cas-update!* (-> cas-box/c (-> any/c (values any/c any/c)) any/c)] 8 | [box-add1! (-> cas-box/c number?)] 9 | [box-sub1! (-> cas-box/c number?)])) 10 | 11 | ;; ----------------------------------------------------------------------------- 12 | 13 | (define cas-box/c (and/c box? (not/c immutable?) (not/c impersonator?))) 14 | 15 | (define (box-cas-update!* b f) 16 | (let retry () 17 | (define old (unbox b)) 18 | (define-values [result new] (f old)) 19 | (if (box-cas! b old new) 20 | result 21 | (retry)))) 22 | 23 | (define (box-cas-update! b f) 24 | (box-cas-update!* b (λ (old) 25 | (define new (f old)) 26 | (values new new)))) 27 | 28 | (define (box-add1! b) 29 | (box-cas-update! b add1)) 30 | (define (box-sub1! b) 31 | (box-cas-update! b sub1)) 32 | -------------------------------------------------------------------------------- /toolbox-lib/toolbox/printing-block.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base 4 | syntax/kerncase) 5 | syntax/parse/define) 6 | 7 | (provide printing-block) 8 | 9 | (define-syntax-parser printing-block 10 | [(_ form ...+) 11 | (cond 12 | [(eq? (syntax-local-context) 'expression) 13 | (syntax/loc this-syntax 14 | (let () 15 | (do-printing-block form) ...))] 16 | [else 17 | #`(#%expression #,this-syntax)])]) 18 | 19 | (define-syntax-parser do-printing-block 20 | [(_ form) 21 | (syntax-parse (local-expand #'form 22 | (syntax-local-context) 23 | (kernel-form-identifier-list)) 24 | #:literal-sets [kernel-literals] 25 | [(begin form ...) 26 | #'(begin (do-printing-block form) ...)] 27 | [({~or* define-values define-syntaxes} . _) 28 | this-syntax] 29 | [expr 30 | (syntax/loc this-syntax 31 | (call-with-values (λ () expr) print-values))])]) 32 | 33 | (define (print-values . vs) 34 | (for-each (current-print) vs) 35 | (apply values vs)) 36 | -------------------------------------------------------------------------------- /toolbox-db-lib/toolbox/db/base.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/require 4 | racket/contract 5 | (subtract-in db/base 6 | "private/base.rkt" 7 | "private/query.rkt") 8 | "private/base.rkt" 9 | "private/query.rkt") 10 | 11 | (provide (all-from-out db/base) 12 | toolbox:db-logger 13 | lifted-statement 14 | (recontract-out 15 | exn:fail:sql:busy? 16 | exn:fail:sql:constraint? 17 | 18 | map-sql-nullable 19 | 20 | current-db 21 | get-db 22 | 23 | in-transaction? 24 | call-with-transaction 25 | current-max-transaction-retries 26 | current-transaction-retry-delay 27 | call-with-transaction/retry 28 | 29 | current-log-db-queries? 30 | current-explain-db-queries? 31 | current-analyze-db-queries? 32 | 33 | query 34 | query-exec 35 | query-rows 36 | query-list 37 | query-row 38 | query-maybe-row 39 | query-value 40 | query-maybe-value 41 | 42 | query-changes)) 43 | -------------------------------------------------------------------------------- /toolbox-web-lib/toolbox/web/dispatch.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base 4 | racket/stxparam-exptime 5 | racket/syntax) 6 | racket/contract 7 | racket/match 8 | syntax/parse/define 9 | web-server/dispatch/extend) 10 | 11 | (provide define-enum-bidi-match-expander) 12 | 13 | (define ((in-pred strs) v) 14 | (and (string? v) (member v strs string=?) #t)) 15 | (define ((out-pred syms) v) 16 | (and (symbol? v) (memq v syms) #t)) 17 | 18 | (begin-for-syntax 19 | (define (enum-arg-match-expander-transformer syms-id strs-id) 20 | (syntax-parser 21 | [(_ x:id) 22 | (if (syntax-parameter-value #'bidi-match-going-in?) 23 | #`(? (in-pred #,strs-id) (app string->symbol x)) 24 | #`(? (out-pred #,syms-id) (app symbol->string x)))]))) 25 | 26 | (define-syntax-parser define-enum-bidi-match-expander 27 | [(_ x:id syms) 28 | #:declare syms (expr/c #'(listof symbol?)) 29 | #:with syms-id (generate-temporary #'x) 30 | #:with strs-id (generate-temporary #'x) 31 | #'(begin 32 | (define syms-id syms.c) 33 | (define strs-id (map symbol->string syms-id)) 34 | (define-match-expander x 35 | (enum-arg-match-expander-transformer #'syms-id #'strs-id)))]) 36 | -------------------------------------------------------------------------------- /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | name: build 2 | on: [push] 3 | jobs: 4 | build: 5 | runs-on: ubuntu-latest 6 | strategy: 7 | fail-fast: false 8 | matrix: 9 | racket-version: [current] 10 | steps: 11 | - uses: actions/checkout@v4 12 | - uses: Bogdanp/setup-racket@v1.11 13 | with: 14 | version: ${{ matrix.racket-version }} 15 | dest: '$GITHUB_WORKSPACE/racket' 16 | sudo: never 17 | - name: install 18 | run: raco pkg install --installation --auto --link toolbox-{lib,db-lib,db-x86_64-linux,draw-lib,web-lib,doc} 19 | - name: test 20 | run: raco test -ep toolbox-{lib,db-lib,draw-lib,web-lib} 21 | - name: deploy_docs 22 | if: ${{ github.event_name != 'pull_request' && github.ref == 'refs/heads/master' && matrix.racket-version == 'current' }} 23 | run: | 24 | set -e 25 | scribble +m --redirect https://docs.racket-lang.org/local-redirect/index.html \ 26 | --htmls --dest-name docs toolbox-doc/scribblings/toolbox.scrbl 27 | cd docs 28 | git init -b gh-pages 29 | git config user.name 'GitHub Actions' 30 | git config user.email 'lexi.lambda@gmail.com' 31 | git add . 32 | git commit -m 'Deploy to GitHub Pages' 33 | git push --force 'https://lexi-lambda:${{ github.token }}@github.com/${{ github.repository }}' gh-pages 34 | -------------------------------------------------------------------------------- /toolbox-lib/toolbox/lazy-require.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base 4 | racket/syntax 5 | syntax/transformer) 6 | racket/lazy-require 7 | racket/promise 8 | racket/runtime-path 9 | syntax/parse/define) 10 | 11 | (provide lazy-require lazy-require/value) 12 | 13 | (begin-for-syntax 14 | (define-syntax-class import-spec 15 | #:description "import spec" 16 | #:attributes [export-id import-id] 17 | #:commit 18 | (pattern export-id:id 19 | #:attr import-id #'export-id) 20 | (pattern [export-id:id import-id:id])) 21 | 22 | (define-syntax-class lazy-require-clause 23 | #:description "lazy-require clause" 24 | #:attributes [{defn 1}] 25 | #:commit 26 | (pattern [module-path {spec:import-spec ...}] 27 | #:with mpi-id (generate-temporary #'module-path) 28 | #:with [promise-id ...] (generate-temporaries (attribute spec.import-id)) 29 | #:with [defn ...] 30 | #'[(define-runtime-module-path-index mpi-id 'module-path) 31 | {~@ (define promise-id (delay (dynamic-require mpi-id 'spec.export-id))) 32 | (define-syntax spec.import-id (make-variable-like-transformer 33 | (quote-syntax (force promise-id))))} 34 | ...]))) 35 | 36 | (define-syntax-parser lazy-require/value 37 | [(_ clause:lazy-require-clause ...) 38 | #'(begin clause.defn ... ...)]) 39 | -------------------------------------------------------------------------------- /toolbox-lib/toolbox/list.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base) 4 | racket/contract 5 | syntax/parse/define) 6 | 7 | (provide (contract-out 8 | [take-at-most (-> list? exact-nonnegative-integer? list?)] 9 | [split-at-most (-> list? exact-nonnegative-integer? (values list? list?))] 10 | [maybe->list (-> any/c list?)]) 11 | when/list 12 | unless/list 13 | when/list* 14 | unless/list*) 15 | 16 | ;; ----------------------------------------------------------------------------- 17 | 18 | (define (take-at-most lst n) 19 | (for/list ([v (in-list lst)] 20 | [i (in-range n)]) 21 | v)) 22 | 23 | (define (split-at-most lst n) 24 | (let loop ([head '()] 25 | [tail lst] 26 | [i 0]) 27 | (cond 28 | [(null? tail) 29 | (values lst '())] 30 | [(>= i n) 31 | (values (reverse head) tail)] 32 | [else 33 | (loop (cons (car tail) head) 34 | (cdr tail) 35 | (add1 i))]))) 36 | 37 | (define (maybe->list v) 38 | (if v (list v) '())) 39 | 40 | (define-syntax-parse-rule (when/list cond-e:expr body ...+) 41 | (if cond-e (list (let () body ...)) '())) 42 | 43 | (define-syntax-parse-rule (unless/list cond-e:expr body ...+) 44 | (if cond-e '() (list (let () body ...)))) 45 | 46 | (define-syntax-parse-rule (when/list* cond-e:expr body ...+) 47 | #:with {~var body-e (expr/c #'list? #:name "body")} 48 | (syntax/loc this-syntax 49 | (let () body ...)) 50 | (if cond-e body-e.c '())) 51 | 52 | (define-syntax-parse-rule (unless/list* cond-e:expr body ...+) 53 | #:with {~var body-e (expr/c #'list? #:name "body")} 54 | (syntax/loc this-syntax 55 | (let () body ...)) 56 | (if cond-e '() body-e.c)) 57 | -------------------------------------------------------------------------------- /toolbox-doc/scribblings/toolbox.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require "toolbox/private/common.rkt") 4 | 5 | @title{Toolbox: Miscellaneous Utilities} 6 | @author{@author+email["Alexis King" "lexi.lambda@gmail.com"]} 7 | 8 | This library provides a collection of miscellaneous Racket utilities that I use in my personal projects but I have not felt warrant being published as a separate package. Note that this library is intentionally @emph{not} published on the Racket package server, as @bold{everything in this library should be considered unstable}. In projects that use it, I include this repository as a Git submodule, pinning to a specific version. 9 | 10 | @table-of-contents[] 11 | 12 | @include-section["toolbox/syntax.scrbl"] 13 | @include-section["toolbox/data.scrbl"] 14 | @include-section["toolbox/logging.scrbl"] 15 | @include-section["toolbox/format.scrbl"] 16 | 17 | @section[#:tag "gregor"]{Gregor} 18 | @defmodule[toolbox/gregor] 19 | 20 | @defthing[UTC tz/c #:auto-value]{ 21 | The @hyperlink["https://www.iana.org/time-zones"]{IANA timezone identifier} for @hyperlink["https://en.wikipedia.org/wiki/Coordinated_Universal_Time"]{Coordinated Universal Time}. 22 | 23 | This binding is actually provided by @racketmodname[gregor] itself, but it is not documented. The @racketmodname[toolbox/gregor] module simply reprovides it.} 24 | 25 | @defproc[(posix->moment/utc [v rational?]) moment?]{ 26 | Equivalent to @racket[(posix->moment v UTC)].} 27 | 28 | @defproc[(jd->moment [v rational?] [tz tz/c (current-timezone)]) moment?]{ 29 | Equivalent to @racket[(adjust-timezone (jd->moment/utc v) tz)].} 30 | 31 | @defproc[(jd->moment/utc [v rational?]) moment?]{ 32 | Equivalent to @racket[(with-timezone (jd->datetime v) UTC)].} 33 | 34 | @include-section["toolbox/db.scrbl"] 35 | @include-section["toolbox/draw.scrbl"] 36 | @include-section["toolbox/web.scrbl"] 37 | 38 | @index-section[] 39 | -------------------------------------------------------------------------------- /toolbox-lib/toolbox/format.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract 4 | racket/format 5 | racket/match) 6 | 7 | (provide ~r* 8 | (contract-out 9 | [ordinal (->* [exact-nonnegative-integer?] 10 | [#:word? any/c] 11 | string?)])) 12 | 13 | ;; ----------------------------------------------------------------------------- 14 | 15 | (define (~r* n 16 | #:sign [sign #f] 17 | #:base [base 10] 18 | #:precision [precision 6] 19 | #:notation [notation 'positional] 20 | #:format-exponent [format-exponent #f] 21 | #:min-width [min-width 1] 22 | #:pad-string [pad-string " "] 23 | #:groups [groups '(3)] 24 | #:group-sep [group-sep ","] 25 | #:decimal-sep [decimal-sep "."]) 26 | (~r n 27 | #:sign sign 28 | #:base base 29 | #:precision precision 30 | #:notation notation 31 | #:format-exponent format-exponent 32 | #:min-width min-width 33 | #:pad-string pad-string 34 | #:groups groups 35 | #:group-sep group-sep 36 | #:decimal-sep decimal-sep)) 37 | 38 | (define (ordinal n #:word? [use-word? #f]) 39 | (cond 40 | [(and use-word? (<= 1 n 10)) 41 | (vector-ref #("first" 42 | "second" 43 | "third" 44 | "fourth" 45 | "fifth" 46 | "sixth" 47 | "seventh" 48 | "eighth" 49 | "ninth" 50 | "tenth") 51 | (sub1 n))] 52 | [else 53 | (string-append 54 | (~r* n) 55 | (match (remainder n 100) 56 | [(or 11 12 13) "th"] 57 | [_ (match (remainder n 10) 58 | [1 "st"] 59 | [2 "nd"] 60 | [3 "rd"] 61 | [_ "th"])]))])) 62 | -------------------------------------------------------------------------------- /toolbox-doc/scribblings/toolbox/format.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require "private/common.rkt") 4 | 5 | @title[#:tag "format"]{Formatting} 6 | @defmodule[toolbox/format] 7 | 8 | @defproc[(~r* [x rational?] 9 | [#:sign sign 10 | (or/c #f '+ '++ 'parens 11 | (let ([ind (or/c string? (list/c string? string?))]) 12 | (list/c ind ind ind))) 13 | #f] 14 | [#:base base (or/c (integer-in 2 36) (list/c 'up (integer-in 2 36))) 10] 15 | [#:precision precision 16 | (or/c exact-nonnegative-integer? 17 | (list/c '= exact-nonnegative-integer?)) 18 | 6] 19 | [#:notation notation 20 | (or/c 'positional 'exponential 21 | (-> rational? (or/c 'positional 'exponential))) 22 | 'positional] 23 | [#:format-exponent format-exponent (or/c #f string? (-> exact-integer? string?)) #f] 24 | [#:min-width min-width exact-positive-integer? 1] 25 | [#:pad-string pad-string non-empty-string? " "] 26 | [#:groups groups (non-empty-listof exact-positive-integer?) '(3)] 27 | [#:group-sep group-sep string? ","] 28 | [#:decimal-sep decimal-sep string? "."]) 29 | string?]{ 30 | Like @racket[~r] from @racketmodname[racket/format], except that the default value of @racket[group-sep] is @racket[","] instead of @racket[""], so numbers include thousands separators by default.} 31 | 32 | @defproc[(ordinal [n exact-nonnegative-integer?] 33 | [#:word? use-word? any/c #f]) 34 | string?]{ 35 | Returns an @hyperlink["https://en.wikipedia.org/wiki/Ordinal_numeral"]{ordinal numeral} for @racket[n]. 36 | 37 | @(toolbox-examples 38 | (eval:check (ordinal 1) "1st") 39 | (eval:check (ordinal 2) "2nd") 40 | (eval:check (ordinal 23) "23rd")) 41 | 42 | If @racket[use-word?] is not @racket[#f], then a word will be returned instead of a numeral with a suffix if @racket[n] is between @racket[1] and @racket[10], inclusive. 43 | 44 | @(toolbox-examples 45 | (eval:check (ordinal 1 #:word? #t) "first") 46 | (eval:check (ordinal 2 #:word? #t) "second") 47 | (eval:check (ordinal 10 #:word? #t) "tenth") 48 | (eval:check (ordinal 11 #:word? #t) "11th"))} 49 | -------------------------------------------------------------------------------- /toolbox-doc/scribblings/toolbox/syntax.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require "private/common.rkt") 4 | 5 | @title[#:tag "syntax"]{Syntax} 6 | 7 | @section[#:tag "lazy-require"]{Importing non-function values lazily} 8 | @defmodule[toolbox/lazy-require] 9 | 10 | In addition to the bindings documented in this section, @racketmodname[toolbox/lazy-require] also reprovides @racket[lazy-require] from @racketmodname[racket/lazy-require]. 11 | 12 | @defform[(lazy-require/value [module-path {import ...}] ...) 13 | #:grammar ([import id 14 | [orig-id bind-id]])]{ 15 | Like @racket[lazy-require], but the imported bindings need not be functions. Instead, each imported binding triggers module loading the first time a use of the binding is evaluated. Note that this is more eager than @racket[lazy-require], which only triggers module loading when the imported binding is @emph{applied}. 16 | 17 | @(toolbox-examples 18 | (module a racket/base 19 | (provide special-value) 20 | (define special-value (gensym 'special)) 21 | (displayln "module a instantiated")) 22 | (lazy-require/value ['a {special-value}]) 23 | (define (get-special-value) 24 | special-value) 25 | (get-special-value) 26 | (get-special-value))} 27 | 28 | @section[#:tag "lift"]{Lifting expressions} 29 | @defmodule[toolbox/lift] 30 | 31 | @defform[(#%lift expr) 32 | #:contracts ([expr any/c])]{ 33 | When expanded as an expression, @racket[#%lift] lifts @racket[expr] to the module top level using @racket[syntax-local-lift-expression] and expands to the fresh identifier it was bound to.} 34 | 35 | @section[#:tag "printing-block"]{Automatic printing in blocks} 36 | @defmodule[toolbox/printing-block] 37 | 38 | @defform[(printing-block defn-or-expr ...+)]{ 39 | Like @racket[(let () defn-or-expr #,m...)], but values returned by each expression in the block are printed in the same way as at the top level of a module. 40 | 41 | @(toolbox-examples 42 | (eval:check (printing-block 43 | (+ 1 2 3) 44 | (string-upcase "hello") 45 | (not #f)) 46 | #t))} 47 | 48 | @section[#:tag "who"]{Context-sensitive @racket[who]} 49 | @defmodule[toolbox/who] 50 | 51 | @defform*[{(define/who id expr) 52 | (define/who (head args) body ...+)}]{ 53 | Like @racket[define], except @racket[who] evaluates to @racket['@#,racket[id]] within the lexical extent of the @racket[expr], @racket[args], or @racket[body] forms. 54 | 55 | @(toolbox-examples 56 | (define/who (vector-first v) 57 | (when (zero? (vector-length v)) 58 | (raise-arguments-error who "empty vector")) 59 | (vector-ref v 0)) 60 | (eval:error (vector-first (vector))))} 61 | 62 | @defidform[who]{ 63 | When used as an expression within @racket[define/who], evaluates to a symbol corresponding to the name of the definition.} 64 | -------------------------------------------------------------------------------- /toolbox-doc/scribblings/toolbox/draw/color.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require "../private/common.rkt") 4 | 5 | @(define (HSV-coordinates) 6 | @hyperlink["https://en.wikipedia.org/wiki/HSL_and_HSV"]{HSV coordinates}) 7 | 8 | @title[#:tag "color"]{Color} 9 | @defmodule[toolbox/color] 10 | 11 | This module provides structures and functions useful when working with colors. 12 | 13 | Note that, technically, none of the structures provided by this module (or the ones provided by @racketmodname[racket/draw]) represent @emph{colors}, only @emph{color coordinates}. The specific color referred to by a given set of color coordinates depends on the @hyperlink["https://en.wikipedia.org/wiki/Color_space"]{color space} they are interpreted in. 14 | 15 | @defproc[(rgb [red (real-in 0 1)] 16 | [green (real-in 0 1)] 17 | [blue (real-in 0 1)] 18 | [alpha (real-in 0 1) 1.0]) 19 | rgb?]{ 20 | Constructs an @deftech{RGB color} from the given components. 21 | 22 | @(toolbox-examples 23 | (rgb 1 0 1 0.5))} 24 | 25 | @defproc[(hsv [hue rational?] 26 | [saturation (real-in 0 1)] 27 | [value (real-in 0 1)] 28 | [alpha (real-in 0 1) 1.0]) 29 | rgb?]{ 30 | Constructs an @tech{RGB color} from the given @HSV-coordinates[]. The @racket[hue] component represents an angle, where @racket[0.0] is interpreted as 0° and @racket[1.0] is interpreted as 360°. The value of @racket[hue] may be any @reftech{rational number}, and it will be interpreted modulo 1. 31 | 32 | @(toolbox-examples 33 | (eval:check (hsv 0 1 1) (rgb 1 0 0)) 34 | (hsv 1/3 1 1) 35 | (hsv 2/3 1 1) 36 | (hsv 1/6 1 0.5))} 37 | 38 | @defproc[(rgb? [v any/c]) boolean?]{ 39 | Returns @racket[#t] if @racket[v] is an @tech{RGB color} constructed with @racket[rgb] or @racket[hsv], otherwise returns @racket[#f].} 40 | 41 | @defproc[(rgb-red [c rgb?]) (real-in 0 1)]{ 42 | Returns the red component of an @tech{RGB color}.} 43 | 44 | @defproc[(rgb-green [c rgb?]) (real-in 0 1)]{ 45 | Returns the green component of an @tech{RGB color}.} 46 | 47 | @defproc[(rgb-blue [c rgb?]) (real-in 0 1)]{ 48 | Returns the blue component of an @tech{RGB color}.} 49 | 50 | @defproc[(rgb-alpha [c rgb?]) (real-in 0 1)]{ 51 | Returns the alpha component of an @tech{RGB color}.} 52 | 53 | @defproc[(rgb-hue [c rgb?]) (and/c (>=/c 0) (hsv [c rgb?]) 63 | (values (and/c (>=/c 0) (hsv] can be more efficient.} 67 | 68 | @defproc[(color? [v any/c]) boolean?]{ 69 | Returns @racket[#t] if @racket[#f] is an @tech{RGB color}, a @racket[color%] object, or a @reftech{string} corresponding to a color name in @racket[the-color-database].} 70 | 71 | @defproc[(->rgb [c color?]) rgb?]{ 72 | Returns an @tech{RGB color} that represents the same color as @racket[c].} 73 | 74 | @defproc[(->color% [c color?]) (is-a?/c color%)]{ 75 | Returns an immutable @racket[color%] object that represents the same color as @racket[c].} 76 | -------------------------------------------------------------------------------- /toolbox-db-lib/toolbox/db/private/sqlite3/ffi.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require db/private/sqlite3/ffi 4 | ffi/unsafe 5 | racket/match) 6 | 7 | (provide sqlite3_statement? 8 | sqlite3_reset 9 | 10 | SQLITE_EXPLAIN_NORMAL 11 | SQLITE_EXPLAIN_EXPLAIN 12 | SQLITE_EXPLAIN_QUERY_PLAN 13 | 14 | (protect-out sqlite3_stmt_isexplain 15 | sqlite3_stmt_explain) 16 | 17 | SQLITE_SCANSTAT_COMPLEX 18 | 19 | SQLITE_SCANSTAT_NLOOP 20 | SQLITE_SCANSTAT_NLOOP 21 | SQLITE_SCANSTAT_NVISIT 22 | SQLITE_SCANSTAT_EST 23 | SQLITE_SCANSTAT_NAME 24 | SQLITE_SCANSTAT_EXPLAIN 25 | SQLITE_SCANSTAT_SELECTID 26 | SQLITE_SCANSTAT_PARENTID 27 | SQLITE_SCANSTAT_NCYCLE 28 | 29 | (protect-out sqlite3_stmt_scanstatus_reset 30 | sqlite3_stmt_scanstatus_v2) 31 | 32 | sqlite3-stmt-scanstatus-enabled? 33 | check-sqlite3-stmt-scanstatus-enabled) 34 | 35 | ;; ----------------------------------------------------------------------------- 36 | 37 | ;; These are not actually defined by SQLite, but they’re useful. 38 | (define SQLITE_EXPLAIN_NORMAL 0) 39 | (define SQLITE_EXPLAIN_EXPLAIN 1) 40 | (define SQLITE_EXPLAIN_QUERY_PLAN 2) 41 | 42 | (define-sqlite sqlite3_stmt_isexplain 43 | (_fun _sqlite3_statement -> _int)) 44 | 45 | (define-sqlite sqlite3_stmt_explain 46 | (_fun _sqlite3_statement 47 | _int 48 | -> [result : _int] 49 | -> (unless (= result SQLITE_OK) 50 | (error 'sqlite3_stmt_explain "could not change statement explain mode" 51 | "error code" result))) 52 | #:fail (λ () #f)) 53 | 54 | ;; ----------------------------------------------------------------------------- 55 | 56 | (define SQLITE_SCANSTAT_COMPLEX 1) 57 | 58 | (define SQLITE_SCANSTAT_NLOOP 0) 59 | (define SQLITE_SCANSTAT_NVISIT 1) 60 | (define SQLITE_SCANSTAT_EST 2) 61 | (define SQLITE_SCANSTAT_NAME 3) 62 | (define SQLITE_SCANSTAT_EXPLAIN 4) 63 | (define SQLITE_SCANSTAT_SELECTID 5) 64 | (define SQLITE_SCANSTAT_PARENTID 6) 65 | (define SQLITE_SCANSTAT_NCYCLE 7) 66 | 67 | (define-sqlite sqlite3_stmt_scanstatus_reset 68 | (_fun _sqlite3_statement -> _void) 69 | #:fail (λ () #f)) 70 | 71 | (define-sqlite sqlite3_stmt_scanstatus_v2 72 | (_fun _sqlite3_statement 73 | [idx : _int] 74 | [scan-status-op : _int] 75 | [flags : _int] 76 | [out : (_ptr o (match scan-status-op 77 | [(or (== SQLITE_SCANSTAT_SELECTID) 78 | (== SQLITE_SCANSTAT_PARENTID)) 79 | _int] 80 | [(or (== SQLITE_SCANSTAT_NLOOP) 81 | (== SQLITE_SCANSTAT_NVISIT) 82 | (== SQLITE_SCANSTAT_NCYCLE)) 83 | _int64] 84 | [(== SQLITE_SCANSTAT_EST) 85 | _double] 86 | [(or (== SQLITE_SCANSTAT_NAME) 87 | (== SQLITE_SCANSTAT_EXPLAIN)) 88 | _pointer]))] 89 | -> [result : _int] 90 | -> (if (zero? result) 91 | (match scan-status-op 92 | [(or (== SQLITE_SCANSTAT_NAME) 93 | (== SQLITE_SCANSTAT_EXPLAIN)) 94 | (cast out _pointer _string/utf-8)] 95 | [_ out]) 96 | #f)) 97 | #:fail (λ () #f)) 98 | 99 | (define (sqlite3-stmt-scanstatus-enabled?) 100 | (and sqlite3_stmt_scanstatus_v2 #t)) 101 | 102 | (define (check-sqlite3-stmt-scanstatus-enabled who message) 103 | (unless (sqlite3-stmt-scanstatus-enabled?) 104 | (raise (exn:fail:unsupported 105 | (format (string-append "~a: ~a;\n" 106 | " SQLite was not compiled with SQLITE_ENABLE_STMT_SCANSTATUS") 107 | who 108 | message) 109 | (current-continuation-marks))))) 110 | -------------------------------------------------------------------------------- /toolbox-doc/scribblings/toolbox/data.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-syntax racket/base) 4 | (only-in racket/base [box r:box]) 5 | "private/common.rkt") 6 | 7 | @title[#:tag "data"]{Data Structures} 8 | 9 | @section[#:tag "boolean"]{Booleans} 10 | @defmodule[toolbox/boolean] 11 | 12 | @defproc[(->boolean [v any/c]) boolean?]{ 13 | Returns @racket[#f] if @racket[v] is @racket[#f], otherwise returns @racket[#t].} 14 | 15 | @section[#:tag "box"]{Boxes} 16 | @defmodule[toolbox/box] 17 | 18 | @defproc[(box-cas-update! [box (and/c box? (not/c immutable?) (not/c impersonator?))] 19 | [proc (-> any/c any/c)]) 20 | any/c]{ 21 | Atomically updates the contents of @racket[box] by applying @racket[proc] to the old value to produce a new value. The @racket[proc] procedure will be applied more than once if the box is concurrently modified between reading the old value and writing the new one, so @racket[proc] should generally be inexpensive. The result of the call to @racket[box-cas-update!] is the value written to @racket[box]. 22 | 23 | @(let-syntax ([box (make-rename-transformer #'r:box)]) 24 | (toolbox-examples 25 | (define b (box "hello")) 26 | (eval:check (box-cas-update! b string-upcase) "HELLO") 27 | (eval:check (unbox b) "HELLO")))} 28 | 29 | @defproc[(box-cas-update!* [box (and/c box? (not/c immutable?) (not/c impersonator?))] 30 | [proc (-> any/c (values any/c any/c))]) 31 | any/c]{ 32 | Like @racket[box-cas-update!], but @racket[proc] should return two values: the first value is returned, and the second value is written to @racket[box]. 33 | 34 | @(let-syntax ([box (make-rename-transformer #'r:box)]) 35 | (toolbox-examples 36 | (define b (box "old")) 37 | (eval:check (box-cas-update!* b (λ (old) (values old "new"))) "old") 38 | (eval:check (unbox b) "new")))} 39 | 40 | @defproc[(box-add1! [box (and/c box? (not/c immutable?) (not/c impersonator?))]) number?]{ 41 | Equivalent to @racket[(box-cas-update! box add1)].} 42 | 43 | @defproc[(box-sub1! [box (and/c box? (not/c immutable?) (not/c impersonator?))]) number?]{ 44 | Equivalent to @racket[(box-cas-update! box sub1)].} 45 | 46 | @section[#:tag "list"]{Lists} 47 | @defmodule[toolbox/list] 48 | 49 | @defproc[(take-at-most [lst list?] [n exact-nonnegative-integer?]) list?]{ 50 | Like @racket[take], except if @racket[lst] has fewer than @racket[n] elements, @racket[take-at-most] returns @racket[lst] instead of raising an exception. 51 | 52 | @(toolbox-examples 53 | (eval:check (take-at-most '(1 2 3 4 5) 3) '(1 2 3)) 54 | (eval:check (take-at-most '(1 2) 3) '(1 2)))} 55 | 56 | @defproc[(split-at-most [lst list?] [n exact-nonnegative-integer?]) 57 | (values list? list?)]{ 58 | Like @racket[split-at], except if @racket[lst] has fewer than @racket[n] elements, @racket[split-at-most] returns @racket[(values lst '())] instead of raising an exception. 59 | 60 | @(toolbox-examples 61 | (eval:check (split-at-most '(1 2 3 4 5) 3) 62 | (values '(1 2 3) '(4 5))) 63 | (eval:check (split-at-most '(1 2) 3) 64 | (values '(1 2) '())))} 65 | 66 | @defproc[(maybe->list [v any/c]) list?]{ 67 | If @racket[v] is @racket[#f], returns @racket['()], otherwise returns @racket[(list v)].} 68 | 69 | @defform[(when/list test-expr body ...+)]{ 70 | Equivalent to @racket[(if test-expr (list (let () body #,m...)) '())].} 71 | 72 | @defform[(unless/list test-expr body ...+)]{ 73 | Equivalent to @racket[(if test-expr '() (list (let () body #,m...)))].} 74 | 75 | @defform[(when/list* test-expr body ...+)]{ 76 | Equivalent to @racket[(if test-expr (let () body #,m...) '())], except that the last @racket[body] form must evaluate to a @reftech{list}, or an @racket[exn:fail:contract] exception is raised.} 77 | 78 | @defform[(unless/list* test-expr body ...+)]{ 79 | Equivalent to @racket[(if test-expr '() (let () body #,m...))], except that the last @racket[body] form must evaluate to a @reftech{list}, or an @racket[exn:fail:contract] exception is raised.} 80 | 81 | @section[#:tag "string"]{Strings} 82 | @defmodule[toolbox/string] 83 | 84 | @defform[(when/string test-expr body ...+)]{ 85 | Equivalent to @racket[(if test-expr (let () body #,m...) "")], except that the last @racket[body] form must evaluate to a @reftech{string}, or an @racket[exn:fail:contract] exception is raised.} 86 | 87 | @defform[(unless/string test-expr body ...+)]{ 88 | Equivalent to @racket[(if test-expr "" (let () body #,m...))], except that the last @racket[body] form must evaluate to a @reftech{string}, or an @racket[exn:fail:contract] exception is raised.} 89 | -------------------------------------------------------------------------------- /toolbox-db-lib/toolbox/db/sql.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base) 4 | racket/contract 5 | racket/format 6 | racket/list 7 | racket/match 8 | racket/string 9 | syntax/parse/define 10 | threading 11 | toolbox/format 12 | toolbox/who 13 | "base.rkt") 14 | 15 | (provide ~stmt 16 | (contract-out 17 | [sql:id (-> (or/c symbol? string?) string?)] 18 | [sql:string (-> string? string?)] 19 | 20 | [pre-sql? predicate/c] 21 | [~sql (-> pre-sql? ... string?)] 22 | [sql:seq (-> pre-sql? ... string?)] 23 | [sql:seq* (-> pre-sql? ... (listof pre-sql?) string?)] 24 | [sql:tuple (-> pre-sql? ... string?)] 25 | [sql:tuple* (-> pre-sql? ... (listof pre-sql?) string?)] 26 | 27 | [query:bag (-> (listof pre-sql?) string?)] 28 | [query:indexed-list (-> (listof pre-sql?) string?)] 29 | [query:rows (->* [(listof (vectorof pre-sql?))] 30 | [#:columns (or/c exact-nonnegative-integer? #f)] 31 | string?)])) 32 | 33 | ;; ----------------------------------------------------------------------------- 34 | 35 | (define (sql:id v) 36 | (~> (if (symbol? v) (symbol->string v) v) 37 | (string-replace "\"" "\"\"") 38 | (string-append "\"" _ "\""))) 39 | 40 | (define (sql:string str) 41 | (~> (string-replace str "'" "''") 42 | (string-append "'" _ "'"))) 43 | 44 | ;; ----------------------------------------------------------------------------- 45 | 46 | (define (pre-sql? v) 47 | (or (string? v) 48 | (symbol? v) 49 | (rational? v) 50 | (sql-null? v))) 51 | 52 | (define ~sql 53 | (case-lambda 54 | [() ""] 55 | [(v) 56 | (match v 57 | [(? string?) v] 58 | [(? symbol?) (sql:id v)] 59 | [(? exact-integer?) (number->string v)] 60 | [(? rational?) (number->string (real->double-flonum v))] 61 | [(? sql-null?) "NULL"])] 62 | [vs 63 | (string-append* (map ~sql vs))])) 64 | 65 | (define-syntax-parse-rule (~stmt arg ...) 66 | #:declare arg (expr/c #'pre-sql?) 67 | (lifted-statement (~sql arg.c ...))) 68 | 69 | (define (sql:seq . vs) 70 | (string-join (map ~sql vs) ",")) 71 | (define sql:seq* 72 | (case-lambda 73 | [(vs) 74 | (apply sql:seq vs)] 75 | [(v . vs) 76 | (apply apply sql:seq v vs)])) 77 | 78 | (define (sql:tuple . vs) 79 | (~a "(" (sql:seq* vs) ")")) 80 | (define sql:tuple* 81 | (case-lambda 82 | [(vs) 83 | (apply sql:tuple vs)] 84 | [(v . vs) 85 | (apply apply sql:tuple v vs)])) 86 | 87 | (define (query:bag lst) 88 | (if (empty? lst) 89 | "SELECT NULL WHERE 0" 90 | (~sql "VALUES " (sql:seq* (map sql:tuple lst))))) 91 | 92 | (define/who (query:rows rows #:columns [given-num-columns #f]) 93 | (cond 94 | [(empty? rows) 95 | (if given-num-columns 96 | (~sql "SELECT " (sql:seq* (make-list given-num-columns "NULL")) " WHERE 0") 97 | (raise-arguments-error who (string-append "cannot infer number of columns;\n" 98 | " no rows given and #:columns not specified")))] 99 | [else 100 | (define num-columns (or given-num-columns (vector-length (first rows)))) 101 | (define sql-rows 102 | (for/list ([(row i) (in-indexed (in-list rows))]) 103 | (unless (= (vector-length row) num-columns) 104 | (cond 105 | [given-num-columns 106 | (raise-arguments-error who "wrong number of columns for row" 107 | "expected" num-columns 108 | "given" (vector-length row) 109 | "row" row 110 | "row index" i)] 111 | [else 112 | (define ith (ordinal (add1 i) #:word? #t)) 113 | (raise-arguments-error who "inconsistent number of columns per row" 114 | "first row" (first rows) 115 | (~a ith " row") row 116 | "first row columns" num-columns 117 | (~a ith " row columns") (vector-length row))])) 118 | (sql:tuple* (vector->list row)))) 119 | (~sql "VALUES " (sql:seq* sql-rows))])) 120 | 121 | (define (query:indexed-list lst) 122 | (query:rows 123 | #:columns 2 124 | (for/list ([(group-id i) (in-indexed (in-list lst))]) 125 | (vector-immutable i group-id)))) 126 | -------------------------------------------------------------------------------- /toolbox-draw-lib/toolbox/color.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/class 4 | racket/contract 5 | racket/draw 6 | racket/flonum 7 | racket/match 8 | toolbox/who) 9 | 10 | (provide (contract-out 11 | [rgb? predicate/c] 12 | (rename make-rgb rgb (->* [(real-in 0 1) 13 | (real-in 0 1) 14 | (real-in 0 1)] 15 | [(real-in 0 1)] 16 | rgb?)) 17 | [rgb-red (-> rgb? (real-in 0 1))] 18 | [rgb-green (-> rgb? (real-in 0 1))] 19 | [rgb-blue (-> rgb? (real-in 0 1))] 20 | [rgb-alpha (-> rgb? (real-in 0 1))] 21 | 22 | [hsv (->* [rational? 23 | (real-in 0 1) 24 | (real-in 0 1)] 25 | [(real-in 0 1)] 26 | rgb?)] 27 | [rgb-hue (-> rgb? (and/c (>=/c 0) ( rgb? (real-in 0 1))] 29 | [rgb-value (-> rgb? (real-in 0 1))] 30 | [rgb->hsv (-> rgb? (values (and/c (>=/c 0) (color% (-> color? (is-a?/c color%))] 36 | [->rgb (-> color? rgb?)])) 37 | 38 | ;; ----------------------------------------------------------------------------- 39 | 40 | (define (flmod x n) 41 | (fl- x (fl* (fltruncate (fl/ x n)) n))) 42 | 43 | ;; Invariant: All fields are flonums between 0.0 and 1.0. 44 | (struct rgb (red green blue alpha) #:transparent) 45 | 46 | (define (make-rgb r g b [alpha 1.0]) 47 | (rgb (real->double-flonum r) 48 | (real->double-flonum g) 49 | (real->double-flonum b) 50 | (real->double-flonum alpha))) 51 | 52 | (define (hsv hue sat val [alpha 1.0]) 53 | (define h (real->double-flonum hue)) 54 | (define s (real->double-flonum sat)) 55 | (define v (real->double-flonum val)) 56 | (define a (real->double-flonum alpha)) 57 | 58 | (define 6h (fl* h 6.0)) 59 | (define (f n) 60 | (define k (flmod (fl+ n 6h) 6.0)) 61 | (fl- v (fl* v s (flmax 0.0 (flmin k (fl- 4.0 k) 1.0))))) 62 | (rgb (f 5.0) (f 3.0) (f 1.0) a)) 63 | 64 | (define (rgb-hue rgb) 65 | (define r (rgb-red rgb)) 66 | (define g (rgb-green rgb)) 67 | (define b (rgb-blue rgb)) 68 | (define v (calculate-rgb-value r g b)) 69 | (define c (calculate-rgb-chroma r g b v)) 70 | (calculate-rgb-hue r g b v c)) 71 | 72 | (define (rgb-saturation rgb) 73 | (define r (rgb-red rgb)) 74 | (define g (rgb-green rgb)) 75 | (define b (rgb-blue rgb)) 76 | (define v (calculate-rgb-value r g b)) 77 | (define c (calculate-rgb-chroma r g b v)) 78 | (calculuate-rgb-saturation v c)) 79 | 80 | (define (rgb-value rgb) 81 | (define r (rgb-red rgb)) 82 | (define g (rgb-green rgb)) 83 | (define b (rgb-blue rgb)) 84 | (calculate-rgb-value r g b)) 85 | 86 | (define (rgb->hsv rgb) 87 | (define r (rgb-red rgb)) 88 | (define g (rgb-green rgb)) 89 | (define b (rgb-blue rgb)) 90 | (define v (calculate-rgb-value r g b)) 91 | (define c (calculate-rgb-chroma r g b v)) 92 | (define h (calculate-rgb-hue r g b v c)) 93 | (define s (calculuate-rgb-saturation v c)) 94 | (values h s v)) 95 | 96 | (define (calculate-rgb-value r g b) 97 | (flmax r g b)) 98 | 99 | (define (calculate-rgb-chroma r g b v) 100 | (fl- v (flmin r g b))) 101 | 102 | (define (calculate-rgb-hue r g b v c) 103 | (cond 104 | [(fl= c 0.0) 105 | 0.0] 106 | [(fl= v r) 107 | (define h (fl/ (fl/ (fl- g b) c) 6.0)) 108 | (if (fl< h 0.0) (fl+ 1.0 h) h)] 109 | [(fl= v g) 110 | (fl/ (fl+ 2.0 (fl/ (fl- b r) c)) 6.0)] 111 | [else 112 | (fl/ (fl+ 4.0 (fl/ (fl- r g) c)) 6.0)])) 113 | 114 | (define (calculuate-rgb-saturation v c) 115 | (if (fl= c 0.0) 0.0 (fl/ c v))) 116 | 117 | ;; ----------------------------------------------------------------------------- 118 | 119 | (define (color%? v) 120 | (is-a? v color%)) 121 | 122 | (define (color? v) 123 | (or (rgb? v) 124 | (color%? v) 125 | (and (string? v) 126 | (send the-color-database find-color v) 127 | #t))) 128 | 129 | (define (find-color% who name) 130 | (or (send the-color-database find-color name) 131 | (raise-arguments-error who "no known color with name" "name" name))) 132 | 133 | (define/who (->color% v) 134 | (match v 135 | [(? color%?) v] 136 | [(rgb r g b a) 137 | (define (f n) 138 | (fl->exact-integer (flround (fl* n 255.0)))) 139 | (make-color (f r) (f g) (f b) a)] 140 | [(? string?) 141 | (find-color% who v)])) 142 | 143 | (define/who (->rgb v) 144 | (match v 145 | [(? rgb?) v] 146 | [(? color%?) 147 | (rgb (fl/ (->fl (send v red)) 255.0) 148 | (fl/ (->fl (send v green)) 255.0) 149 | (fl/ (->fl (send v blue)) 255.0) 150 | (real->double-flonum (send v alpha)))] 151 | [(? string?) 152 | (->rgb (find-color% who v))])) 153 | -------------------------------------------------------------------------------- /toolbox-db-lib/toolbox/db/private/base.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base) 4 | db/base 5 | (prefix-in db: db/base) 6 | racket/contract 7 | racket/match 8 | syntax/parse/define 9 | toolbox/lift 10 | toolbox/logging 11 | toolbox/who 12 | toolbox/private/logger) 13 | 14 | (provide (logger-out toolbox:db) 15 | define-toolbox:db-logger 16 | lifted-statement 17 | (contract-out 18 | [current-db (parameter/c (or/c connection? #f))] 19 | [get-db (->* [symbol?] connection?)] 20 | 21 | [exn:fail:sql:busy? predicate/c] 22 | [exn:fail:sql:constraint? predicate/c] 23 | 24 | [map-sql-nullable (-> (-> any/c any/c) any/c any/c)] 25 | 26 | [in-transaction? (->* [] [#:db connection?] boolean?)] 27 | [call-with-transaction 28 | (->* [(-> any)] 29 | [#:db connection? 30 | #:isolation (or/c transaction-isolation/c #f) 31 | #:option any/c 32 | #:nested transaction-nested/c] 33 | any)] 34 | [current-max-transaction-retries (parameter/c (or/c exact-nonnegative-integer? +inf.0))] 35 | [current-transaction-retry-delay (parameter/c (>=/c 0))] 36 | [call-with-transaction/retry 37 | (->* [(-> any)] 38 | [#:db connection? 39 | #:isolation (or/c transaction-isolation/c #f) 40 | #:option any/c 41 | #:nested transaction-nested/c 42 | #:max-retries (or/c exact-nonnegative-integer? +inf.0) 43 | #:retry-delay (>=/c 0)] 44 | any)])) 45 | 46 | ;; ----------------------------------------------------------------------------- 47 | 48 | (define-toolbox-logger toolbox:db) 49 | 50 | (define current-db (make-parameter #f)) 51 | 52 | (define/who (get-db [who who]) 53 | (or (current-db) 54 | (raise-arguments-error who "no current db"))) 55 | 56 | ;; ----------------------------------------------------------------------------- 57 | 58 | (define ((make-exn:fail:sql-pred sqlstate) exn) 59 | (and (exn:fail:sql? exn) 60 | (eq? (exn:fail:sql-sqlstate exn) sqlstate))) 61 | 62 | (define exn:fail:sql:busy? (make-exn:fail:sql-pred 'busy)) 63 | (define exn:fail:sql:constraint? (make-exn:fail:sql-pred 'constraint)) 64 | 65 | (define (map-sql-nullable f v) 66 | (if (sql-null? v) 67 | v 68 | (f v))) 69 | 70 | (define virtual-statement-gen/c (or/c string? (-> dbsystem? string?))) 71 | 72 | (define-syntax-parse-rule (lifted-statement e) 73 | #:declare e (expr/c #'virtual-statement-gen/c) 74 | (#%lift (virtual-statement e.c))) 75 | 76 | ;; ----------------------------------------------------------------------------- 77 | 78 | (define/who (in-transaction? #:db [db (get-db who)]) 79 | (db:in-transaction? db)) 80 | 81 | (define current-max-transaction-retries (make-parameter 10)) 82 | (define current-transaction-retry-delay (make-parameter 0.1)) 83 | 84 | (define transaction-isolation/c (or/c 'serializable 85 | 'repeatable-read 86 | 'read-committed 87 | 'read-uncommitted)) 88 | 89 | (define transaction-nested/c (or/c 'allow 'omit 'fail)) 90 | 91 | (define/who (call-with-transaction proc 92 | #:db [db (get-db who)] 93 | #:isolation [isolation #f] 94 | #:option [option #f] 95 | #:nested [nested 'omit]) 96 | (call-with-transaction/retry proc 97 | #:who who 98 | #:db db 99 | #:isolation isolation 100 | #:option option 101 | #:nested nested 102 | #:max-retries 0 103 | #:retry-delay 0)) 104 | 105 | (define/who (call-with-transaction/retry thunk 106 | #:who [who who] 107 | #:db [db (get-db who)] 108 | #:isolation [isolation #f] 109 | #:option [option #f] 110 | #:nested [nested 'omit] 111 | #:max-retries [max-retries (current-max-transaction-retries)] 112 | #:retry-delay [retry-delay (current-transaction-retry-delay)]) 113 | (if (in-transaction? #:db db) 114 | (match nested 115 | ['allow (db:call-with-transaction db thunk)] 116 | ['omit (thunk)] 117 | ['fail (raise-arguments-error who "already in transaction")]) 118 | (let retry ([retries-left max-retries] 119 | [option option]) 120 | (if (<= retries-left 0) 121 | (db:call-with-transaction db thunk #:isolation isolation #:option option) 122 | (with-handlers* 123 | ([exn:fail:sql:busy? 124 | (λ (exn) 125 | (sleep retry-delay) 126 | (retry (sub1 retries-left) 127 | (match* {(dbsystem-name (connection-dbsystem db)) option} 128 | [{'sqlite3 (or #f 'deferred)} 129 | 'immediate] 130 | [{_ _} 131 | option])))]) 132 | (db:call-with-transaction db thunk #:isolation isolation #:option option)))))) 133 | -------------------------------------------------------------------------------- /toolbox-db-lib/toolbox/db/private/sqlite3/explain.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract 4 | racket/format 5 | racket/match 6 | racket/string 7 | toolbox/format 8 | toolbox/list 9 | toolbox/who 10 | "ffi.rkt") 11 | 12 | (provide (contract-out 13 | [eqp-root? predicate/c] 14 | [build-query-plan-explanation (-> (listof vector?) eqp-root?)] 15 | [build-query-plan-explanation/scan-status (-> sqlite3_statement? eqp-root?)] 16 | [print-query-plan-explanation (->* [eqp-root?] [output-port?] void?)])) 17 | 18 | ;; ----------------------------------------------------------------------------- 19 | 20 | (struct eqp-root (cycles children) #:transparent) 21 | (struct eqp-node (description stats children) #:transparent) 22 | (struct eqp-stats (loops rows est cycles) #:transparent) 23 | 24 | ;; Builds a query plan explanation from the rows returned by EXPLAIN QUERY PLAN. 25 | (define (build-query-plan-explanation rows) 26 | (match-define-values ['() nodes] 27 | (let loop ([rows rows] 28 | [parent-id 0]) 29 | (match rows 30 | ['() (values '() '())] 31 | [(cons (vector this-id this-parent-id _ description) rows1) 32 | (cond 33 | [(= this-parent-id parent-id) 34 | (define-values [rows2 children] (loop rows1 this-id)) 35 | (define this-node (eqp-node description #f children)) 36 | (define-values [rows3 siblings] (loop rows2 parent-id)) 37 | (values rows3 (cons this-node siblings))] 38 | [else 39 | (values rows '())])]))) 40 | (eqp-root #f nodes)) 41 | 42 | ;; Builds a query plan explanation using sqlite3_stmt_scanstatus_v2. 43 | (define/who (build-query-plan-explanation/scan-status stmt) 44 | (check-sqlite3-stmt-scanstatus-enabled who "operation not supported") 45 | 46 | (define (stat* idx op) 47 | (sqlite3_stmt_scanstatus_v2 stmt idx op SQLITE_SCANSTAT_COMPLEX)) 48 | (define (neg->false v) 49 | (if (negative? v) #f v)) 50 | 51 | (match-define-values [#f nodes] 52 | (let loop ([idx 0] 53 | [parent-id 0]) 54 | (define (stat op) 55 | (stat* idx op)) 56 | (cond 57 | [(and idx (stat SQLITE_SCANSTAT_SELECTID)) 58 | => (λ (this-id) 59 | (define this-parent-id (stat SQLITE_SCANSTAT_PARENTID)) 60 | (define description (stat SQLITE_SCANSTAT_EXPLAIN)) 61 | 62 | (define loops (neg->false (stat SQLITE_SCANSTAT_NLOOP))) 63 | (define rows (neg->false (stat SQLITE_SCANSTAT_NVISIT))) 64 | (define cycles (neg->false (stat SQLITE_SCANSTAT_NCYCLE))) 65 | (define stats 66 | (and (or loops rows cycles) 67 | (eqp-stats loops 68 | rows 69 | (and loops rows (neg->false (stat SQLITE_SCANSTAT_EST))) 70 | cycles))) 71 | (cond 72 | [(= this-parent-id parent-id) 73 | (define-values [idx2 children] (loop (add1 idx) this-id)) 74 | (define this-node (eqp-node description stats children)) 75 | (define-values [idx3 siblings] (loop idx2 parent-id)) 76 | (values idx3 (cons this-node siblings))] 77 | [else 78 | (values idx '())]))] 79 | [else 80 | (values #f '())]))) 81 | 82 | (eqp-root (neg->false (stat* -1 SQLITE_SCANSTAT_NCYCLE)) nodes)) 83 | 84 | (define (print-query-plan-explanation root-node [out (current-output-port)]) 85 | (match-define (eqp-root total-cycles nodes) root-node) 86 | 87 | (write-string "QUERY PLAN" out) 88 | (when total-cycles 89 | (fprintf out " [cycles=~a]" (~r* total-cycles))) 90 | (newline out) 91 | 92 | (define max-description-width 93 | (let loop ([start-width 2] 94 | [nodes nodes]) 95 | (for/fold ([max-width start-width]) 96 | ([node (in-list nodes)]) 97 | (max max-width 98 | (+ start-width (string-length (eqp-node-description node))) 99 | (loop (+ start-width 2) (eqp-node-children node)))))) 100 | 101 | (let loop ([nodes nodes] 102 | [prefix-str ""]) 103 | (define num-nodes (length nodes)) 104 | (for ([(node i) (in-indexed (in-list nodes))]) 105 | (match-define (eqp-node description stats children) node) 106 | (define last? (= (add1 i) num-nodes)) 107 | 108 | (define-values [this-prefix child-prefix] 109 | (if last? 110 | (values "╰╴" " ") 111 | (values "├╴" "│ "))) 112 | 113 | (write-string prefix-str out) 114 | (write-string this-prefix out) 115 | (write-string description out) 116 | 117 | (when stats 118 | (match-define (eqp-stats loops rows est cycles) stats) 119 | 120 | (for ([i (in-range (add1 (- max-description-width 121 | (string-length prefix-str) 122 | (string-length this-prefix) 123 | (string-length description))))]) 124 | (write-char #\space out)) 125 | 126 | (cond 127 | [(and cycles total-cycles (not (zero? total-cycles))) 128 | (write-string (~r* (* (/ cycles total-cycles) 100) 129 | #:min-width 5 130 | #:precision '(= 1)) 131 | out) 132 | (write-string "% " out)] 133 | [else 134 | (write-string " " out)]) 135 | 136 | (write-char #\[ out) 137 | (write-string 138 | (string-join 139 | `[,@(when/list* est 140 | `[,(~a "est=" (~r* est #:precision '(= 1))) 141 | ,@(when/list (not (zero? loops)) 142 | (~a "actual=" (~r* (/ rows loops) #:precision '(= 1))))]) 143 | 144 | ,@(when/list loops (~a "loops=" (~r* loops))) 145 | ,@(when/list rows (~a "rows=" (~r* rows))) 146 | ,@(when/list cycles (~a "cycles=" (~r* cycles)))] 147 | " ") 148 | out) 149 | (write-char #\] out)) 150 | 151 | (newline out) 152 | (loop children 153 | (string-append prefix-str child-prefix))))) 154 | 155 | -------------------------------------------------------------------------------- /toolbox-doc/scribblings/toolbox/private/common.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base 4 | racket/syntax) 5 | scribble/manual 6 | scribble/example 7 | syntax/parse/define 8 | (for-label (only-in db sqlite3-connect) 9 | gregor 10 | (except-in racket/base date? date) 11 | racket/class 12 | racket/contract 13 | racket/draw 14 | racket/format 15 | racket/lazy-require 16 | racket/list 17 | racket/logging 18 | racket/match 19 | racket/math 20 | racket/string 21 | toolbox/boolean 22 | toolbox/box 23 | toolbox/color 24 | toolbox/db/base 25 | toolbox/db/define 26 | toolbox/db/sql 27 | toolbox/db/sqlite3 28 | toolbox/format 29 | toolbox/gregor 30 | toolbox/lazy-require 31 | toolbox/lift 32 | toolbox/list 33 | toolbox/logger 34 | toolbox/logging 35 | toolbox/pict 36 | toolbox/printing-block 37 | toolbox/string 38 | toolbox/web/dispatch 39 | toolbox/who 40 | web-server/dispatch)) 41 | 42 | (provide m... 43 | reftech 44 | dbtech 45 | drawtech 46 | pictech 47 | define-id-referencer 48 | make-toolbox-eval 49 | close-eval 50 | toolbox-examples 51 | toolbox-interaction 52 | (for-label (all-from-out db 53 | gregor 54 | racket/base 55 | racket/class 56 | racket/contract 57 | racket/draw 58 | racket/format 59 | racket/lazy-require 60 | racket/list 61 | racket/logging 62 | racket/match 63 | racket/math 64 | racket/string 65 | toolbox/boolean 66 | toolbox/box 67 | toolbox/color 68 | toolbox/db/base 69 | toolbox/db/define 70 | toolbox/db/sql 71 | toolbox/db/sqlite3 72 | toolbox/format 73 | toolbox/gregor 74 | toolbox/lazy-require 75 | toolbox/lift 76 | toolbox/list 77 | toolbox/logger 78 | toolbox/logging 79 | toolbox/pict 80 | toolbox/printing-block 81 | toolbox/string 82 | toolbox/web/dispatch 83 | toolbox/who 84 | web-server/dispatch))) 85 | 86 | (define m... (racketmetafont "...")) 87 | 88 | (define (reftech #:key [key #f] . pre-content) 89 | (apply tech pre-content #:key key #:doc '(lib "scribblings/reference/reference.scrbl"))) 90 | (define (dbtech #:key [key #f] . pre-content) 91 | (apply tech pre-content #:key key #:doc '(lib "db/scribblings/db.scrbl"))) 92 | (define (drawtech #:key [key #f] . pre-content) 93 | (apply tech pre-content #:key key #:doc '(lib "scribblings/draw/draw.scrbl"))) 94 | (define (pictech #:key [key #f] . pre-content) 95 | (apply tech pre-content #:key key #:doc '(lib "pict/scribblings/pict.scrbl"))) 96 | 97 | (define (id-from-modname-elem id-elem mod-name-elem) 98 | (list id-elem " from " mod-name-elem)) 99 | 100 | (begin-for-syntax 101 | (define (make-id-referencer-transformers mod-name) 102 | (values 103 | (syntax-parser 104 | [(_ x:id) 105 | #`(racket #,(datum->syntax mod-name (syntax-e #'x) #'x #'x))]) 106 | (syntax-parser 107 | [(_ x:id) 108 | #`(id-from-modname-elem 109 | (racket #,(datum->syntax mod-name (syntax-e #'x) #'x #'x)) 110 | (racketmodname #,mod-name))])))) 111 | 112 | (define-syntax-parse-rule (define-id-referencer name:id mod-name:id) 113 | #:with name-id (format-id #'name "~a-id" #'name #:subs? #t) 114 | #:with id-from-name (format-id #'name "id-from-~a" #'name #:subs? #t) 115 | #:do [(define introducer (make-syntax-introducer #t))] 116 | #:with mod-name* (introducer (datum->syntax #f (syntax-e #'mod-name) #'mod-name #'mod-name)) 117 | (begin 118 | (require (for-label mod-name*)) 119 | (define-syntaxes [name-id id-from-name] 120 | (make-id-referencer-transformers (quote-syntax mod-name*))))) 121 | 122 | (define make-toolbox-eval (make-eval-factory '(db/sqlite3 123 | racket/class 124 | racket/draw 125 | racket/list 126 | racket/match 127 | racket/math 128 | racket/string 129 | toolbox/boolean 130 | toolbox/box 131 | toolbox/color 132 | toolbox/db/base 133 | toolbox/db/define 134 | toolbox/db/sql 135 | toolbox/db/sqlite3 136 | toolbox/format 137 | toolbox/gregor 138 | toolbox/lazy-require 139 | toolbox/lift 140 | toolbox/list 141 | toolbox/logger 142 | toolbox/logging 143 | toolbox/pict 144 | toolbox/printing-block 145 | toolbox/string 146 | toolbox/web/dispatch 147 | toolbox/who 148 | web-server/dispatch))) 149 | 150 | (begin-for-syntax 151 | (define-splicing-syntax-class eval-body 152 | #:description #f 153 | #:attributes [e] 154 | (pattern {~seq body:expr #:hidden hidden:expr} 155 | #:attr e #'(eval:alts body (begin0 body hidden))) 156 | (pattern {~seq #:hidden hidden:expr body:expr} 157 | #:attr e #'(eval:alts body (begin hidden body))) 158 | (pattern body:expr 159 | #:attr e #'body))) 160 | 161 | (define-syntax-parse-rule 162 | (toolbox-examples {~alt {~optional {~seq #:eval eval-e:expr}} 163 | {~optional {~seq #:label label-e:expr}}} 164 | ... 165 | body:eval-body ...) 166 | (examples {~? {~@ #:eval eval-e} 167 | {~@ #:eval (make-toolbox-eval) #:once}} 168 | {~? {~@ #:label label-e}} 169 | body.e ...)) 170 | 171 | (define-syntax-parse-rule (toolbox-interaction body ...) 172 | (toolbox-examples #:label #f body ...)) 173 | -------------------------------------------------------------------------------- /toolbox-db-lib/toolbox/db/define.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base 4 | racket/string 5 | racket/syntax 6 | threading) 7 | (only-in racket/class field) 8 | racket/contract 9 | syntax/parse/define 10 | "base.rkt" 11 | "sql.rkt") 12 | 13 | (provide field 14 | define-sql-table 15 | (contract-out 16 | [make-sql-deleter (->* [#:who symbol? 17 | #:table symbol?] 18 | [#:resolve resolver/c] 19 | procedure?)] 20 | [make-sql-getter (->* [#:who symbol? 21 | #:table symbol? 22 | #:field symbol?] 23 | [#:resolve resolver/c 24 | #:convert convert/c] 25 | procedure?)] 26 | [make-sql-setter (->* [#:who symbol? 27 | #:table symbol? 28 | #:field symbol?] 29 | [#:resolve resolver/c 30 | #:convert convert/c] 31 | procedure?)])) 32 | 33 | ;; ----------------------------------------------------------------------------- 34 | 35 | (define resolver/c (or/c (-> any/c #:who symbol? any/c) #f)) 36 | (define convert/c (-> any/c any/c)) 37 | 38 | (define (sqlite-statement who str) 39 | (virtual-statement 40 | (λ (sys) 41 | (define sys-name (dbsystem-name sys)) 42 | (if (eq? sys-name 'sqlite3) 43 | str 44 | (raise (exn:fail:unsupported 45 | (format "~a: dbsystem not supported\n dbsystem name: ~e" who sys-name) 46 | (current-continuation-marks))))))) 47 | 48 | (define (make-sql-deleter #:who who 49 | #:table table-name 50 | #:resolve [resolve-ref #f]) 51 | (define stmt (sqlite-statement who (~sql "DELETE FROM " table-name " WHERE id = ?"))) 52 | (procedure-rename 53 | (λ (ref #:who [who who] #:resolve? [resolve? #t]) 54 | (call-with-transaction/retry 55 | #:option 'immediate 56 | (λ () 57 | (query-exec stmt (if (and resolve? resolve-ref) 58 | (resolve-ref ref #:who who) 59 | ref))))) 60 | who)) 61 | 62 | (define (make-sql-getter #:who who 63 | #:table table-name 64 | #:field field-name 65 | #:resolve [resolve-ref #f] 66 | #:convert [convert-value values]) 67 | (define stmt (sqlite-statement who (~sql "SELECT " field-name " FROM " table-name " WHERE id = ?"))) 68 | (procedure-rename 69 | (λ (ref #:who [who who] #:resolve? [resolve? #t]) 70 | (call-with-transaction/retry 71 | (λ () 72 | (convert-value (query-value stmt (if (and resolve? resolve-ref) 73 | (resolve-ref ref #:who who) 74 | ref)))))) 75 | who)) 76 | 77 | (define (make-sql-setter #:who who 78 | #:table table-name 79 | #:field field-name 80 | #:resolve [resolve-ref #f] 81 | #:convert [convert-value values]) 82 | (define stmt (sqlite-statement who (~sql "UPDATE " table-name " SET " field-name " = ?2 WHERE id = ?1"))) 83 | (procedure-rename 84 | (λ (ref value #:who [who who] #:resolve? [resolve? #t]) 85 | (call-with-transaction/retry 86 | #:option 'immediate 87 | (λ () 88 | (query-exec stmt 89 | (if (and resolve? resolve-ref) 90 | (resolve-ref ref #:who who) 91 | ref) 92 | (convert-value value))))) 93 | who)) 94 | 95 | ;; ----------------------------------------------------------------------------- 96 | 97 | (begin-for-syntax 98 | (define (racket-name->sql-name name) 99 | (let* ([name (string-replace (symbol->string name) "-" "_")] 100 | [name (if (char=? (string-ref name (sub1 (string-length name))) #\?) 101 | (string-append "is_" (substring name 0 (sub1 (string-length name)))) 102 | name)]) 103 | (string->symbol name))) 104 | 105 | (define-syntax-class (table-field-decl table-name sql-table-name-e resolve-e) 106 | #:description "field declaration" #:no-delimit-cut 107 | #:attributes [{defn 1}] 108 | #:literals [field] 109 | (pattern (field ~! name:id 110 | {~alt {~optional {~seq #:sql-name {~var sql-name-e* (expr/c #'symbol? #:name "#:sql-name argument")} 111 | {~bind [sql-name-e (generate-temporary #'name)]}} 112 | #:defaults ([sql-name-e #`(quote #,(racket-name->sql-name (syntax-e #'name)))])} 113 | {~optional {~seq #:getter 114 | {~optional getter-name:id 115 | #:defaults ([getter-name (format-id #'name "~a-~a" table-name #'name #:subs? #t)])}}} 116 | {~optional {~seq #:setter 117 | {~optional setter-name:id 118 | #:defaults ([setter-name (format-id #'name "set-~a-~a!" table-name #'name #:subs? #t)])}}} 119 | {~optional {~seq #:convert 120 | {~var sql->racket-e (expr/c #'convert/c #:name "#:convert argument")} 121 | {~var racket->sql-e (expr/c #'convert/c #:name "#:convert argument")} 122 | {~bind [sql->racket (generate-temporary #'name)] 123 | [racket->sql (generate-temporary #'name)]}}}} 124 | ...) 125 | #:attr resolve-e resolve-e 126 | #:with [defn ...] 127 | #`[{~? (define sql-name-e sql-name-e*.c)} 128 | {~? {~@ (define sql->racket sql->racket-e.c) 129 | (define racket->sql racket->sql-e.c)}} 130 | {~? (define getter-name 131 | (make-sql-getter #:who 'getter-name 132 | #:table #,sql-table-name-e 133 | #:field sql-name-e 134 | {~? {~@ #:resolve resolve-e}} 135 | {~? {~@ #:convert sql->racket}}))} 136 | {~? (define setter-name 137 | (make-sql-setter #:who 'setter-name 138 | #:table #,sql-table-name-e 139 | #:field sql-name-e 140 | {~? {~@ #:resolve resolve-e}} 141 | {~? {~@ #:convert racket->sql}}))}]))) 142 | 143 | (define-syntax-parser define-sql-table 144 | #:track-literals 145 | [(_ table-name:id 146 | {~alt {~optional {~seq #:sql-name {~var sql-name-e* (expr/c #'symbol? #:name "#:sql-name argument")} 147 | {~bind [sql-name-e (generate-temporary #'table-name)]}} 148 | #:defaults ([sql-name-e #`(quote #,(racket-name->sql-name (syntax-e #'table-name)))])} 149 | {~optional {~seq #:resolve {~var resolve-e* (expr/c #'resolver/c #:name "#:resolve argument")} 150 | {~bind [resolve-e (generate-temporary #'table-name)]}}} 151 | {~optional {~seq #:deleter 152 | {~optional deleter-name:id 153 | #:defaults ([deleter-name (format-id #'table-name "delete-~a!" #'table-name #:subs? #t)])}}}} 154 | ... 155 | {~var field-decl (table-field-decl #'table-name #'sql-name-e (attribute resolve-e))} ...) 156 | #`(begin 157 | {~? (define sql-name-e sql-name-e*.c)} 158 | {~? (define resolve-e resolve-e*.c)} 159 | {~? (define deleter-name 160 | (make-sql-deleter #:who 'deleter-name 161 | #:table sql-name-e 162 | {~? {~@ #:resolve resolve-e}}))} 163 | field-decl.defn ... ...)]) 164 | -------------------------------------------------------------------------------- /toolbox-doc/scribblings/toolbox/logging.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require "private/common.rkt") 4 | 5 | @title[#:tag "logging"]{Logging} 6 | @defmodule[toolbox/logging] 7 | 8 | @(define (log-id-level-fns) 9 | (define id @racketvarfont{id}) 10 | @list{@racketplainfont{log-@|id|-fatal}, @racketplainfont{log-@|id|-error}, @racketplainfont{log-@|id|-warning}, @racketplainfont{log-@|id|-info}, and @racketplainfont{log-@|id|-debug}}) 11 | 12 | @defform[#:kind "provide syntax" 13 | (logger-out id)]{ 14 | When used in @racket[provide], exports @log-id-level-fns[].} 15 | 16 | @defform[(define-log-message-transformers id logger-expr) 17 | #:contracts ([logger-expr logger?])]{ 18 | Defines @log-id-level-fns[] as forms like @racket[log-fatal], @racket[log-error], @racket[log-warning], @racket[log-info], and @racket[log-debug], with two differences: 19 | @itemlist[ 20 | @item{The defined forms log messages to @racket[logger-expr] instead of the @reftech{current logger}.} 21 | @item{A @racket[log-message-info] structure is sent to the logger instead of @racket[(current-continuation-marks)].}]} 22 | 23 | @defform[(define-root-logger id 24 | option ...) 25 | #:grammar ([option (code:line #:topic topic-expr) 26 | (code:line #:parent parent-expr)]) 27 | #:contracts ([topic-expr (or/c symbol? #f)] 28 | [parent-expr (or/c logger? #f)])]{ 29 | Defines @racketplainfont{@racket[id]-logger} as a new @reftech{logger}. The logger’s default topic is the result of @racket[topic-expr], or @racket['@#,racket[id]] if no @racket[topic-expr] is provided. The logger’s parent is the result of @racket[parent-expr], or @racket[(current-logger)] if no @racket[parent-expr] is provided. 30 | 31 | The @racket[define-root-logger] form also defines @log-id-level-fns[] in the same way as @racket[define-log-message-transformers], with @racketplainfont{@racket[id]-logger} as the target logger. 32 | 33 | Finally, @racket[define-root-logger] defines @racketplainfont{define-@racket[id]-logger} as a form like @racket[define-root-logger] itself, except @racketplainfont{@racket[id]-logger} is always used as the parent logger (and the @racket[#:parent] option is not allowed). This form can be used to conveniently define child loggers to form a logging hierarchy. 34 | 35 | @(toolbox-examples 36 | (define-root-logger toolbox) 37 | (define toolbox-receiver (make-log-receiver toolbox-logger 'debug)) 38 | (log-toolbox-info "message on the root logger") 39 | (sync toolbox-receiver) 40 | (define-toolbox-logger toolbox:example) 41 | (log-toolbox:example-debug "message on a child logger") 42 | (sync toolbox-receiver))} 43 | 44 | @defstruct[log-message-info ([milliseconds rational?] 45 | [continuation-marks continuation-mark-set?])]{ 46 | A structure type used by the forms defined by @racket[define-log-message-transformers] to record when and from where a message was sent to a logger. The value of the @racket[milliseconds] field should be @racket[(current-inexact-milliseconds)] and the value of the @racket[continuation-marks] field should be @racket[(current-continuation-marks)]. 47 | 48 | The @racket[log-message-info] structure type implements @racket[gen:moment-provider] using the value of the @racket[milliseconds] field.} 49 | 50 | @section[#:tag "logging:writers"]{Log writers} 51 | 52 | @(define log-writer-eval (make-toolbox-eval)) 53 | @defproc[(spawn-pretty-log-writer [receiver (evt/c (vector/c log-level/c string? any/c (or/c symbol? #f)))] 54 | [#:out out output-port? (current-output-port)] 55 | [#:process-name process-name any/c #f] 56 | [#:millis? millis? any/c #f] 57 | [#:color? color? any/c (terminal-port? out)]) 58 | log-writer?]{ 59 | Starts a new @reftech{thread} that repeatedly synchronizes on @racket[receiver] (which is usually the result of a call to @racket[make-log-receiver]) and writes a formatted version of each @reftech{synchronization result} to @racket[out]. The result of @racket[spawn-pretty-log-writer] is a @deftech{log writer} handle that can be used to flush or terminate the writer thread. 60 | 61 | @(toolbox-examples 62 | #:eval log-writer-eval 63 | (eval:alts (define-root-logger toolbox) 64 | (define-root-logger toolbox #:parent #f)) 65 | (define writer (spawn-pretty-log-writer 66 | (make-log-receiver toolbox-logger 'debug))) 67 | (log-toolbox-info "an informational message") 68 | #:hidden (flush-log-writer writer) 69 | (log-toolbox-fatal "a fatal message!!") 70 | #:hidden (flush-log-writer writer) 71 | (close-log-writer writer)) 72 | 73 | Because log messages are written asynchronously, most programs should explicitly call @racket[close-log-writer] to ensure all log messages are flushed before exiting. Otherwise, messages logged immediately prior to termination may be lost. 74 | 75 | If @racket[process-name] is not @racket[#f], it is written after the topic and log level using @racket[display]: 76 | 77 | @(toolbox-interaction 78 | #:eval log-writer-eval 79 | (eval:alts (spawn-pretty-log-writer (make-log-receiver toolbox-logger 'debug) 80 | #:process-name 'worker) 81 | (begin 82 | (define writer (spawn-pretty-log-writer (make-log-receiver toolbox-logger 'debug) 83 | #:process-name 'worker)) 84 | writer)) 85 | (log-toolbox-info "message from a worker process") 86 | #:hidden (close-log-writer writer)) 87 | 88 | If the third element of the result of @racket[receiver] implements @racket[gen:moment-provider], @racket[->moment] is used to extract a timestamp for the message. Otherwise, the timestamp is based on the moment the message is received, rather than when the message was logged, which can be substantially less accurate. The logging forms defined by @racket[define-log-message-transformers] send a @racket[log-message-info] structure with each message, which @emph{do} implement @racket[gen:moment-provider] and supply a reliable timestamp. 89 | 90 | If @racket[millis?] is not @racket[#f], timestamps are written with millisecond precision. However, see the caveat about timestamp accuracy from the previous paragraph. 91 | 92 | @(toolbox-examples 93 | #:eval log-writer-eval 94 | (eval:alts (spawn-pretty-log-writer (make-log-receiver toolbox-logger 'debug) 95 | #:millis? #t) 96 | (begin 97 | (define writer (spawn-pretty-log-writer (make-log-receiver toolbox-logger 'debug) 98 | #:millis? #t)) 99 | writer)) 100 | (log-toolbox-info "high-precision message") 101 | #:hidden (close-log-writer writer)) 102 | 103 | If @racket[color?] is not @racket[#f], @hyperlink["https://en.wikipedia.org/wiki/ANSI_escape_code"]{ANSI escape codes} are included in the formatted output to colorize the output for log levels other than @racket['info].} 104 | @(close-eval log-writer-eval) 105 | 106 | @defproc[(log-writer? [v any/c]) boolean?]{ 107 | Returns @racket[#t] if @racket[v] is a @tech{log writer} handle returned by @racket[spawn-pretty-log-writer], otherwise returns @racket[#f].} 108 | 109 | @defproc[(close-log-writer [writer log-writer?] 110 | [#:wait? wait? any/c #t]) 111 | void?]{ 112 | Closes the given @tech{log writer} by flushing all pending log messages and terminating the writer thread. If @racket[wait?] is not @racket[#f], the call to @racket[close-log-writer] blocks until the shutdown is complete. If @racket[writer] is already closed, @racket[close-log-writer] has no effect.} 113 | 114 | @defproc[(log-writer-closed? [writer log-writer?]) boolean?]{ 115 | Returns @racket[#t] if the given @tech{log writer} has been closed by @racket[close-log-writer] or if its writer thread has been killed by some other means. Otherwise, @racket[log-writer-closed?] returns @racket[#f].} 116 | 117 | @defproc[(flush-log-writer [writer (and/c log-writer? (not/c log-writer-closed?))]) void?]{ 118 | Forces the given @tech{log writer} to write any pending messages, blocking until all messages have been written. 119 | 120 | This function is not generally necessary, as @racket[spawn-pretty-log-writer] calls @racket[flush-output] after writing each log message it receives @emph{regardless} of whether @racket[flush-log-writer] is used. The @emph{only} effect of @racket[flush-log-writer] is to block the calling thread until the log writer thread has had a chance to receive and write any pending messages. However, this can rarely be useful if the calling thread writes to the same output port and wants to avoid output being interleaved, for example.} 121 | 122 | @section[#:tag "toolbox-logger"]{Toolbox logger} 123 | @defmodule[toolbox/logger] 124 | 125 | @defthing[toolbox-logger logger?]{ 126 | A @reftech{logger} used by various functions in this library. Generally, messages are not written to @racket[toolbox-logger] directly, but it serves as a parent logger for module-specific loggers, such as @racket[toolbox:db-logger].} 127 | -------------------------------------------------------------------------------- /toolbox-lib/toolbox/logging.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base 4 | racket/provide-transform 5 | racket/syntax) 6 | data/mvar 7 | gregor 8 | racket/contract 9 | racket/format 10 | racket/logging 11 | racket/match 12 | syntax/parse/define 13 | "who.rkt") 14 | 15 | (provide logger-out 16 | define-root-logger 17 | define-log-message-transformers 18 | 19 | (contract-out 20 | (struct log-message-info ([milliseconds rational?] 21 | [continuation-marks continuation-mark-set?])) 22 | [log-writer? predicate/c] 23 | [log-writer-closed? (-> log-writer? boolean?)] 24 | [flush-log-writer (-> log-writer? void?)] 25 | [close-log-writer (->* [log-writer?] [#:wait? any/c] void?)] 26 | [spawn-pretty-log-writer 27 | (->* [(evt/c (vector/c log-level/c string? any/c (or/c symbol? #f)))] 28 | [#:out output-port? 29 | #:process-name any/c 30 | #:millis? any/c 31 | #:color? any/c] 32 | log-writer?)])) 33 | 34 | ;; ----------------------------------------------------------------------------- 35 | 36 | (begin-for-syntax 37 | (define log-level-syms '(fatal error warning info debug)) 38 | (define (make-logger-id name-id) 39 | (format-id name-id "~a-logger" name-id #:subs? #t)) 40 | (define (make-log-message-id name-id level) 41 | (format-id name-id "log-~a-~a" name-id level #:subs? #t)) 42 | (define (make-logger-definer-id name-id) 43 | (format-id name-id "define-~a-logger" name-id #:subs? #t))) 44 | 45 | (define-syntax logger-out 46 | (make-provide-transformer 47 | (λ (stx modes) 48 | (syntax-parse stx 49 | [(_ name:id) 50 | (expand-export 51 | #`(combine-out 52 | #,(make-logger-id #'name) 53 | #,@(for/list ([level (in-list log-level-syms)]) 54 | (make-log-message-id #'name level))) 55 | modes)])))) 56 | 57 | (struct log-message-info (milliseconds continuation-marks) 58 | #:transparent 59 | #:methods gen:moment-provider 60 | [(define (->moment self) 61 | (posix->moment (/ (log-message-info-milliseconds self) 1000) "Etc/UTC"))]) 62 | 63 | (define (current-log-message-info) 64 | (log-message-info (current-inexact-milliseconds) 65 | (current-continuation-marks))) 66 | 67 | (begin-for-syntax 68 | (define (make-log-message-transformer logger-id level-sym) 69 | (syntax-parser 70 | [(_ {~or* str:expr {~seq format-str:expr val:expr ...+}}) 71 | #`(when (log-level? #,logger-id '#,level-sym) 72 | (log-message #,logger-id 73 | '#,level-sym 74 | {~? (format format-str val ...) str} 75 | (current-log-message-info) 76 | #f))]))) 77 | 78 | (define-syntax-parser define-log-message-transformers 79 | [(_ name:id {~var logger-e (expr/c #'logger?)}) 80 | (define/with-syntax logger (generate-temporary #'name)) 81 | #`(begin 82 | (define logger logger-e.c) 83 | #,@(for/list ([level (in-list log-level-syms)]) 84 | #`(define-syntax #,(make-log-message-id #'name level) 85 | (make-log-message-transformer (quote-syntax logger) '#,level))))]) 86 | 87 | (define symbol-or-false/c (or/c symbol? #f)) 88 | (define logger-or-false/c (or/c logger? #f)) 89 | 90 | (begin-for-syntax 91 | (define (make-logger-definer-transformer parent-logger-id) 92 | (syntax-parser 93 | [(_ name:id 94 | {~alt {~optional {~seq #:topic {~var topic-e (expr/c #'symbol-or-false/c #:name "topic")}} 95 | #:defaults ([topic-e.c #''name])} 96 | {~optional {~seq {~fail #:when (and parent-logger-id #t)} 97 | #:parent {~var parent-e (expr/c #'logger-or-false/c #:name "parent logger")}} 98 | #:defaults ([parent-e.c (or parent-logger-id #'(current-logger))])}} 99 | ...) 100 | (define/with-syntax name-logger (make-logger-id #'name)) 101 | (define/with-syntax define-name-logger (make-logger-definer-id #'name)) 102 | #`(begin 103 | (define name-logger (make-logger topic-e.c parent-e.c)) 104 | (define-syntax define-name-logger 105 | (make-logger-definer-transformer (quote-syntax name-logger))) 106 | (define-log-message-transformers name name-logger))]))) 107 | 108 | (define-syntax define-root-logger (make-logger-definer-transformer #f)) 109 | 110 | ;; ----------------------------------------------------------------------------- 111 | 112 | (define tty:reset #"\e[m") 113 | (define tty:bold #"\e[1m") 114 | (define tty:red #"\e[31m") 115 | (define tty:yellow #"\e[33m") 116 | (define tty:blue #"\e[34m") 117 | 118 | (struct log-writer 119 | (process-name 120 | flush-mv ; filled to initiate a flush, emptied when flush is complete 121 | shutdown-mv ; filled to initiate a shutdown, stays full 122 | dead-evt) 123 | #:property prop:custom-write 124 | (λ (self out mode) 125 | (define name (log-writer-process-name self)) 126 | (if name 127 | (fprintf out "#" name) 128 | (write-string "#" out)))) 129 | 130 | (define (log-writer-closed-evt lw) 131 | (choice-evt (mvar-peek-evt (log-writer-shutdown-mv lw)) 132 | (log-writer-dead-evt lw))) 133 | 134 | (define (log-writer-closed? lw) 135 | (and (sync/timeout 0 (log-writer-closed-evt lw)) #t)) 136 | 137 | (define/who (flush-log-writer lw) 138 | (define flush-mv (log-writer-flush-mv lw)) 139 | (mvar-try-put! flush-mv #t) 140 | (sync (mvar-empty-evt flush-mv) 141 | (handle-evt 142 | (log-writer-closed-evt lw) 143 | (λ (x) 144 | (raise-arguments-error who "log writer is closed" 145 | "log writer" lw)))) 146 | (void)) 147 | 148 | (define (close-log-writer lw #:wait? [wait? #t]) 149 | (mvar-try-put! (log-writer-shutdown-mv lw) #t) 150 | (when wait? 151 | (sync (log-writer-dead-evt lw))) 152 | (void)) 153 | 154 | (define (spawn-pretty-log-writer receiver 155 | #:out [out (current-output-port)] 156 | #:process-name [process-name #f] 157 | #:millis? [millis? #f] 158 | #:color? [color?* (terminal-port? out)]) 159 | (define color? (and color?* #t)) 160 | (define timestamp-format (if millis? 161 | "yyyy-MM-dd HH:mm:ss.SSS" 162 | "yyyy-MM-dd HH:mm:ss")) 163 | (define process-name-str (and process-name (~a process-name))) 164 | 165 | (define (write-log-message level topic msg value) 166 | (define timestamp (if (moment-provider? value) 167 | (adjust-timezone (->moment value) (current-timezone)) 168 | (now))) 169 | (when color? 170 | (match level 171 | [(or 'fatal 'error) 172 | (write-bytes tty:bold out) 173 | (write-bytes tty:red out)] 174 | ['warning 175 | (write-bytes tty:bold out) 176 | (write-bytes tty:yellow out)] 177 | ['info 178 | (void)] 179 | ['debug 180 | (write-bytes tty:blue out)])) 181 | (write-string 182 | (~a "[" (~t timestamp timestamp-format) "] [" 183 | (if topic (~a topic "/") "") 184 | (match level 185 | ['fatal "FATAL"] 186 | ['error "ERROR"] 187 | ['warning "WARN"] 188 | ['info "INFO"] 189 | ['debug "DEBUG"]) 190 | (if process-name-str (~a "@" process-name-str) "") 191 | "] " 192 | msg 193 | (if color? 194 | (match level 195 | ['info ""] 196 | [_ tty:reset]) 197 | "")) 198 | out) 199 | (when color? 200 | (match level 201 | ['info (void)] 202 | [_ (write-bytes tty:reset out)])) 203 | (newline out) 204 | (flush-output out)) 205 | 206 | (define flush-mv (make-mvar)) 207 | (define shutdown-mv (make-mvar)) 208 | (define writer-thread 209 | (thread 210 | (λ () 211 | (define (do-flush) 212 | (let flush-loop () 213 | (match (sync/timeout 0 receiver) 214 | [(vector level msg value topic) 215 | (write-log-message level topic msg value) 216 | (flush-loop)] 217 | [#f 218 | (void)]))) 219 | 220 | (define flush-evt (handle-evt (mvar-peek-evt flush-mv) (λ (v) 'flush))) 221 | (define shutdown-evt (handle-evt (mvar-peek-evt shutdown-mv) (λ (v) 'shutdown))) 222 | (let loop () 223 | (match (sync receiver flush-evt shutdown-evt) 224 | [(vector level msg value topic) 225 | (write-log-message level topic msg value) 226 | (loop)] 227 | ['flush 228 | (do-flush) 229 | (mvar-try-take! flush-mv) 230 | (loop)] 231 | ['shutdown 232 | (do-flush)]))))) 233 | 234 | (log-writer process-name-str 235 | flush-mv 236 | shutdown-mv 237 | (thread-dead-evt writer-thread))) 238 | -------------------------------------------------------------------------------- /toolbox-db-lib/toolbox/db/private/query.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/require 4 | (subtract-in db/base "base.rkt") 5 | (prefix-in db: db/base) 6 | racket/class 7 | racket/contract 8 | racket/match 9 | racket/string 10 | toolbox/format 11 | toolbox/who 12 | "base.rkt" 13 | "sqlite3/explain.rkt" 14 | "sqlite3/ffi.rkt") 15 | 16 | (provide (contract-out 17 | [current-log-db-queries? (parameter/c any/c boolean?)] 18 | [current-explain-db-queries? (parameter/c any/c boolean?)] 19 | [current-analyze-db-queries? (parameter/c any/c boolean?)] 20 | 21 | [query (query-func/c (or/c simple-result? rows-result?))] 22 | [query-exec (query-func/c void?)] 23 | [query-rows (->* [(or/c string? virtual-statement? prepared-statement?)] 24 | [#:db connection? 25 | #:group groupings/c 26 | #:group-mode (listof (or/c 'preserve-null 'list)) 27 | #:log? any/c 28 | #:explain? any/c 29 | #:analyze? any/c] 30 | #:rest any/c 31 | (listof vector?))] 32 | [query-list (query-func/c list?)] 33 | [query-row (query-func/c vector?)] 34 | [query-maybe-row (query-func/c (or/c vector? #f))] 35 | [query-value (query-func/c any/c)] 36 | [query-maybe-value (query-func/c any/c)] 37 | 38 | [query-changes (->* [] [#:db connection?] exact-nonnegative-integer?)])) 39 | 40 | ;; ----------------------------------------------------------------------------- 41 | 42 | (define-toolbox:db-logger toolbox:db:query) 43 | 44 | ;; ----------------------------------------------------------------------------- 45 | 46 | (define current-log-db-queries? (make-parameter #f (λ (v) (and v #t)))) 47 | (define current-explain-db-queries? (make-parameter #f (λ (v) (and v #t)))) 48 | (define current-analyze-db-queries? (make-parameter #f (λ (v) (and v #t)))) 49 | 50 | (define (query-func/c result/c) 51 | (->* [(or/c string? virtual-statement? prepared-statement?)] 52 | [#:db connection? 53 | #:log? any/c 54 | #:explain? any/c 55 | #:analyze? any/c] 56 | #:rest any/c 57 | result/c)) 58 | 59 | (define field/c (or/c string? exact-nonnegative-integer?)) 60 | (define grouping/c (or/c field/c (vectorof field/c))) 61 | (define groupings/c (or/c grouping/c (listof grouping/c))) 62 | 63 | (define (do-query stmt query-proc 64 | #:who who 65 | #:db db 66 | #:log? log? 67 | #:explain? explain? 68 | #:analyze? analyze?) 69 | 70 | (define p-stmt (if (prepared-statement? stmt) 71 | stmt 72 | (db:prepare db stmt))) 73 | 74 | (define (maybe-log-query) 75 | (when log? 76 | (define sql (send p-stmt get-stmt)) 77 | (if (string-contains? sql "\n") 78 | (log-toolbox:db:query-info "\n~a" sql) 79 | (log-toolbox:db:query-info "~a" sql)))) 80 | 81 | (define (really-do-query) 82 | (cond 83 | [log? 84 | (define pre-ms (current-inexact-monotonic-milliseconds)) 85 | (define result (query-proc p-stmt)) 86 | (define post-ms (current-inexact-monotonic-milliseconds)) 87 | (log-toolbox:db:query-info "~a ms" (~r* (- post-ms pre-ms) #:precision 1)) 88 | result] 89 | [else 90 | (query-proc p-stmt)])) 91 | 92 | (match (dbsystem-name (connection-dbsystem db)) 93 | ['sqlite3 94 | (when analyze? 95 | (check-sqlite3-stmt-scanstatus-enabled who "cannot analyze query")) 96 | (define ffi-stmt 97 | (and (or explain? analyze?) 98 | (let () 99 | (define ffi-stmt (send p-stmt get-handle)) 100 | (unless (sqlite3_statement? ffi-stmt) 101 | (error who "failed to obtain sqlite3 statement handle\n handle: ~e" ffi-stmt)) 102 | ffi-stmt))) 103 | 104 | (maybe-log-query) 105 | 106 | (define (log-query-plan-explanation root-node) 107 | (define out (open-output-string)) 108 | (print-query-plan-explanation root-node out) 109 | (log-toolbox:db:query-info "~a" (string-trim (get-output-string out)))) 110 | 111 | (cond 112 | [(or analyze? (and explain? (sqlite3-stmt-scanstatus-enabled?))) 113 | (sqlite3_stmt_scanstatus_reset ffi-stmt) 114 | ;; Use scanstatus for ordinary `explain?` when available, since it includes estimates. 115 | (when explain? 116 | (log-query-plan-explanation 117 | (build-query-plan-explanation/scan-status ffi-stmt)))] 118 | [explain? 119 | ;; Fall back to running an EXPLAIN QUERY PLAN query if scanstatus is not available. 120 | (cond 121 | ;; Try to use `sqlite3_stmt_explain` to avoid a re-prepare if possible. 122 | [sqlite3_stmt_explain 123 | (when (= (sqlite3_stmt_isexplain ffi-stmt) SQLITE_EXPLAIN_NORMAL) 124 | (define eqp-rows 125 | (dynamic-wind 126 | (λ () 127 | (sqlite3_reset ffi-stmt) 128 | (sqlite3_stmt_explain ffi-stmt SQLITE_EXPLAIN_QUERY_PLAN)) 129 | (λ () 130 | (db:query-rows db p-stmt)) 131 | (λ () 132 | (sqlite3_reset ffi-stmt) 133 | (sqlite3_stmt_explain ffi-stmt SQLITE_EXPLAIN_NORMAL)))) 134 | (log-query-plan-explanation 135 | (build-query-plan-explanation eqp-rows)))] 136 | ;; Otherwise, just re-prepare the query. 137 | [else 138 | (log-query-plan-explanation 139 | (build-query-plan-explanation 140 | (db:query-rows db (string-append "EXPLAIN QUERY PLAN\n" (send p-stmt get-stmt)))))])]) 141 | 142 | (define result (really-do-query)) 143 | 144 | (when analyze? 145 | (log-query-plan-explanation 146 | (build-query-plan-explanation/scan-status ffi-stmt))) 147 | 148 | result] 149 | [sys-name 150 | (when explain? 151 | (raise (exn:fail:unsupported 152 | (format "~a: cannot explain query; unsupported dbsystem\n dbsystem: ~e" who sys-name) 153 | (current-continuation-marks)))) 154 | (when analyze? 155 | (raise (exn:fail:unsupported 156 | (format "~a: cannot analyze query; unsupported dbsystem\n dbsystem: ~e" who sys-name) 157 | (current-continuation-marks)))) 158 | (maybe-log-query) 159 | (really-do-query)])) 160 | 161 | (define/who (query stmt 162 | #:db [db (get-db 'query)] 163 | #:log? [log? (current-log-db-queries?)] 164 | #:explain? [explain? (current-explain-db-queries?)] 165 | #:analyze? [analyze? (current-analyze-db-queries?)] 166 | . args) 167 | (do-query 168 | #:who who 169 | #:db db 170 | #:log? log? 171 | #:explain? explain? 172 | #:analyze? analyze? 173 | stmt (λ (stmt) (apply db:query db stmt args)))) 174 | 175 | (define/who (query-exec stmt 176 | #:db [db (get-db 'query-exec)] 177 | #:log? [log? (current-log-db-queries?)] 178 | #:explain? [explain? (current-explain-db-queries?)] 179 | #:analyze? [analyze? (current-analyze-db-queries?)] 180 | . args) 181 | (do-query 182 | #:who who 183 | #:db db 184 | #:log? log? 185 | #:explain? explain? 186 | #:analyze? analyze? 187 | stmt (λ (stmt) (apply db:query-exec db stmt args)))) 188 | 189 | (define/who (query-rows stmt 190 | #:db [db (get-db 'query-rows)] 191 | #:group [groupings '()] 192 | #:group-mode [group-mode '()] 193 | #:log? [log? (current-log-db-queries?)] 194 | #:explain? [explain? (current-explain-db-queries?)] 195 | #:analyze? [analyze? (current-analyze-db-queries?)] 196 | . args) 197 | (do-query 198 | #:who who 199 | #:db db 200 | #:log? log? 201 | #:explain? explain? 202 | #:analyze? analyze? 203 | stmt (λ (stmt) (apply db:query-rows db stmt args 204 | #:group groupings 205 | #:group-mode group-mode)))) 206 | 207 | (define/who (query-list stmt 208 | #:db [db (get-db 'query-list)] 209 | #:log? [log? (current-log-db-queries?)] 210 | #:explain? [explain? (current-explain-db-queries?)] 211 | #:analyze? [analyze? (current-analyze-db-queries?)] 212 | . args) 213 | (do-query 214 | #:who who 215 | #:db db 216 | #:log? log? 217 | #:explain? explain? 218 | #:analyze? analyze? 219 | stmt (λ (stmt) (apply db:query-list db stmt args)))) 220 | 221 | (define/who (query-row stmt 222 | #:db [db (get-db 'query-row)] 223 | #:log? [log? (current-log-db-queries?)] 224 | #:explain? [explain? (current-explain-db-queries?)] 225 | #:analyze? [analyze? (current-analyze-db-queries?)] 226 | . args) 227 | (do-query 228 | #:who who 229 | #:db db 230 | #:log? log? 231 | #:explain? explain? 232 | #:analyze? analyze? 233 | stmt (λ (stmt) (apply db:query-row db stmt args)))) 234 | 235 | (define/who (query-maybe-row stmt 236 | #:db [db (get-db 'query-maybe-row)] 237 | #:log? [log? (current-log-db-queries?)] 238 | #:explain? [explain? (current-explain-db-queries?)] 239 | #:analyze? [analyze? (current-analyze-db-queries?)] 240 | . args) 241 | (do-query 242 | #:who who 243 | #:db db 244 | #:log? log? 245 | #:explain? explain? 246 | #:analyze? analyze? 247 | stmt (λ (stmt) (apply db:query-maybe-row db stmt args)))) 248 | 249 | (define/who (query-value stmt 250 | #:db [db (get-db 'query-value)] 251 | #:log? [log? (current-log-db-queries?)] 252 | #:explain? [explain? (current-explain-db-queries?)] 253 | #:analyze? [analyze? (current-analyze-db-queries?)] 254 | . args) 255 | (do-query 256 | #:who who 257 | #:db db 258 | #:log? log? 259 | #:explain? explain? 260 | #:analyze? analyze? 261 | stmt (λ (stmt) (apply db:query-value db stmt args)))) 262 | 263 | (define/who (query-maybe-value stmt 264 | #:db [db (get-db 'query-maybe-value)] 265 | #:log? [log? (current-log-db-queries?)] 266 | #:explain? [explain? (current-explain-db-queries?)] 267 | #:analyze? [analyze? (current-analyze-db-queries?)] 268 | . args) 269 | (do-query 270 | #:who who 271 | #:db db 272 | #:log? log? 273 | #:explain? explain? 274 | #:analyze? analyze? 275 | stmt (λ (stmt) (apply db:query-maybe-value db stmt args)))) 276 | 277 | ;; ----------------------------------------------------------------------------- 278 | 279 | (define/who (query-changes #:db [db (get-db who)]) 280 | (match (dbsystem-name (connection-dbsystem db)) 281 | ['sqlite3 282 | (db:query-value db "SELECT changes()")] 283 | [sys-name 284 | (raise (exn:fail:unsupported 285 | (format "~a: unsupported dbsystem\n dbsystem: ~e" who sys-name) 286 | (current-continuation-marks)))])) 287 | -------------------------------------------------------------------------------- /toolbox-doc/scribblings/toolbox/draw/pict.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(begin 4 | (require scribble/core 5 | scribble/html-properties 6 | "../private/common.rkt") 7 | 8 | (define-id-referencer pict pict) 9 | (define svg-render-style (style #f (list (render-convertible-as '(svg-bytes png-bytes gif-bytes)))))) 10 | 11 | @title[#:tag "pict" #:style svg-render-style]{Pict} 12 | @defmodule[#:multi [toolbox/pict toolbox/pict/base]] 13 | 14 | The @racketmodname[toolbox/pict/base] module exports all of the bindings documented in this section. The @racketmodname[toolbox/pict] module re-exports everything from @racketmodname[pict], @racketmodname[pict/conditional], @racketmodname[ppict/tag], and @racketmodname[toolbox/pict/base], except exports from later modules shadow exports from earlier ones with the same name. 15 | 16 | @section[#:tag "pict:constructors"]{Constructors} 17 | 18 | @defproc[(arrowhead [size (and/c rational? (not/c negative?))] 19 | [radians rational? 0]) 20 | pict?]{ 21 | Like @id-from-pict[arrowhead], but only draws a fill, not a stroke (and @racket[radians] is optional). 22 | 23 | @(toolbox-examples 24 | (arrowhead 30))} 25 | 26 | @defproc[(arrow-line [#:arrow-size arrow-size (and/c rational? (not/c negative?)) 10] 27 | [#:line-length line-length (and/c rational? (not/c negative?)) 50] 28 | [#:line-width line-width (or/c (and/c rational? (not/c negative?)) #f) 2]) 29 | pict?]{ 30 | Draws a right-facing arrow built from an arrowhead of size @racket[arrow-size] and a tail line of length @racket[line-length] and stroke width @racket[line-width]. If @racket[line-width] is @racket[#f], the current pen width is used. 31 | 32 | @(toolbox-examples 33 | (arrow-line))} 34 | 35 | @section[#:tag "pict:combine"]{Combiners} 36 | 37 | @defproc*[([(pin-over [base pict?] 38 | [dx rational?] 39 | [dy rational?] 40 | [pict pict?] 41 | [#:hole hole 42 | (or/c (vector/c rational? rational?) 43 | (vector/c pict-path? pict-finder/c) 44 | pict-finder/c) 45 | #(0 0)]) 46 | pict?] 47 | [(pin-over [base pict?] 48 | [path pict-path?] 49 | [find pict-finder/c] 50 | [pict pict?] 51 | [#:hole hole 52 | (or/c (vector/c rational? rational?) 53 | (vector/c pict-path? pict-finder/c) 54 | pict-finder/c) 55 | #(0 0)]) 56 | pict?])]{ 57 | Like @id-from-pict[pin-over], but extended to accept the more general @tech{pict paths} instead of @tech{tagless pict paths}. Additionally, the @racket[hole] argument specifies a “pinhole” within @racket[pict] that controls how @racket[pict] is aligned to the pin location: 58 | 59 | @itemlist[ 60 | @item{If @racket[hole] is a vector of two @reftech{rational numbers}, the numbers are used as x- and y-coordinates for the pinhole’s location, relative to the top-left corner of @racket[pict].} 61 | 62 | @item{If @racket[hole] is a vector of a @tech{pict path} and a finder procedure, the finder procedure is used to locate a child of @racket[pict], and the resulting coordinates are used as the pinhole.} 63 | 64 | @item{If @racket[hole] is a finder procedure, it is equivalent to supplying the finder procedure with an empty @tech{pict path}.}] 65 | 66 | @(toolbox-examples 67 | (define (bg-rect color) 68 | (filled-rectangle 30 30 69 | #:draw-border? #f 70 | #:color color)) 71 | (define bg 72 | (vc-append (hc-append (bg-rect "light green") 73 | (bg-rect "light blue")) 74 | (hc-append (bg-rect "light blue") 75 | (bg-rect "light green")))) 76 | (define fg 77 | (disk 15 #:color "crimson" 78 | #:draw-border? #f)) 79 | (pin-over bg '() cc-find fg) 80 | (pin-over bg '() cc-find fg #:hole rb-find) 81 | (pin-over bg '() ct-find fg #:hole ct-find))} 82 | 83 | @defproc*[([(pin-under [base pict?] 84 | [dx rational?] 85 | [dy rational?] 86 | [pict pict?] 87 | [#:hole hole 88 | (or/c (vector/c rational? rational?) 89 | (vector/c pict-path? pict-finder/c) 90 | pict-finder/c) 91 | #(0 0)]) 92 | pict?] 93 | [(pin-under [base pict?] 94 | [path pict-path?] 95 | [find pict-finder/c] 96 | [pict pict?] 97 | [#:hole hole 98 | (or/c (vector/c rational? rational?) 99 | (vector/c pict-path? pict-finder/c) 100 | pict-finder/c) 101 | #(0 0)]) 102 | pict?])]{ 103 | Like @id-from-pict[pin-under], but extended in the same ways as @racket[pin-over].} 104 | 105 | @defproc[(line-append [pict pict?] ...+) pict?]{ 106 | Creates a new pict by aligning the descent and ascent lines of each adjacent pair of picts. That is, each @racket[pict] is vertically positioned such that its ascent line (as reported by @racket[pict-ascent]) is aligned with the previous @racket[pict]’s descent line (as reported by @racket[pict-descent]). Each @racket[pict] is horizontally positioned so that it immediately follows the previous @racket[pict]’s last element (as reported by @racket[pict-last]). 107 | 108 | The alignment rules used by @racket[line-append] make it useful for aligning multiline blocks, especially code that uses expression-based indentation. 109 | 110 | @(toolbox-examples 111 | (define (tt str) 112 | (text str 'modern 16)) 113 | (line-append 114 | (vl-append 115 | (tt "(define some-example-with-a-long-first-line") 116 | (tt " (values ")) 117 | (vl-append 118 | (tt "(some-expression)") 119 | (tt "(another-expression)") 120 | (tt "note-the-close-paren!")) 121 | (tt ")")))} 122 | 123 | @section[#:tag "pict:adjust-draw"]{Drawing Adjusters} 124 | 125 | @defproc[(set-smoothing [pict pict?] 126 | [smoothing (or/c 'unsmoothed 'smoothed 'aligned)]) 127 | pict?]{ 128 | Sets the anti-aliased smoothing mode used when drawing @racket[pict] to @racket[smoothing]. For an explanation of the different modes, see @xmethod[dc<%> set-smoothing].} 129 | 130 | @defproc[(set-brush [pict pict?] 131 | [#:color color (or/c color? 'pen #f) (make-color 0 0 0)] 132 | [#:style style (or/c brush-style/c #f) 'solid]) 133 | pict?]{ 134 | Sets the @drawtech{brush} used while drawing @racket[pict]. If any argument is @racket[#f], its value is inherited from whatever brush was installed by the enclosing context. 135 | 136 | As a special case, if @racket[color] is @racket['pen], the brush’s color is set to the current @emph{pen} color. This is intended to be used to follow the convention used by pict constructors like @racket[filled-rectangle], which (for some reason) default to using the current pen color rather than the current brush color if no color is provided. 137 | 138 | @(toolbox-examples 139 | (define rect 140 | (dc (λ (dc x y) 141 | (send dc draw-rectangle x y 50 30)) 142 | 50 30)) 143 | (set-brush rect #:color "red") 144 | (set-brush rect #:style 'fdiagonal-hatch))} 145 | 146 | @defproc[(adjust-brush [pict pict?] 147 | [#:color color (or/c color? 'pen #f) #f] 148 | [#:style style (or/c brush-style/c #f) #f]) 149 | pict?]{ 150 | Like @racket[set-brush], but argument values default to @racket[#f], so any unprovided arguments will be inherited from the current brush.} 151 | 152 | @defproc[(set-pen [pict pict?] 153 | [#:color color (or/c color? #f) (make-color 0 0 0)] 154 | [#:width width (or/c (real-in 0 255) #f) 0] 155 | [#:style style (or/c pen-style/c #f) 'solid] 156 | [#:cap cap (or/c pen-cap-style/c #f) 'round] 157 | [#:join join (or/c pen-join-style/c #f) 'round]) 158 | pict?]{ 159 | Sets the pen used while drawing @racket[pict]. If any argument is @racket[#f], its value is inherited from whatever pen was installed by the enclosing context. 160 | 161 | Note that many pict constructors, like @racket[filled-rectangle], conventionally default (for some reason) to using the current pen color for the fill rather than the current @drawtech{brush} color if no color is provided. For that reason, using @racket[set-pen] to change the pen color can also affect the fill color of picts created that way. 162 | 163 | @(toolbox-examples 164 | (define rect 165 | (dc (λ (dc x y) 166 | (send dc draw-rectangle x y 50 30)) 167 | 50 30)) 168 | (set-pen rect #:color "red" #:width 3) 169 | (set-pen rect #:style 'short-dash #:width 3))} 170 | 171 | @defproc[(adjust-pen [pict pict?] 172 | [#:color color (or/c color? #f) #f] 173 | [#:width width (or/c (real-in 0 255) #f) #f] 174 | [#:style style (or/c pen-style/c #f) #f] 175 | [#:cap cap (or/c pen-cap-style/c #f) #f] 176 | [#:join join (or/c pen-join-style/c #f) #f]) 177 | pict?]{ 178 | Like @racket[set-pen], but argument values default to @racket[#f], so any unprovided arguments will be inherited from the current brush.} 179 | 180 | @section[#:tag "pict:adjust-bounds"]{Bounding Box Adjusters} 181 | 182 | @defproc[(one-line [pict pict?]) pict?]{ 183 | Drops the ascent line (as reported by @racket[pict-ascent]) to the descent line, making the entire pict behave as a single line of text.} 184 | 185 | @defproc[(refocus [pict pict?] [path pict-path?]) pict?]{ 186 | Like @id-from-pict[refocus], but accepts an arbitrary @tech{pict path} to locate the sub-pict to focus on. 187 | 188 | @(toolbox-examples 189 | (define p1 (filled-rectangle 15 30 #:color "sienna")) 190 | (define p2 (hc-append 191 | p1 192 | (filled-rectangle 15 30 #:color "darkkhaki"))) 193 | (define p3 (filled-rectangle 50 50 #:color "khaki")) 194 | (define combined (cc-superimpose p3 p2)) 195 | combined 196 | (refocus combined p2) 197 | (refocus combined (list p2 p1)))} 198 | 199 | @defproc[(refocus* [pict pict?] [paths (non-empty-listof pict-path?)]) pict?]{ 200 | Like @racket[refocus], but shifts the bounding box to encompass @emph{all} of the picts at the given @racket[paths]. Unlike @racket[refocus], @racket[refocus*] does not set @racket[pict-last]. 201 | 202 | @(toolbox-examples 203 | (define p1 (disk 15 #:color "dark sea green")) 204 | (define p2 (filled-rectangle 15 15 #:color "cadet blue")) 205 | (define p3 (rotate (filled-rectangle 15 15 #:color "plum") (/ pi 4))) 206 | (define p4 (vc-append 7 (hc-append 12 p1 p2) p3)) 207 | p4 208 | (refocus* p4 (list p1 p2)) 209 | (refocus* p4 (list p1 p3)) 210 | (refocus* p4 (list p2 p3)))} 211 | 212 | @defproc*[([(recenter [pict pict?] [x rational?] [y rational?]) pict?] 213 | [(recenter [pict pict?] 214 | [path pict-path?] 215 | [find pict-finder/c cc-find]) 216 | pict?])]{ 217 | Insets @racket[pict] so that the chosen point is its new center. In the first form, the @racket[x] and @racket[y] arguments specify a new center point as a coordinate offset from @racket[pict]’s top-left corner. In the second form, the @racket[find] procedure is used to locate a sub-pict at @racket[path] in the same way as @racket[pin-over], and the result is used as the new center point. 218 | 219 | @(toolbox-examples 220 | (define p1 (filled-rectangle 15 15 #:color "slate blue")) 221 | (define p2 (disk 15 #:color "firebrick")) 222 | (define p3 (disk 15 #:color "forest green")) 223 | (define p2+p3 (hc-append 5 p2 p3)) 224 | (frame (vc-append 5 p1 p2+p3)) 225 | (frame (vc-append 5 p1 (recenter p2+p3 p3))))} 226 | 227 | @defproc[(use-last [pict pict?] [path pict-path?]) pict?]{ 228 | Like @id-from-pict[use-last], but accepts an arbitrary @tech{pict path} instead of a @tech{tagless pict path}.} 229 | 230 | @defproc[(use-last* [pict pict?] [path pict-path?]) pict?]{ 231 | Like @id-from-pict[use-last*], but accepts an arbitrary @tech{pict path} instead of a sub-pict.} 232 | 233 | @section[#:tag "pict:path-find"]{Paths and Finders} 234 | 235 | @defproc[(pict-path? [v any/c]) boolean?]{ 236 | Returns @racket[#t] if @racket[v] is a @deftech{pict path}, which is either a @pictech{pict}, a @reftech{symbol}, or a @reftech{list} of picts and symbols. Otherwise, returns @racket[#f]. 237 | 238 | This definition is broader than the one used by @id-from-pict[pict-path?] (which is provided by this library as @racket[tagless-pict-path?]), as it allows pict path elements to be symbols in addition to picts. When a symbol is an element of a pict path, it refers to all children tagged with that symbol via @racket[tag-pict]. Additionally, an empty list may be used as a pict path, which always refers to the root pict.} 239 | 240 | @defproc[(tagless-pict-path? [v any/c]) boolean?]{ 241 | Returns @racket[#t] if @racket[v] is a @deftech{tagless pict path}, which is either a @pictech{pict} or a non-empty @reftech{list} of picts. As the name of this function suggests, a tagless pict path is a @tech{pict path} that contains no symbolic tags (though it additionally requires that a list path be non-empty). 242 | 243 | The @racket[tagless-pict-path?] function is actually the same binding as @id-from-pict[pict-path?], re-exported under a different name.} 244 | 245 | @defproc[(ppath-cons [elem (or/c pict? symbol?)] [path pict-path?]) pict-path?]{ 246 | Prefixes @racket[path] with @racket[elem] to form a larger @tech{pict path}. 247 | 248 | @(toolbox-examples 249 | (eval:check (ppath-cons 'a '()) 'a) 250 | (eval:check (ppath-cons 'a 'b) '(a b)) 251 | (eval:check (ppath-cons 'a '(b c)) '(a b c)))} 252 | 253 | @defproc[(ppath-append [path-a pict-path?] [path-b pict-path?]) pict-path?]{ 254 | Appends @racket[path-a] and @racket[path-b] to form a larger @tech{pict path}. 255 | 256 | @(toolbox-examples 257 | (eval:check (ppath-append 'a 'b) '(a b)) 258 | (eval:check (ppath-append '(a b) 'c) '(a b c)) 259 | (eval:check (ppath-append 'a '(b c)) '(a b c)) 260 | (eval:check (ppath-append '(a b) '(c d)) '(a b c d)))} 261 | 262 | @defproc[(find-child [p pict?] [path pict-path?]) tagless-pict-path?]{ 263 | Finds a child @pictech{pict} with the given @tech{pict path} and returns a (possibly more specific) @tech{tagless pict path} to it. If there are multiple child picts with the given path, one is selected arbitrarily. If there are no child picts with the given path, an @racket[exn:fail:contract] exception is raised.} 264 | 265 | @defproc[(find-children [p pict?] [path pict-path?]) (listof tagless-pict-path?)]{ 266 | Finds all child @pictech{picts} with the given @tech{pict path} and returns a list of (possibly more specific) @tech{tagless pict paths} to them.} 267 | 268 | @defproc[(offset-find [find pict-finder/c] [dx rational?] [dy rational?]) pict-finder/c]{ 269 | Returns a @tech{pict finder} like @racket[find], except the returned x- and y-coordinates are offset by @racket[dx] and @racket[dy], respectively.} 270 | 271 | @defthing[pict-finder/c chaperone-contract? 272 | #:value (-> pict? tagless-pict-path? (values rational? rational?))]{ 273 | A contract that accepts @deftech{pict finder} procedures like @racket[lt-find]. See also @secref["Pict_Finders" #:doc '(lib "pict/scribblings/pict.scrbl")] in the @racketmodname[pict] documentation.} 274 | 275 | @section[#:tag "pict:cond"]{Conditional Picts} 276 | 277 | @defproc[(pict-when [show? any/c] 278 | [p pict?] 279 | [#:launder? launder? any/c #f]) 280 | pict?]{ 281 | Like @racket[(show p show?)], except if @racket[show?] is @racket[#f] and @racket[launder?] is not @racket[#f], @racket[launder] is additionally applied to the result.} 282 | 283 | @defproc[(pict-unless [hide? any/c] 284 | [p pict?] 285 | [#:launder? launder? any/c #f]) 286 | pict?]{ 287 | Like @racket[(hide p hide?)], except that if @racket[hide?] and @racket[launder?] are both not @racket[#f], @racket[launder] is additionally applied to the result.} 288 | -------------------------------------------------------------------------------- /toolbox-draw-lib/toolbox/pict/base.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (rename-in pict 4 | [pin-over pict:pin-over] 5 | [pin-under pict:pin-under] 6 | [pict-path? tagless-pict-path?]) 7 | ppict/tag 8 | racket/class 9 | racket/contract 10 | racket/draw 11 | racket/list 12 | racket/match 13 | threading 14 | toolbox/who 15 | "../color.rkt") 16 | 17 | (provide tagless-pict-path? 18 | (contract-out [pict-finder/c chaperone-contract?] 19 | [offset-find (-> pict-finder/c rational? rational? pict-finder/c)] 20 | 21 | [pict-path? flat-contract?] 22 | [ppath-cons (-> (or/c pict? symbol?) pict-path? pict-path?)] 23 | [ppath-append (-> pict-path? pict-path? pict-path?)] 24 | 25 | [find-child (-> pict? pict-path? tagless-pict-path?)] 26 | [find-children (-> pict? pict-path? (listof tagless-pict-path?))] 27 | 28 | [pict-when (->* [any/c pict?] [#:launder? any/c] pict?)] 29 | [pict-unless (->* [any/c pict?] [#:launder? any/c] pict?)] 30 | 31 | [arrowhead (->* [(and/c rational? (not/c negative?))] [rational?] pict?)] 32 | [arrow-line (->* [] [#:arrow-size (and/c rational? (not/c negative?)) 33 | #:line-length (and/c rational? (not/c negative?)) 34 | #:line-width (or/c (and/c rational? (not/c negative?)) #f)] 35 | pict?)] 36 | 37 | [one-line (-> pict? pict?)] 38 | 39 | [use-last (-> pict? pict-path? pict?)] 40 | [use-last* (-> pict? pict-path? pict?)] 41 | 42 | [refocus (-> pict? pict-path? pict?)] 43 | [refocus* (-> pict? (non-empty-listof pict-path?) pict?)] 44 | 45 | [recenter (case-> 46 | (-> pict? pict-path? pict?) 47 | (-> pict? 48 | (or/c rational? pict-path?) 49 | (or/c rational? pict-finder/c) 50 | pict?))] 51 | 52 | [set-smoothing (-> pict? (or/c 'unsmoothed 'smoothed 'aligned) pict?)] 53 | [set-brush (->* [pict?] 54 | [#:color (or/c color? 'pen #f) 55 | #:style (or/c brush-style/c #f)] 56 | pict?)] 57 | [adjust-brush (->* [pict?] 58 | [#:color (or/c color? 'pen #f) 59 | #:style (or/c brush-style/c #f)] 60 | pict?)] 61 | [set-pen (->* [pict?] 62 | [#:color (or/c color? #f) 63 | #:width (or/c (real-in 0 255) #f) 64 | #:style (or/c pen-style/c #f) 65 | #:cap (or/c pen-cap-style/c #f) 66 | #:join (or/c pen-join-style/c #f)] 67 | pict?)] 68 | [adjust-pen (->* [pict?] 69 | [#:color (or/c color? #f) 70 | #:width (or/c (real-in 0 255) #f) 71 | #:style (or/c pen-style/c #f) 72 | #:cap (or/c pen-cap-style/c #f) 73 | #:join (or/c pen-join-style/c #f)] 74 | pict?)] 75 | 76 | [pin-over (->* [pict? 77 | (or/c rational? pict-path?) 78 | (or/c rational? pict-finder/c) 79 | pict?] 80 | [#:hole (or/c (vector/c rational? rational?) 81 | (vector/c pict-path? pict-finder/c) 82 | pict-finder/c)] 83 | pict?)] 84 | [pin-under (->* [pict? 85 | (or/c rational? pict-path?) 86 | (or/c rational? pict-finder/c) 87 | pict?] 88 | [#:hole (or/c (vector/c rational? rational?) 89 | (vector/c pict-path? pict-finder/c) 90 | pict-finder/c)] 91 | pict?)] 92 | [line-append (-> pict? pict? ... pict?)])) 93 | 94 | ;; ----------------------------------------------------------------------------- 95 | ;; miscellany 96 | 97 | (define pict-finder/c (-> pict? tagless-pict-path? (values rational? rational?))) 98 | 99 | (define ((offset-find find dx dy) p path) 100 | (define-values [x y] (find p path)) 101 | (values (+ x dx) (+ y dy))) 102 | 103 | (define pict-path? (or/c pict? symbol? (listof (or/c pict? symbol?)))) 104 | 105 | (define (ppath-cons p path) 106 | (if (list? path) 107 | (if (empty? path) 108 | p 109 | (cons p path)) 110 | (list p path))) 111 | 112 | (define (ppath-append path1 path2) 113 | (cond 114 | [(empty? path1) path2] 115 | [(empty? path2) path1] 116 | [(list? path1) 117 | (append path1 118 | (if (list? path2) 119 | path2 120 | (list path2)))] 121 | [else 122 | (if (list? path2) 123 | (cons path1 path2) 124 | (list path1 path2))])) 125 | 126 | (define (ppath-last path) 127 | (if (list? path) 128 | (last path) 129 | path)) 130 | 131 | (define (simplify-ppath path) 132 | (match path 133 | [(list elem) elem] 134 | [_ path])) 135 | 136 | (define (child-matches-path-elem? child elem) 137 | (if (pict? elem) 138 | (equal? child elem) 139 | (eq? (pict-tag child) elem))) 140 | 141 | (define/who (find-child p path #:who [who who]) 142 | (let ([path (if (list? path) path (list path))]) 143 | (let/ec escape 144 | (let loop ([child p] 145 | [parents '()] 146 | [path path]) 147 | (match path 148 | ['() (escape (simplify-ppath (reverse (cons child parents))))] 149 | [(cons elem path*) 150 | (if (child-matches-path-elem? child elem) 151 | (loop child parents path*) 152 | (for ([child* (in-list (pict-children child))]) 153 | (loop (child-pict child*) (cons child parents) path)))])) 154 | (raise-arguments-error who "no sub-pict with the given path" 155 | "pict" p 156 | "path" path)))) 157 | 158 | (define (find-children p path) 159 | (let ([path (if (list? path) path (list path))]) 160 | (let loop ([child p] 161 | [parents '()] 162 | [path path]) 163 | (match path 164 | ['() (list (simplify-ppath (reverse (cons child parents))))] 165 | [(cons elem path*) 166 | (if (child-matches-path-elem? child elem) 167 | (loop child parents path*) 168 | (append-map 169 | (λ (child*) 170 | (loop (child-pict child*) (cons child parents) path)) 171 | (pict-children child)))])))) 172 | 173 | ;; ----------------------------------------------------------------------------- 174 | ;; conditionals 175 | 176 | (define (pict-when test then #:launder? [launder? #f]) 177 | (if test then (~> (ghost then) (when~> launder? launder)))) 178 | 179 | (define (pict-unless test then #:launder? [launder? #f]) 180 | (if test (~> (ghost then) (when~> launder? launder)) then)) 181 | 182 | ;; ----------------------------------------------------------------------------- 183 | ;; constructors 184 | 185 | (define (arrowhead size [radians 0]) 186 | (define path (new dc-path%)) 187 | (with-method ([move-to {path move-to}] 188 | [line-to {path line-to}] 189 | [close {path close}]) 190 | (move-to 1 0) 191 | (line-to -1 -1) 192 | (line-to -1/2 0) 193 | (line-to -1 1) 194 | (close)) 195 | 196 | ;; Note: By rotating the path but keeping the pict’s bounding box the same, 197 | ;; some of the path may actually lie outside the bounding box. However, this 198 | ;; is what `arrowhead` from `pict` does, so we emulate that for now. 199 | (send path rotate radians) 200 | (send path translate 1 1) 201 | (send path scale (/ size 2) (/ size 2)) 202 | 203 | (~> (dc (λ (dc x y) (send dc draw-path path x y)) size size) 204 | (set-pen #:style 'transparent) 205 | (set-brush #:color 'pen #:style 'solid))) 206 | 207 | (define (arrow-line #:arrow-size [arrow-size 10] 208 | #:line-length [line-length 50] 209 | #:line-width [line-width 2]) 210 | (define head (arrowhead arrow-size)) 211 | (hc-append 212 | (- (/ (pict-width head) 2)) 213 | (adjust-pen (hline line-length line-width) 214 | #:width line-width) 215 | head)) 216 | 217 | ;; ----------------------------------------------------------------------------- 218 | ;; sizing / bounding box adjusters 219 | 220 | (define (one-line p) 221 | (define ascent (- (pict-height p) (pict-descent p))) 222 | (pin-over (blank (pict-width p) 223 | (pict-height p) 224 | ascent 225 | (pict-descent p)) 226 | 0 0 p)) 227 | 228 | (define/who (refocus base-p path) 229 | (define path* (find-child base-p path #:who who)) 230 | (define-values [x1 y1] (lt-find base-p path*)) 231 | (define-values [x2 y2] (rb-find base-p path*)) 232 | (~> (blank (- x2 x1) (- y2 y1)) 233 | (pin-over (- x1) (- y1) base-p) 234 | (use-last* path*))) 235 | 236 | (define/who (refocus* base-p paths) 237 | (for*/fold ([found-any? #f] 238 | [x1 +inf.0] 239 | [y1 +inf.0] 240 | [x2 -inf.0] 241 | [y2 -inf.0] 242 | #:result (if found-any? 243 | (~> (blank (- x2 x1) (- y2 y1)) 244 | (pin-over (- x1) (- y1) base-p)) 245 | (raise-arguments-error who "no sub-picts with the given paths" 246 | "pict" base-p 247 | "paths" paths))) 248 | ([path (in-list paths)] 249 | [path* (in-list (find-children base-p path))]) 250 | (define-values [sub-x1 sub-y1] (lt-find base-p path*)) 251 | (define-values [sub-x2 sub-y2] (rb-find base-p path*)) 252 | (values #t 253 | (min x1 sub-x1) 254 | (min y1 sub-y1) 255 | (max x2 sub-x2) 256 | (max y2 sub-y2)))) 257 | 258 | (define/who (use-last p path) 259 | (struct-copy 260 | pict p 261 | [children (list (make-child p 0 0 1 1 0 0))] 262 | [last (find-child p path #:who who)])) 263 | 264 | (define/who (use-last* p path) 265 | (define path* (find-child p path #:who who)) 266 | (define last-path (pict-last (ppath-last path*))) 267 | (struct-copy 268 | pict p 269 | [children (list (make-child p 0 0 1 1 0 0))] 270 | [last (if last-path 271 | (ppath-append path* last-path) 272 | path*)])) 273 | 274 | 275 | (define/who recenter 276 | (case-lambda 277 | [(p x) 278 | (recenter/path p x cc-find)] 279 | [(p x y) 280 | (cond 281 | [(rational? x) 282 | (unless (rational? y) 283 | (raise-argument-error who "rational?" 2 p x y)) 284 | (recenter/coords p x y)] 285 | [else 286 | (unless (procedure? y) 287 | (raise-argument-error who "procedure?" 2 p x y)) 288 | (recenter/path p x y)])])) 289 | 290 | (define (recenter/coords p x y) 291 | (define h-inset (- (* x 2) (pict-width p))) 292 | (define v-inset (- (* y 2) (pict-height p))) 293 | (inset p 294 | (max 0 (- h-inset)) 295 | (max 0 (- v-inset)) 296 | (max 0 h-inset) 297 | (max 0 v-inset))) 298 | 299 | (define/who (recenter/path p path find) 300 | (define-values [x y] (find p (find-child p path #:who who))) 301 | (recenter/coords p x y)) 302 | 303 | ;; ----------------------------------------------------------------------------- 304 | ;; drawing adjusters 305 | 306 | (define (dc/wrap p proc) 307 | (define draw-p (make-pict-drawer p)) 308 | (struct-copy 309 | pict 310 | (dc (λ (dc dx dy) 311 | (proc draw-p dc dx dy)) 312 | (pict-width p) 313 | (pict-height p) 314 | (pict-ascent p) 315 | (pict-descent p)) 316 | [children (list (make-child p 0 0 1 1 0 0))] 317 | [last (pict-last p)])) 318 | 319 | (define (set-smoothing p smoothing) 320 | (dc/wrap 321 | p 322 | (λ (draw-p dc dx dy) 323 | (define old-smoothing (send dc get-smoothing)) 324 | (send dc set-smoothing smoothing) 325 | (draw-p dc dx dy) 326 | (send dc set-smoothing old-smoothing)))) 327 | 328 | (define (set-brush #:color [color (make-color 0 0 0)] 329 | #:style [style 'solid] 330 | p) 331 | (dc/wrap 332 | p 333 | (λ (draw-p dc dx dy) 334 | (define old-brush (send dc get-brush)) 335 | (send dc set-brush (make-brush #:color (match color 336 | [#f (send old-brush get-color)] 337 | ['pen (send (send dc get-pen) get-color)] 338 | [_ (->color% color)]) 339 | #:style (or style (send old-brush get-style)))) 340 | (draw-p dc dx dy) 341 | (send dc set-brush old-brush)))) 342 | 343 | (define (adjust-brush #:color [color #f] 344 | #:style [style #f] 345 | p) 346 | (dc/wrap 347 | p 348 | (λ (draw-p dc dx dy) 349 | (define old-brush (send dc get-brush)) 350 | (send dc set-brush (make-brush #:color (match color 351 | [#f (send old-brush get-color)] 352 | ['pen (send (send dc get-pen) get-color)] 353 | [_ (->color% color)]) 354 | #:style (or style (send old-brush get-style)) 355 | #:stipple (send old-brush get-stipple) 356 | #:gradient (send old-brush get-gradient) 357 | #:transformation (send old-brush get-transformation))) 358 | (draw-p dc dx dy) 359 | (send dc set-brush old-brush)))) 360 | 361 | (define (set-pen #:color [color (make-color 0 0 0)] 362 | #:width [width 0] 363 | #:style [style 'solid] 364 | #:cap [cap 'round] 365 | #:join [join 'round] 366 | p) 367 | (dc/wrap 368 | p 369 | (λ (draw-p dc dx dy) 370 | (define old-pen (send dc get-pen)) 371 | (send dc set-pen (make-pen #:color (if color (->color% color) (send old-pen get-color)) 372 | #:width (or width (send old-pen get-width)) 373 | #:style (or style (send old-pen get-style)) 374 | #:cap (or cap (send old-pen get-cap)) 375 | #:join (or join (send old-pen get-join)))) 376 | (draw-p dc dx dy) 377 | (send dc set-pen old-pen)))) 378 | 379 | (define (adjust-pen #:color [color #f] 380 | #:width [width #f] 381 | #:style [style #f] 382 | #:cap [cap #f] 383 | #:join [join #f] 384 | p) 385 | (dc/wrap 386 | p 387 | (λ (draw-p dc dx dy) 388 | (define old-pen (send dc get-pen)) 389 | (send dc set-pen (make-pen #:color (if color (->color% color) (send old-pen get-color)) 390 | #:width (or width (send old-pen get-width)) 391 | #:style (or style (send old-pen get-style)) 392 | #:cap (or cap (send old-pen get-cap)) 393 | #:join (or join (send old-pen get-join)) 394 | #:stipple (send old-pen get-stipple))) 395 | (draw-p dc dx dy) 396 | (send dc set-pen old-pen)))) 397 | 398 | 399 | ;; ----------------------------------------------------------------------------- 400 | ;; combiners 401 | 402 | (define (pin base-p arg1 arg2 sub-p 403 | #:hole [hole #(0 0)] 404 | #:order [order 'over] 405 | #:who who) 406 | (define-values [base-x base-y] 407 | (if (real? arg1) 408 | (values arg1 arg2) 409 | (arg2 base-p (find-child base-p arg1 #:who who)))) 410 | 411 | (define-values [sub-x sub-y] 412 | (match hole 413 | [(vector (? real? sub-x) sub-y) 414 | (values sub-x sub-y)] 415 | [(vector path find) 416 | (find sub-p (find-child sub-p path #:who who))] 417 | [find 418 | (find sub-p sub-p)])) 419 | 420 | ((match order 421 | ['over pict:pin-over] 422 | ['under pict:pin-under]) 423 | base-p (- base-x sub-x) (- base-y sub-y) sub-p)) 424 | 425 | (define/who (pin-over base-p arg1 arg2 sub-p #:hole [hole #(0 0)]) 426 | (pin base-p arg1 arg2 sub-p #:hole hole #:order 'over #:who who)) 427 | 428 | (define/who (pin-under base-p arg1 arg2 sub-p #:hole [hole #(0 0)]) 429 | (pin base-p arg1 arg2 sub-p #:hole hole #:order 'under #:who who)) 430 | 431 | ; Combines picts by extending the last line, as determined by pict-last. 432 | (define (line-append p0 . ps) 433 | (foldl (λ (p2 p1) (line-append/2 p1 p2)) p0 ps)) 434 | (define (line-append/2 p1 p2) 435 | (define draw-p1 (make-pict-drawer p1)) 436 | (define draw-p2 (make-pict-drawer p2)) 437 | ; find the rightmost point on the baseline of (pict-last p1) 438 | (define-values [last-x last-y] (rbl-find p1 (or (pict-last p1) p1))) 439 | 440 | ; figure out where we’ll place p2 relative to p1, since we want to align the 441 | ; descent line of (pict-last p1) with the ascent line of p2 442 | (define p2-y-relative (- last-y (pict-ascent p2))) 443 | ; if p2-y is negative, that means p2’s ascent peeks out above the top of p1, 444 | ; so compute how far we need to offset p1/p2 relative to the top of the new pict 445 | (define p1-y (if (negative? p2-y-relative) (- p2-y-relative) 0)) 446 | (define p2-y (if (negative? p2-y-relative) 0 p2-y-relative)) 447 | 448 | ; the x coordinate is simpler, since we don’t have to deal with ascent/descent, 449 | ; but it’s possible (though unlikely) that last-x is negative, in which case we 450 | ; want to do a similar adjustment 451 | (define p1-x (if (negative? last-x) (- last-x) 0)) 452 | (define p2-x (if (negative? last-x) 0 last-x)) 453 | 454 | ; compute rightmost point and bottommost point in the new pict’s bounding box 455 | (define w (max (+ p1-x (pict-width p1)) 456 | (+ p2-x (pict-width p2)))) 457 | (define h (max (+ p1-y (pict-height p1)) 458 | (+ p2-y (pict-height p2)))) 459 | ; same for uppermost ascent line and lowermost descent line 460 | (define a (min (+ p1-y (pict-ascent p1)) 461 | (+ p2-y (pict-ascent p2)))) 462 | (define d (- h (max (+ p1-y (- (pict-height p1) (pict-descent p1))) 463 | (+ p2-y (- (pict-height p2) (pict-descent p2)))))) 464 | 465 | ; invent a new, totally unique pict to use as pict-last, in case (pict-last p2) 466 | ; already exists somewhere in the pict 467 | (define p2-last (or (ppath-last (pict-last p2)) p2)) 468 | (define-values [p2-last-x p2-last-y] (lt-find p2 (or (pict-last p2) p2))) 469 | (define last-p (blank (pict-width p2-last) 470 | (pict-height p2-last) 471 | (pict-ascent p2-last) 472 | (pict-descent p2-last))) 473 | 474 | ; compute child offsets, which are weird because pict uses an inverted 475 | ; coordinate system, so these are relative to the lowermost point 476 | (define p1-dy (- h (+ p1-y (pict-height p1)))) 477 | (define p2-dy (- h (+ p2-y (pict-height p2)))) 478 | (define p2-last-dy (- h (+ p2-y p2-last-y (pict-height p2-last)))) 479 | 480 | (~> (dc (λ (dc dx dy) 481 | (draw-p1 dc (+ dx p1-x) (+ dy p1-y)) 482 | (draw-p2 dc (+ dx p2-x) (+ dy p2-y))) 483 | w h a d) 484 | (struct-copy pict _ 485 | [children (list (make-child p1 p1-x p1-dy 1 1 0 0) 486 | (make-child p2 p2-x p2-dy 1 1 0 0) 487 | (make-child last-p 488 | (+ p2-x p2-last-x) 489 | p2-last-dy 490 | 1 1 0 0))] 491 | [last last-p]))) 492 | -------------------------------------------------------------------------------- /toolbox-doc/scribblings/toolbox/db.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(begin 4 | (require "private/common.rkt") 5 | (define-id-referencer db db/base)) 6 | 7 | @title[#:tag "db" #:style 'toc]{Database} 8 | 9 | @local-table-of-contents[] 10 | 11 | @section[#:tag "db:base"]{Extended DB API} 12 | @defmodule[toolbox/db/base] 13 | 14 | The @racketmodname[toolbox/db/base] module improves and extends @racketmodname[db/base]. In addition to the bindings documented in this section, it re-exports all bindings from @racketmodname[db/base] (except those that have the same name as one of the bindings documented in this section). 15 | 16 | The interface provided by @racketmodname[toolbox/db/base] is @emph{mostly} drop-in compatible with that of @racketmodname[db/base], with two major exceptions: 17 | 18 | @itemlist[ 19 | @item{Most functions have been changed to no longer require an explicit database connection argument. Instead, the value of the @racket[current-db] parameter is used.} 20 | 21 | @item{Nested uses of @racket[call-with-transaction] do not create @dbtech{nested transactions} by default. The @racket[#:nested 'allow] option must be supplied if true nested transactions are desired.}] 22 | 23 | @defparam[current-db db (or/c connection? #f) #:value #f]{ 24 | A parameter that determines the @deftech{current database connection}, which many functions use implicitly if a connection is not explicitly provided.} 25 | 26 | @defproc[(get-db [who symbol? 'get-db]) connection?]{ 27 | Obtains the @tech{current database connection}. If @racket[(current-db)] is @racket[#f], an @racket[exn:fail:contract] exception is raised (with @racket[who] inserted at the start of the error message).} 28 | 29 | @defproc[(in-transaction? [#:db db connection? (current-db)]) boolean?]{ 30 | Like @id-from-db[in-transaction?], but uses the @tech{current database connection} by default.} 31 | 32 | @defproc[(call-with-transaction [thunk (-> any)] 33 | [#:db db connection? (current-db)] 34 | [#:isolation isolation-level 35 | (or/c 'serializable 36 | 'repeatable-read 37 | 'read-committed 38 | 'read-uncommitted 39 | #f) 40 | #f] 41 | [#:option option any/c #f] 42 | [#:nested nested-mode (or/c 'allow 'omit 'fail) 'omit]) 43 | any]{ 44 | Like @id-from-db[call-with-transaction], but uses the @tech{current database connection} by default, and behavior when already inside a transaction differs depending on @racket[nested-mode]: 45 | 46 | @itemlist[ 47 | @item{If @racket[nested-mode] is @racket['omit] (the default), @racket[call-with-transaction] has no effect when already inside a transaction: @racket[thunk] is invoked directly, without starting a @dbtech{nested transaction}.} 48 | 49 | @item{If @racket[nested-mode] is @racket['allow], @racket[call-with-transaction] applies @racket[thunk] within a @dbtech{nested transaction}. (This is the behavior of @id-from-db[call-with-transaction].)} 50 | 51 | @item{If @racket[nested-mode] is @racket['fail], @racket[call-with-transaction] raises an @racket[exn:fail:contract] exception if already inside a transaction.}] 52 | 53 | The default value of @racket['omit] makes @racket[call-with-transaction] ensure that @racket[thunk] is executed in the context of @emph{some} transaction, but it does not allow the effects of @racket[thunk] to be selectively rolled back. In practice, partial rollbacks are rarely useful, and creating savepoints to permit them can have significant performance overhead, so this is usually the right choice.} 54 | 55 | @defproc[(call-with-transaction/retry 56 | [thunk (-> any)] 57 | [#:db db connection? (current-db)] 58 | [#:isolation isolation-level 59 | (or/c 'serializable 60 | 'repeatable-read 61 | 'read-committed 62 | 'read-uncommitted 63 | #f) 64 | #f] 65 | [#:option option any/c #f] 66 | [#:nested nested-mode (or/c 'allow 'omit 'fail) 'omit] 67 | [#:max-retries max-retries (or/c exact-nonnegative-integer? +inf.0) (current-max-transaction-retries)] 68 | [#:retry-delay retry-delay-secs (>=/c 0) (current-transaction-retry-delay)]) 69 | any]{ 70 | Like @racket[call-with-transaction], except that @racket[thunk] may be retried if it raises an @racket[exn:fail:sql:busy?] exception. Retrying is not possible if @racket[call-with-transaction/retry] is called from within another transaction, so if a transaction is already started, @racket[call-with-transaction/retry] behaves identically to @racket[call-with-transaction]. 71 | 72 | Assuming retrying is possible, @racket[thunk] may be executed up to @racket[max-retries] times before giving up. Before each retry attempt, @racket[call-with-transaction/retry] sleeps for @racket[retry-delay-secs] seconds. 73 | 74 | When @racket[db] is a SQLite connection and @racket[option] is @racket[#f] or @racket['deferred], retry attempts will automatically use @racket['immediate] for @racket[option], instead. This is usually enough to ensure that @racket[thunk] itself is only executed at most twice, though the retry limit may still be reached if @racket[call-with-transaction/retry] is unable to successfully acquire a write transaction. 75 | 76 | Note that the retry mechanism of @racket[call-with-transaction/retry] is used @emph{in addition to} the retry mechanism used for all SQLite operations, which is controlled separately via the @racket[#:busy-retry-limit] and @racket[#:busy-retry-delay] arguments to @racket[sqlite3-connect]. For multi-statement transactions, the retry mechanism of @racket[call-with-transaction/retry] is often substantially more useful, as a @tt{SQLITE_BUSY} failure may indicate that the entire transaction must be restarted, in which case retrying the last statement will never succeed and serves no purpose. However, the intrinsic retry mechanism can be more useful in other situations, especially when the @racket[#:use-place] argument to @racket[sqlite3-connect] is @racket['os-thread], as it can use @hyperlink["https://www.sqlite.org/c3ref/busy_handler.html"]{SQLite’s built-in busy handler}.} 77 | 78 | @defparam[current-max-transaction-retries max-retries 79 | (or/c exact-nonnegative-integer? +inf.0) #:value 10]{ 80 | A parameter that controls the number of times @racket[call-with-transaction/retry] will attempt to retry a transaction that fails with a @racket[exn:fail:sql:busy?] exception.} 81 | 82 | @defparam[current-transaction-retry-delay retry-delay-secs (>=/c 0) #:value 0.1]{ 83 | A parameter that controls the number of seconds @racket[call-with-transaction/retry] will wait between attempts to retry a transaction that fails with a @racket[exn:fail:sql:busy?] exception.} 84 | 85 | @defproc[(query [stmt (or/c string? virtual-statement? prepared-statement?)] 86 | [arg any/c] ... 87 | [#:db db connection? (current-db)] 88 | [#:log? log? any/c (current-log-db-queries?)] 89 | [#:explain? explain? any/c (current-explain-db-queries?)] 90 | [#:analyze? analyze? any/c (current-analyze-db-queries?)]) 91 | (or/c simple-result? rows-result?)]{ 92 | Like @id-from-db[query], but uses the @tech{current database connection} by default and supports automatic query logging and instrumentation. If enabled, all log messages are written to @racket[toolbox:db-logger] on topic @racket['toolbox:db:query] at level @racket['info]. 93 | 94 | If @racket[log?] is not @racket[#f], the SQL text of @racket[stmt] is logged before the query is executed, and the query’s (wall clock) execution time is logged after the execution completes. 95 | 96 | If @racket[explain?] is not @racket[#f], a textual representation of the database system’s query plan is logged before the query is executed. Currently, this option is only supported with SQLite; an @racket[exn:fail:unsupported] exception will be raised with other database systems. 97 | 98 | If @racket[analyze?] is not @racket[#f], the query plan is logged in the same way as for @racket[explain?], but the plan is logged @emph{after} executing the query, and it is annotated with performance information collected during the query’s execution. Like @racket[explain?], this option is currently only supported with SQLite, but @racket[analyze?] additionally requires that SQLite was compiled with the @tt{SQLITE_ENABLE_STMT_SCANSTATUS} compile-time option. The @racket[sqlite3-stmt-scanstatus-enabled?] function can be used to check whether this is the case. 99 | 100 | @(toolbox-examples 101 | #:hidden (define log-writer 102 | (spawn-pretty-log-writer (make-log-receiver toolbox:db-logger 'debug))) 103 | (current-db (sqlite3-connect #:database 'memory)) 104 | (define can-analyze? (sqlite3-stmt-scanstatus-enabled?)) 105 | (query 106 | #:log? #t 107 | #:explain? (not can-analyze?) 108 | #:analyze? can-analyze? 109 | (string-join 110 | '("WITH RECURSIVE" 111 | " fib(i,a,b) AS" 112 | " (SELECT 1, 0, 1" 113 | " UNION ALL" 114 | " SELECT i+1, b, a+b FROM fib" 115 | " WHERE i <= 10)" 116 | "SELECT b FROM fib ORDER BY i") 117 | "\n")) 118 | #:hidden (close-log-writer log-writer))} 119 | 120 | @(define (make-query-proc-flow id-from-db-elem) 121 | @list{Like @id-from-db-elem, but uses the @tech{current database connection} by default and supports automatic query logging and instrumentation like @racket[query]. See the documentation for @racket[query] for information about the behavior of @racket[_log?], @racket[_explain?], and @racket[_analyze?].}) 122 | 123 | @(define-syntax-rule (defqueryproc proc-id result-ctc) 124 | @defproc[(proc-id [stmt (or/c string? virtual-statement? prepared-statement?)] 125 | [arg any/c] (... ...) 126 | [#:db db connection? (current-db)] 127 | [#:log? log? any/c (current-log-db-queries?)] 128 | [#:explain? explain? any/c (current-explain-db-queries?)] 129 | [#:analyze? analyze? any/c (current-analyze-db-queries?)]) 130 | result-ctc]{ 131 | @(make-query-proc-flow @id-from-db[proc-id])}) 132 | 133 | @defqueryproc[query-exec void?] 134 | 135 | @defproc[(query-rows [stmt (or/c string? virtual-statement? prepared-statement?)] 136 | [arg any/c] ... 137 | [#:db db connection? (current-db)] 138 | [#:group groupings 139 | (let* ([field/c (or/c string? exact-nonnegative-integer?)] 140 | [grouping/c (or/c field/c (vectorof field/c))]) 141 | (or/c grouping/c (listof grouping/c))) 142 | '()] 143 | [#:group-mode group-mode 144 | (listof (or/c 'preserve-null 'list)) 145 | '()] 146 | [#:log? log? any/c (current-log-db-queries?)] 147 | [#:explain? explain? any/c (current-explain-db-queries?)] 148 | [#:analyze? analyze? any/c (current-analyze-db-queries?)]) 149 | (listof vector?)]{ 150 | @(make-query-proc-flow @id-from-db[query-rows])} 151 | 152 | @defqueryproc[query-list list?] 153 | @defqueryproc[query-row vector?] 154 | @defqueryproc[query-maybe-row (or/c vector? #f)] 155 | @defqueryproc[query-value any/c] 156 | @defqueryproc[query-maybe-value any/c] 157 | 158 | @defboolparam[current-log-db-queries? log? #:value #f]{ 159 | A parameter that controls whether functions like @racket[query] should log each query’s SQL text; see the documentation for @racket[query] for details.} 160 | 161 | @defboolparam[current-explain-db-queries? explain? #:value #f]{ 162 | A parameter that controls whether functions like @racket[query] should log each query’s query plan before execution; see the documentation for @racket[query] for details.} 163 | 164 | @defboolparam[current-analyze-db-queries? analyze? #:value #f]{ 165 | A parameter that controls whether functions like @racket[query] should log each query’s profiled query plan after execution; see the documentation for @racket[query] for details.} 166 | 167 | @defproc[(query-changes [#:db db connection? (current-db)]) 168 | exact-nonnegative-integer?]{ 169 | Returns the number of database rows that were changed, inserted, or deleted by the most recently completed @tt{INSERT}, @tt{DELETE}, or @tt{UPDATE} statement. Currently only supported with SQLite; an @racket[exn:fail:unsupported] exception will be raised with other database systems.} 170 | 171 | @defproc[(map-sql-nullable [proc (-> any/c any/c)] [v any/c]) any/c]{ 172 | If @racket[v] is @racket[sql-null], returns @racket[sql-null], otherwise returns @racket[(proc v)]. 173 | 174 | @(toolbox-examples 175 | (eval:check (map-sql-nullable add1 1) 2) 176 | (eval:check (map-sql-nullable add1 sql-null) sql-null))} 177 | 178 | @defform[(lifted-statement expr) 179 | #:contracts ([expr (or/c string? (-> dbsystem? string?))])]{ 180 | Equivalent to @racket[(#%lift (virtual-statement expr))]. That is, @racket[lifted-statement] is like @racket[virtual-statement], except that it is implicitly lifted to the top of the enclosing module (so @racket[expr] may not reference local variables). This allows a @dbtech{virtual statement} to be declared inline, where it is used. 181 | 182 | Also see @racket[~stmt], which combines @racket[lifted-statement] and @racket[~sql].} 183 | 184 | @defthing[toolbox:db-logger logger?]{ 185 | A @reftech{logger} used by various functions in @racketmodname[toolbox/db/base]. Its parent logger is @racket[toolbox-logger].} 186 | 187 | @defproc[(exn:fail:sql:busy? [v any/c]) boolean?]{ 188 | Returns @racket[#t] if @racket[v] is an @racket[exn:fail:sql] exception and @racket[(exn:fail:sql-sqlstate v)] is @racket['busy]. Otherwise, returns @racket[#f].} 189 | 190 | @defproc[(exn:fail:sql:constraint? [v any/c]) boolean?]{ 191 | Returns @racket[#t] if @racket[v] is an @racket[exn:fail:sql] exception and @racket[(exn:fail:sql-sqlstate v)] is @racket['constraint]. Otherwise, returns @racket[#f].} 192 | 193 | @section[#:tag "db:sql"]{Formatting SQL} 194 | @defmodule[toolbox/db/sql] 195 | 196 | @defproc[(~sql [v pre-sql?] ...) string?]{ 197 | Converts each @racket[v] argument to a string then concatenates the results. The arguments are converted according to the following rules: 198 | 199 | @itemlist[ 200 | @item{If @racket[v] is a @reftech{string}, it is used directly.} 201 | @item{If @racket[v] is a @reftech{symbol}, it is formatted as a SQL identifier using @racket[sql:id].} 202 | @item{If @racket[v] is an @reftech[#:key "exact number"]{exact} @reftech{integer}, it is converted using @racket[number->string].} 203 | @item{If @racket[v] is any other @reftech{rational number}, it is converted to a @reftech{flonum} using @racket[real->double-flonum], then converted to a string using @racket[number->string].} 204 | @item{If @racket[v] is @racket[sql-null], it is converted to the string @racket["NULL"].}] 205 | 206 | @(toolbox-examples 207 | (~sql "SELECT " 'id " FROM " 'comment " WHERE " 'rating " > " 0.75)) 208 | 209 | The @racket[~sql] function is especially useful when used @seclink["reader" #:doc '(lib "scribblings/scribble/scribble.scrbl")]|{@ syntax}| via the @racketmodname[at-exp] language. 210 | 211 | Example: 212 | 213 | @codeblock[#:keep-lang-line? #f]|{ 214 | #lang at-exp racket/base 215 | @~sql{SELECT name FROM user WHERE id IN @sql:tuple*[user-ids]}}|} 216 | 217 | @defform[(~stmt expr ...) 218 | #:contracts ([expr pre-sql?])]{ 219 | Equivalent to @racket[(lifted-statement (~sql expr #,m...))]. The @racket[expr] forms may not reference local variables.} 220 | 221 | @defproc[(sql:id [name (or/c symbol? string?)]) string?]{ 222 | Quotes @racket[name] as a SQL identifier by surrounding it with double quotes. If @racket[name] contains double quotes, they are escaped by doubling. 223 | 224 | @(toolbox-examples 225 | (eval:check (sql:id "hello") "\"hello\"") 226 | (eval:check (sql:id "weird\"id") "\"weird\"\"id\""))} 227 | 228 | @defproc[(sql:string [name (or/c symbol? string?)]) string?]{ 229 | Quotes @racket[name] as a SQL string literal by surrounding it with single quotes. If @racket[name] contains single quotes, they are escaped by doubling. 230 | 231 | @(toolbox-examples 232 | (eval:check (sql:string "hello") "'hello'") 233 | (eval:check (sql:string "it's") "'it''s'"))} 234 | 235 | @defproc[(sql:seq [v pre-sql?] ...) string?]{ 236 | Converts each @racket[v] to a string using @racket[~sql], then concatenates the results with @racket[","] between consecutive items. 237 | 238 | @(toolbox-examples 239 | (eval:check (sql:seq 1 2 3) "1,2,3"))} 240 | 241 | @defproc[(sql:seq* [v pre-sql?] ... [vs (listof pre-sql?)]) string?]{ 242 | Like @racket[sql:seq], but the last argument is used as a list of arguments for @racket[sql:seq]. In other words, the relationship between @racket[sql:seq] and @racket[sql:seq*] is the same as the one between @racket[string-append] and @racket[string-append*]. 243 | 244 | @(toolbox-examples 245 | (eval:check (sql:seq* 1 2 '(3 4)) "1,2,3,4"))} 246 | 247 | @defproc[(sql:tuple [v pre-sql?] ...) string?]{ 248 | Like @racket[sql:seq], but the resulting string is additionally wrapped in parentheses. 249 | 250 | @(toolbox-examples 251 | (eval:check (sql:tuple 1 2 3) "(1,2,3)"))} 252 | 253 | @defproc[(sql:tuple* [v pre-sql?] ... [vs (listof pre-sql?)]) string?]{ 254 | Like @racket[sql:tuple], but the last argument is used as a list of arguments for @racket[sql:tuple]. In other words, the relationship between @racket[sql:tuple] and @racket[sql:tuple*] is the same as the one between @racket[string-append] and @racket[string-append*]. 255 | 256 | @(toolbox-examples 257 | (eval:check (sql:tuple* 1 2 '(3 4)) "(1,2,3,4)"))} 258 | 259 | @defproc[(query:bag [vs (listof pre-sql?)]) string?]{ 260 | Builds a SQL query that returns rows of exactly one column, where each element of @racket[vs] is an expression that supplies the value of one of the rows. 261 | 262 | @(toolbox-examples 263 | (query:bag '(1 2 3)) 264 | (query:bag '())) 265 | 266 | In a sense, @racket[query:bag] is the inverse of @racket[query-list]. However, because the query contains no @tt{ORDER BY} clause, the order of the resulting rows cannot be guaranteed. If the order of @racket[vs] is important, @racket[query:indexed-list] should be used instead.} 267 | 268 | @defproc[(query:indexed-list [vs (listof pre-sql?)]) string?]{ 269 | Like @racket[query:bag], but the resulting query contains two columns. The first column is a (zero-based) index corresponding to the index of each element @racket[_v] in @racket[vs], while the second column is the value of the expression @racket[_v] itself. 270 | 271 | @(toolbox-examples 272 | #:hidden (current-db (sqlite3-connect #:database 'memory)) 273 | (query:indexed-list '(1 2 3)) 274 | (query:indexed-list '()) 275 | (eval:check (query-list 276 | (~sql "WITH nums(i,n) AS (" (query:indexed-list (range 10)) ")\n" 277 | "SELECT n*n FROM nums ORDER BY i")) 278 | '(0 1 4 9 16 25 36 49 64 81)))} 279 | 280 | @defproc[(query:rows [rows (listof (vectorof pre-sql?))] 281 | [#:columns num-columns (or/c exact-nonnegative-integer? #f) #f]) 282 | string?]{ 283 | Builds a SQL query that returns a row for each element @racket[_row] of @racket[rows], where each element of @racket[_row] is an expression that supplies the value of one of the columns in the row. Each @racket[_row] must have the same length. 284 | 285 | If @racket[num-columns] is not @racket[#f], it supplies the number of columns the query should return. Otherwise, the number of columns is inferred from the length of the elements of @racket[rows]. If @racket[num-columns] is @racket[#f] and no rows are provided, an @racket[exn:fail:contract] exception is raised. 286 | 287 | @(toolbox-examples 288 | (query:rows '(#(1 2) #(3 4) #(5 6))) 289 | (query:rows '() #:columns 2) 290 | (eval:error (query:rows '())))} 291 | 292 | @defproc[(pre-sql? [v any/c]) boolean?]{ 293 | Returns @racket[#t] if @racket[v] is a @deftech{pre-SQL} value: a raw SQL @reftech{string}, a @reftech{symbol}, a @reftech{rational number}, or @racket[sql-null]. Otherwise, returns @racket[#f]. 294 | 295 | Pre-SQL values can be converted to SQL strings using @racket[~sql].} 296 | 297 | @section[#:tag "db:define"]{Defining SQL accessors} 298 | @defmodule[toolbox/db/define] 299 | 300 | In addition to the bindings documented in this section, the @racketmodname[toolbox/db/define] module also re-exports @racket[field] from @racketmodname[racket/class], which is recognized as part of the syntax of @racket[define-sql-table]. 301 | 302 | @defform[#:literals [field] 303 | (define-sql-table table-name-id 304 | table-option ... 305 | (field field-name-id 306 | field-option ...) 307 | ...) 308 | #:grammar ([table-option (code:line #:sql-name table-name-expr) 309 | (code:line #:resolve resolve-expr) 310 | (code:line #:deleter maybe-name-id)] 311 | [field-option (code:line #:sql-name field-name-expr) 312 | (code:line #:getter maybe-name-id) 313 | (code:line #:setter maybe-name-id) 314 | (code:line #:convert sql->racket-expr racket->sql-expr)] 315 | [table-name-expr name-expr] 316 | [field-name-expr name-expr] 317 | [maybe-name-id (code:line) 318 | name-id]) 319 | #:contracts ([name-expr symbol?] 320 | [resolve-expr (or/c (-> any/c #:who symbol? any/c) #f)] 321 | [sql->racket-expr (-> any/c any/c)] 322 | [racket->sql-expr (-> any/c any/c)])]{ 323 | Defines functions for performing simple SQL queries against a SQL table. 324 | 325 | The name of the SQL table is given by the result of @racket[table-name-expr]. If no @racket[table-name-expr] is provided, the SQL table name is inferred from @racket[table-name-id] by replacing all occurrences of @litchar{-} with @litchar{_} and replacing a trailing @litchar{?} with the prefix @litchar{is_}. For example, if @racket[table-name-id] were @tt{user-friend?}, the inferred SQL name would be @tt{is_user_friend}. 326 | 327 | If the @racket[#:deleter name-id] option is provided, @racket[name-id] is defined as a deleter procedure produced by @racket[make-sql-deleter]. If @racket[#:deleter] is provided with no @racket[name-id], the name @racketplainfont{delete-@racket[table-name-id]!} is used, instead. 328 | 329 | Each provided @racket[field] clause controls generation of getter and setter procedures for individual fields (columns) of the table. The SQL name of each field is given by @racket[field-name-expr]. If no @racket[field-name-expr] is provided, the SQL name is inferred from @racket[field-name-id] in the same way the table name may be inferred from @racket[table-name-id]. 330 | 331 | If the @racket[#:getter name-id] option is provided for a field, @racket[name-id] is defined as a getter procedure produced by @racket[make-sql-getter]. If @racket[#:getter] is provided with no @racket[name-id], the name @racketplainfont{@racket[table-name-id]-@racket[field-name-id]} is used, instead. 332 | 333 | Likewise, if the @racket[#:setter name-id] option is provided for a field, @racket[name-id] is defined as a setter procedure produced by @racket[make-sql-setter]. If @racket[#:setter] is provided with no @racket[name-id], the name @racketplainfont{set-@racket[table-name-id]-@racket[field-name-id]!} is used, instead. 334 | 335 | If the @racket[#:convert] option is provided for a field, the @racket[sql->racket-expr] and @racket[racket->sql-expr] expressions are used as the @racket[#:convert] arguments to @racket[make-sql-getter] and @racket[make-sql-setter], respectively. 336 | 337 | If the @racket[#:resolve] table option is provided, the procedure produced by @racket[resolve-expr] is used as the @racket[#:resolve] argument to @racket[make-sql-deleter], @racket[make-sql-getter], and @racket[make-sql-setter]. 338 | 339 | @(toolbox-examples 340 | (current-db (sqlite3-connect #:database 'memory)) 341 | (query-exec 342 | (~sql "CREATE TABLE user" 343 | "( id INTEGER NOT NULL PRIMARY KEY" 344 | ", name TEXT NOT NULL" 345 | ", is_admin INTEGER NOT NULL DEFAULT (0)" 346 | " CHECK (is_admin IN (0, 1)) )")) 347 | (define-sql-table user 348 | (field name #:getter #:setter) 349 | (field admin? #:getter #:setter 350 | #:convert integer->boolean boolean->integer)) 351 | (query-exec 352 | (~sql "INSERT INTO user(id, name) VALUES (1, 'Alyssa'), (2, 'Ben')")) 353 | (eval:check (user-name 1) "Alyssa") 354 | (eval:check (user-name 2) "Ben") 355 | (set-user-admin?! 1 #t) 356 | (eval:check (user-admin? 1) #t) 357 | (eval:check (user-admin? 2) #f))} 358 | 359 | @defproc[(make-sql-deleter [#:table table-name symbol?] 360 | [#:who who symbol?] 361 | [#:resolve resolve-proc 362 | (or/c (-> any/c #:who symbol? any/c) #f) 363 | #f]) 364 | (->* [any/c] [#:who symbol? #:resolve? any/c] void?)]{ 365 | Builds a deleter procedure that accepts a primary key for the SQL table given by @racket[table-name] and executes the following query: 366 | 367 | @nested[#:style 'code-inset]{@verbatim{DELETE FROM @racket[(sql:id table-name)] WHERE id = ?}} 368 | 369 | If @racket[resolve-proc] is not @racket[#f], it is used to compute a primary key from the argument provided to the deleter procedure unless @racket[#:resolve? #f] is supplied. The call to @racket[resolve-proc] and the @tt{DELETE} statement are both executed within the same database transaction. 370 | 371 | The @racket[who] argument is used as the name of the deleter procedure, as returned by @racket[object-name], and it is used in error messages reported by the deleter procedure. It is also passed to @racket[resolve-proc], if provided, via the @racket[#:who] keyword argument.} 372 | 373 | @defproc[(make-sql-getter [#:table table-name symbol?] 374 | [#:field field-name symbol?] 375 | [#:who who symbol?] 376 | [#:resolve resolve-proc 377 | (or/c (-> any/c #:who symbol? any/c) #f) 378 | #f] 379 | [#:convert convert-proc (-> any/c any/c) values]) 380 | (->* [any/c] [#:who symbol? #:resolve? any/c] any/c)]{ 381 | Builds a getter procedure that accepts a primary key for the SQL table given by @racket[table-name] and executes the following query: 382 | 383 | @nested[#:style 'code-inset]{@verbatim{SELECT @racket[(sql:id field-name)] FROM @racket[(sql:id table-name)] WHERE id = ?}} 384 | 385 | The @racket[convert-proc] argument is applied to the result of the @tt{SELECT} statement to produce a result for the getter procedure. 386 | 387 | If @racket[resolve-proc] is not @racket[#f], it is used to compute a primary key from the argument provided to the getter procedure unless @racket[#:resolve? #f] is supplied. The call to @racket[resolve-proc] and the @tt{SELECT} statement are both executed within the same database transaction. 388 | 389 | The @racket[who] argument is used as the name of the getter procedure, as returned by @racket[object-name], and it is used in error messages reported by the getter procedure. It is also passed to @racket[resolve-proc], if provided, via the @racket[#:who] keyword argument.} 390 | 391 | @defproc[(make-sql-setter [#:table table-name symbol?] 392 | [#:field field-name symbol?] 393 | [#:who who symbol?] 394 | [#:resolve resolve-proc 395 | (or/c (-> any/c #:who symbol? any/c) #f) 396 | #f] 397 | [#:convert convert-proc (-> any/c any/c) values]) 398 | (->* [any/c any/c] [#:who symbol? #:resolve? any/c] void?)]{ 399 | Builds a setter procedure that accepts a primary key and a value for the SQL table and column given by @racket[table-name] and @racket[field-name] and executes the following query: 400 | 401 | @nested[#:style 'code-inset]{@verbatim{UPDATE @racket[(sql:id table-name)] SET @racket[(sql:id field-name)] = ? WHERE id = ?}} 402 | 403 | The @racket[convert-proc] argument is applied to the second argument of the of the setter procedure to produce a value to be used as the first parameter of the @tt{UPDATE} statement. 404 | 405 | If @racket[resolve-proc] is not @racket[#f], it is used to compute a primary key from the first argument provided to the setter procedure unless @racket[#:resolve? #f] is supplied. The call to @racket[resolve-proc] and the @tt{UPDATE} statement are both executed within the same database transaction. 406 | 407 | The @racket[who] argument is used as the name of the setter procedure, as returned by @racket[object-name], and it is used in error messages reported by the setter procedure. It is also passed to @racket[resolve-proc], if provided, via the @racket[#:who] keyword argument.} 408 | 409 | @section[#:tag "db:sqlite3"]{SQLite} 410 | @defmodule[toolbox/db/sqlite3] 411 | 412 | @defproc[(sqlite3-stmt-scanstatus-enabled?) boolean?]{ 413 | Returns @racket[#t] if the loaded SQLite library was compiled with @tt{SQLITE_ENABLE_STMT_SCANSTATUS}, which is required if query profiling is enabled in @racket[query] via the @racket[#:analyze?] option. Otherwise, returns @racket[#f].} 414 | 415 | @defproc[(boolean->integer [v any/c]) (or/c 0 1)]{ 416 | If @racket[v] is @racket[#f], returns @racket[0], otherwise returns @racket[1].} 417 | 418 | @defproc[(integer->boolean [v (or/c 0 1)]) boolean?]{ 419 | If @racket[v] is @racket[0], returns @racket[#f], otherwise returns @racket[#t].} 420 | 421 | @defproc[(->posix/integer [v datetime-provider?]) exact-integer?]{ 422 | Equivalent to @racket[(floor (->posix v))].} 423 | 424 | @defproc[(->jd/double [v datetime-provider?]) (and/c rational? flonum?)]{ 425 | Equivalent to @racket[(real->double-flonum (->jd v))].} 426 | --------------------------------------------------------------------------------