1#lang racket/base 2(require "../common/struct-star.rkt" 3 "../common/parameter-like.rkt" 4 "readtable-parameter.rkt") 5 6(provide (struct*-out read-config) 7 (struct-out read-config-state) 8 current-read-config 9 make-read-config 10 read-config-update 11 port+config->srcloc 12 reading-at 13 disable-wrapping 14 keep-comment 15 discard-comment 16 next-readtable) 17 18(struct* read-config (readtable 19 next-readtable ; readtable to use for recursive reads 20 for-syntax? ; impose restrictions on graphs, fxvectors, etc? 21 source 22 * wrap ; wrapper applied to each datum, intended for syntax objects 23 read-compiled ; for `#~`: input-port -> any/c 24 call-with-root-namespace ; around extension callback 25 dynamic-require ; for reader extensions: module-path sym -> any 26 module-declared? ; for `#lang`: module-path -> any/c 27 coerce ; coerce for syntax or not: any boolean -> any 28 coerce-key ; coerce unwrapped key for hash 29 * line 30 * col 31 * pos 32 * indentations ; stack of `indentation` records 33 * keep-comment? ; make main dispatch return on comment 34 parameter-override ; hash of parameter -> value 35 parameter-cache ; hash of parameter -> value 36 st)) ; other shared mutable state 37 38(struct read-config-state ([accum-str #:mutable] ; string-buffer cache 39 [graph #:mutable])) ; #f or hash of number -> value 40 41(define-parameter-like current-read-config #f) ; for `read/recursive` 42 43(define (make-read-config 44 #:source [source #f] 45 #:for-syntax? [for-syntax? #f] 46 #:readtable [readtable (current-readtable)] 47 #:next-readtable [next-readtable readtable] 48 #:wrap [wrap #f #;(lambda (s-exp srcloc) s-exp)] 49 #:read-compiled [read-compiled #f] 50 #:call-with-root-namespace [call-with-root-namespace #f] 51 #:dynamic-require [dynamic-require #f] 52 #:module-declared? [module-declared? #f] 53 #:coerce [coerce #f] 54 #:coerce-key [coerce-key #f] 55 #:keep-comment? [keep-comment? #f]) 56 (read-config readtable 57 next-readtable 58 for-syntax? 59 source 60 wrap 61 (or read-compiled 62 (lambda (in) 63 (error 'read "no `read-compiled` provided"))) 64 (or call-with-root-namespace 65 (lambda (thunk) 66 (error 'read "no `call-with-root-namespace` provided"))) 67 (or dynamic-require 68 (lambda (mod-path sym failure-k) 69 (error 'read "no `dynamic-require` provided"))) 70 (or module-declared? 71 (lambda (mod-path) 72 (error 'read "no `module-declare?` provided"))) 73 (or coerce 74 (lambda (for-syntax? v srcloc) v)) 75 (or coerce-key 76 (lambda (for-syntax? v) v)) 77 #f ; line 78 #f ; col 79 #f ; pos 80 null ; indentations 81 keep-comment? 82 #hasheq() ; parameter-override 83 (make-hasheq) ; parameter-cache 84 (read-config-state #f ; accum-str 85 #f))) ; graph 86 87(define (read-config-update config 88 #:for-syntax? for-syntax? 89 #:wrap wrap 90 #:readtable readtable 91 #:next-readtable [next-readtable (read-config-readtable config)] 92 #:reset-graph? local-graph? 93 #:keep-comment? keep-comment?) 94 (struct*-copy read-config config 95 [for-syntax? for-syntax?] 96 [wrap wrap] 97 [readtable readtable] 98 [next-readtable next-readtable] 99 [keep-comment? keep-comment?] 100 [st (if local-graph? 101 (read-config-state #f #f) 102 (read-config-st config))] 103 [parameter-override #hasheq()] 104 [parameter-cache (make-hasheq)])) 105 106(define (port+config->srcloc in config 107 #:end-pos [given-end-pos #f]) 108 (define end-pos 109 (or given-end-pos 110 (let-values ([(end-line end-col end-pos) (port-next-location in)]) 111 end-pos))) 112 (srcloc (or (read-config-source config) 113 (object-name in) 114 "UNKNOWN") 115 (read-config-line config) 116 (read-config-col config) 117 (read-config-pos config) 118 (and (read-config-pos config) end-pos (max 0 (- end-pos (read-config-pos config)))))) 119 120(define (reading-at config line col pos) 121 (struct*-copy read-config config 122 [line line] 123 [col col] 124 [pos pos])) 125 126(define (disable-wrapping config) 127 (struct*-copy read-config config 128 [wrap #f])) 129 130(define (keep-comment config) 131 (struct*-copy read-config config 132 [keep-comment? #t])) 133 134(define (discard-comment config) 135 (cond 136 [(not (read-config-keep-comment? config)) 137 config] 138 [else 139 (struct*-copy read-config config 140 [keep-comment? #f])])) 141 142(define (next-readtable config) 143 (cond 144 [(eq? (read-config-readtable config) 145 (read-config-next-readtable config)) 146 config] 147 [else 148 (struct*-copy read-config config 149 [readtable (read-config-next-readtable config)])])) 150