remember-implementation.hl.rkt (12175B)
1 #lang hyper-literate racket/base 2 @(require scribble-enhanced/doc) 3 @doc-lib-setup 4 5 @title[#:style manual-doc-style 6 #:tag "remember" 7 #:tag-prefix "(lib remember/remember-implementation.hl.rkt)" 8 ]{Implementation of Remember} 9 10 @(chunks-toc-prefix 11 '("(lib remember/remember-implementation.hl.rkt)")) 12 13 @(table-of-contents) 14 15 @section{@racket[remember]} 16 17 This module allows macros to remember some values across 18 compilations. Values are stored within the 19 @tc[remembered-values] hash table, which associates a 20 @racket[_category] (a symbol) with a set of values. 21 22 @chunk[<remembered-values> 23 (begin-for-syntax 24 (define remembered-values (make-hash)))] 25 26 A second set tracks values which were recently written, but 27 not initially added via @racket[remembered!] or 28 @racket[remembered-add!]. 29 30 @chunk[<remembered-values> 31 (begin-for-syntax 32 (define written-values (make-hash)))] 33 34 The user can specify input files from which remembered 35 values are loaded, and optionally an output file to which 36 new, not-yet-remembered values will be appended: 37 38 @CHUNK[<remember-file> 39 (define-for-syntax remember-output-file-parameter 40 (make-parameter #f (or? path-string? false?))) 41 42 (define-syntax (remember-output-file stx) 43 (syntax-case stx () 44 [(_ new-value) 45 (string? (syntax-e #'new-value)) 46 (begin (remember-output-file-parameter (syntax-e #'new-value)) 47 #'(void))] 48 [(_) 49 (quasisyntax/loc stx remember-output-file-parameter)])) 50 51 (define-syntax (remember-input-file stx) 52 (syntax-case stx () 53 [(_ name) 54 (string? (syntax-e #'name)) 55 #'(require (only-in name))])) 56 57 (define-syntax-rule (remember-io-file name) 58 (begin (remember-input-file name) 59 (remember-output-file name)))] 60 61 @CHUNK[<remember> 62 (define-syntax-rule (remembered! category value) 63 (begin-for-syntax 64 (remembered-add! 'category 'value))) 65 66 (define-for-syntax writable? 67 (disjoin number? 68 string? 69 symbol? 70 char? 71 null? 72 (λ (v) (and (pair? v) 73 (writable? (car v)) 74 (writable? (cdr v)))) 75 (λ (v) (and (vector? v) 76 (andmap writable? (vector->list v)))))) 77 78 (define-for-syntax (remembered-add! category value) 79 (unless (writable? value) 80 (error "Value to remember does not seem to be safely writable:" 81 value)) 82 (unless (symbol? category) 83 (error (format "The category was not a symbol, when remembering ~a:" 84 value) 85 category)) 86 (hash-update! remembered-values 87 category 88 (λ (s) (set-add s value)) 89 set)) 90 91 (define-for-syntax (remembered-add-written! category value) 92 (unless (writable? value) 93 (error "Value to remember does not seem to be safely writable:" 94 value)) 95 (unless (symbol? category) 96 (error (format "The category was not a symbol, when remembering ~a:" 97 value) 98 category)) 99 (hash-update! written-values 100 category 101 (λ (s) (set-add s value)) 102 set)) 103 104 (define-for-syntax (remembered? category value) 105 (unless (writable? value) 106 (error "Value to remember does not seem to be safely writable:" 107 value)) 108 (set-member? (hash-ref remembered-values category set) value)) 109 110 (define-for-syntax (written? category value) 111 (unless (writable? value) 112 (error "Value to remember does not seem to be safely writable:" 113 value)) 114 (set-member? (hash-ref written-values category set) value)) 115 116 (define-for-syntax (remembered-or-written? category value) 117 (or (remembered? category value) 118 (written? category value))) 119 120 (define-for-syntax (remember-write! category value) 121 (unless (writable? value) 122 (error "Value to remember does not seem to be safely writable:" 123 value)) 124 (unless (or (remembered? category value) 125 (written? category value)) 126 (when (remember-output-file-parameter) 127 (with-output-file [port (remember-output-file-parameter)] 128 #:exists 'append 129 (writeln (list 'remembered! category value) 130 port))) 131 (remembered-add-written! category value)))] 132 133 @chunk[<delayed-errors> 134 (begin-for-syntax 135 (define remember-errors-list '()) 136 (define remember-lifted-error #f))] 137 138 @chunk[<error> 139 (define-for-syntax (remembered-error! category 140 stx-value 141 [stx-errs (list stx-value)]) 142 (set! remember-errors-list 143 (cons (list category stx-value stx-errs) remember-errors-list)) 144 145 (unless (disable-remember-immediate-error) 146 (if (not (syntax-local-lift-context)) 147 ;; Trigger the error right now 148 (remember-all-hard-error) 149 ;; Lift a delayed error, which will be triggered later on 150 (lift-maybe-delayed-errors)))) 151 152 (define-for-syntax (remembered-add-error! category stx-value) 153 (remembered-add! category (syntax-e stx-value)) 154 (remembered-error! category stx-value))] 155 156 @CHUNK[<remember-all-hard-error> 157 ;; These two functions allow us to wait around 1000 levels of nested 158 ;; macro-expansion before triggering the error. 159 ;; If the error is triggered immediately when the lifted statements are 160 ;; added at the end of the module, then it can get executed before macros 161 ;; used in the righ-hand side of a (define …) are expanded, for example. 162 ;; Since these macros may need to remember more values, it's better to 163 ;; wait until they are all expanded. 164 ;; The number 1000 above in #`(delay-remember-all-hard-error1 1000) is 165 ;; arbitrary, but should be enough for most practical purposes, worst 166 ;; case the file would require a few more compilations to settle. 167 (define-syntax (delay-remember-all-hard-error1 stx) 168 (syntax-case stx () 169 [(_ n) 170 (number? (syntax-e #'n)) 171 (if (> (syntax-e #'n) 0) 172 #`(let () 173 (define blob 174 (delay-remember-all-hard-error2 #,(- (syntax-e #'n) 1))) 175 (void)) 176 (begin (syntax-local-lift-module-end-declaration 177 #`(remember-all-hard-error-macro)) 178 #'(void)))])) 179 180 (define-syntax (delay-remember-all-hard-error2 stx) 181 (syntax-case stx () 182 [(_ n) 183 (number? (syntax-e #'n)) 184 (begin 185 (syntax-local-lift-module-end-declaration 186 #'(delay-remember-all-hard-error1 n)) 187 #'n)])) 188 189 (define-for-syntax (remember-all-hard-error) 190 (define remember-errors-list-orig remember-errors-list) 191 (set! remember-errors-list '()) 192 (unless (empty? remember-errors-list-orig) 193 (raise-syntax-error 194 'remember 195 (format (~a "The values ~a were not remembered." 196 " Some of them may have been added to the" 197 " appropriate list automatically." 198 " Please recompile this file now.") 199 (string-join (remove-duplicates 200 (reverse 201 (stx-map (compose ~a syntax->datum) 202 (map cadr 203 remember-errors-list-orig)))) 204 ", ")) 205 #f 206 #f 207 (remove-duplicates 208 (append-map caddr remember-errors-list-orig) 209 #:key (λ (e) 210 (cons (syntax->datum e) 211 (build-source-location-list e))))))) 212 (define-syntax (remember-all-hard-error-macro stx) 213 (remember-all-hard-error) 214 #'(void))] 215 216 The @racket[disable-remember-immediate-error] parameter allows code to 217 temporarily prevent @racket[remembered-error!] from lifting a delayed error. 218 This can be useful for example when calling @racket[remembered-error!] from a 219 context where @racket[(syntax-local-lift-context)] is @racket[#false], e.g. 220 outside of the expansion of a macro, but within a @racket[begin-for-syntax] 221 block. 222 223 @chunk[<disable-remember-errors> 224 (define-for-syntax disable-remember-immediate-error (make-parameter #f))] 225 226 The error is still put aside, so that if a delayed error was triggered by 227 another call to @racket[remembered-error!], the error will still be included 228 with the other delayed errors. If no delayed error is triggered during 229 macro-expansion, the error that was put aside will be ignored. To prevent 230 that, the user can call @racket[lift-maybe-delayed-errors] within a context 231 where lifts are possible. 232 233 @chunk[<lift-maybe-delayed-errors> 234 (define-for-syntax (lift-maybe-delayed-errors) 235 (if (syntax-transforming-module-expression?) 236 ;; Lift a delayed error, attempting to allow several (1000) levels 237 ;; of nested let blocks to expand before pulling the alarm signal. 238 (unless remember-lifted-error 239 (set! remember-lifted-error #t) 240 (syntax-local-lift-module-end-declaration 241 #`(delay-remember-all-hard-error1 1000))) 242 ;; Lift a delayed error, which will be triggered after the current 243 ;; expansion pass (i.e. before the contents of any let form is 244 ;; expanded). 245 (syntax-local-lift-expression 246 #`(remember-all-hard-error-macro))))] 247 248 249 @CHUNK[<get-remembered> 250 (define-for-syntax (get-remembered category) 251 (hash-ref remembered-values category set))] 252 253 @chunk[<provide> 254 (begin-for-syntax 255 (provide get-remembered 256 remembered-add! 257 remembered? 258 remembered-or-written? 259 remember-write! 260 remembered-error! 261 remember-output-file-parameter 262 disable-remember-immediate-error 263 lift-maybe-delayed-errors)) 264 (provide remember-input-file 265 remember-output-file 266 remember-io-file 267 remembered!) 268 269 (module+ private 270 (begin-for-syntax 271 (provide remembered-add-written!)))] 272 273 @; TODO: circumvents bug https://github.com/racket/scribble/issues/44 274 @(require racket/require) 275 @chunk[<*> 276 (require mzlib/etc 277 ;; TODO: circumvent https://github.com/racket/scribble/issues/44 278 racket/require 279 (subtract-in phc-toolkit/untyped syntax/stx) 280 syntax/stx 281 (for-syntax racket/base 282 racket/function 283 racket/bool 284 racket/set 285 racket/list 286 mzlib/etc 287 ;;TODO: https://github.com/racket/scribble/issues/44 288 (subtract-in phc-toolkit/untyped 289 syntax/stx) 290 syntax/stx 291 syntax/srcloc 292 racket/string 293 racket/format)) 294 <provide> 295 <remembered-values> 296 <remember-file> 297 <remember> 298 <get-remembered> 299 <delayed-errors> 300 <disable-remember-errors> 301 <lift-maybe-delayed-errors> 302 <remember-all-hard-error> 303 <error>]