traversal.hl.rkt (15348B)
1 #lang hyper-literate typed/racket/base #:no-require-lang #:no-auto-require 2 @(require racket/require 3 scribble-enhanced/doc 4 racket/require 5 hyper-literate 6 (subtract-in scribble/struct scribble-enhanced/doc) 7 scribble/decode 8 (for-label racket/format 9 racket/promise 10 racket/list 11 (except-in subtemplate/override begin let) 12 type-expander 13 phc-adt 14 (except-in (subtract-in typed/racket/base 15 type-expander 16 subtemplate/override) 17 values) 18 (only-in racket/base values) 19 (subtract-in racket/contract typed/racket/base) 20 (except-in phc-toolkit generate-temporary) 21 phc-toolkit/untyped-only 22 remember)) 23 @(unless-preexpanding 24 (require (for-label (submod "..")))) 25 @doc-lib-setup 26 27 @title[#:style manual-doc-style 28 #:tag "traversal" 29 #:tag-prefix "phc-graph/traversal"]{Parametric replacement of parts of 30 data structures} 31 32 @(chunks-toc-prefix 33 '("(lib phc-graph/scribblings/phc-graph-implementation.scrbl)" 34 "phc-graph/traversal")) 35 36 @(table-of-contents) 37 38 @(declare-exporting (lib "phc-graph/traversal.hl.rkt")) 39 40 @section{Introduction} 41 42 This utility allows functionally updating parts of data structures. The 43 @racket[define-fold] macro takes the type of the whole data structure and a 44 list of type names associated with their predicate. It locates all literal 45 occurrences of those type names within the data structure, and identifies 46 those locations as the parts to replace. The type of the whole data structure 47 is expressed as a syntactic tree. Within that syntactic tree, only the parts 48 which are syntactically equal to one of the types to replace are considered. 49 50 As an example, suppose the whole type is 51 @racket[(List Foo Number (Listof String))], and @racket[Foo] is defined as: 52 53 @racketblock[(define-type Foo (Listof String))] 54 55 If @racket[Foo] is given as a type to replace, and its replacement type is 56 @racket[(Listof Symbol)], then the type of the result would be: 57 58 @racketblock[(List (Listof Symbol) Number (Listof String))] 59 60 The second occurrence of @racket[(Listof String)], although semantically 61 equivalent to the type to replace, @racket[Foo], will not be altered, as it is 62 not expressed syntactically using the @racket[Foo] identifier. 63 64 @defform[ 65 (define-fold _function-name _type-name _whole-type _type-to-replaceᵢ ...)]{ 66 The @racket[define-fold] macro takes the type of the whole data structure, and 67 a list of types to replace, each associated with a predicate for that type. It 68 @;defines @racket[_name] as a macro, which behaves as follows: 69 defines @racket[(_type-name _Tᵢ ...)] as a polymorphic type, with one type 70 argument for each @racket[_type-to-replaceᵢ], such that 71 72 @racketblock[(_type-name _type-to-replaceᵢ ...)] 73 74 is the same type as 75 76 @racketblock[_whole-type] 77 78 In other words, @racket[_type-name] is defined as @racket[_whole-type], except 79 that each syntactic occurrence of a @racket[_type-to-replaceᵢ] is replaced with 80 the corresponding type argument @racket[_Tᵢ]. 81 82 It also defines @racket[_function-name] as a function, with the type 83 84 @racketblock[(∀ (Aᵢ ... Bᵢ ... Acc) 85 (→ (?@ (→ Any Boolean : Aᵢ) 86 (→ Aᵢ Acc (Values Bᵢ Acc))) 87 ... 88 (→ (type-name Aᵢ ...) 89 Acc 90 (Values (type-name Bᵢ ...) 91 Acc))))] 92 93 We use the @racket[?@] notation from 94 @racketmodname[syntax/parse/experimental/template] to indicate that the 95 function accepts a predicate, followed by an update function, followed by 96 another predicate, and so on. For example, the function type when there are 97 three @racket[_type-to-replaceᵢ] would be: 98 99 @racketblock[(∀ (A₁ A₂ A₃ B₁ B₂ B₃ Acc) 100 (→ (→ Any Boolean : A₁) 101 (→ A₁ Acc (Values B₁ Acc)) 102 (→ Any Boolean : A₂) 103 (→ A₂ Acc (Values B₂ Acc)) 104 (→ Any Boolean : A₃) 105 (→ A₃ Acc (Values B₃ Acc)) 106 (→ (type-name A₁ A₂ A₃) 107 Acc 108 (Values (type-name B₁ B₂ B₃) 109 Acc))))] 110 111 The @racket[_function-name] replaces all values in the whole data structure 112 which are present in locations corresponding to a @racket[_type-to-replaceᵢ] in 113 the @racket[_whole-type]. It expects those values to have the type @racket[Aᵢ], 114 i.e. its input type is not restricted to @racket[_whole-type], any polymorphic 115 instance of @racket[_type-name] is valid. Each value is passed as an argument 116 to the corresponding update function with type 117 @racket[(→ Aᵢ Acc (Values Bᵢ Acc))], and the result of type @racket[Bᵢ] is 118 used as a replacement. 119 120 An accumulator value, with the type @racket[Acc], is threaded through all 121 calls to all update functions, so that the update functions can communicate 122 state in a functional way.} 123 124 @section{Implementation} 125 126 @subsection{Caching the results of @racket[define-fold]} 127 128 @chunk[<with-folds> 129 (define-for-syntax get-f-cache (make-parameter #f)) 130 (define-for-syntax get-τ-cache (make-parameter #f)) 131 (define-for-syntax get-f-defs (make-parameter #f)) 132 (define-for-syntax get-τ-defs (make-parameter #f)) 133 (define-for-syntax (with-folds thunk) 134 ;; TODO: should probably use bound-id instead. 135 (parameterize ([get-f-cache (make-mutable-free-id-tree-table)] 136 [get-τ-cache (make-mutable-free-id-tree-table)] 137 [get-f-defs (box '())] 138 [get-τ-defs (box '())]) 139 (define/with-syntax thunk-result (thunk)) 140 (with-syntax ([([f-id f-body f-type] …) (unbox (get-f-defs))] 141 [([τ-id . τ-body] …) (unbox (get-τ-defs))]) 142 #`(begin (define-type τ-id τ-body) … 143 (: f-id f-type) … 144 (define f-id f-body) … 145 thunk-result))))] 146 147 @;@subsection{…} 148 149 150 @; TODO: recursively go down the tree. If there are no replacements, return #f 151 @; all the way up, so that a simple identity function can be applied in these 152 @; cases. 153 154 155 @CHUNK[<api> 156 (define-template-metafunction (!replace-in-type stx) 157 (syntax-case stx () 158 [(_ _whole-type [_type-to-replaceᵢ _Tᵢ] …) 159 #`(#,(syntax-local-template-metafunction-introduce 160 (fold-τ #'(_whole-type _type-to-replaceᵢ …))) _Tᵢ …)]))] 161 162 @CHUNK[<api> 163 (define-template-metafunction (!∀-replace-in-type stx) 164 (syntax-case stx () 165 [(_ _whole-type _type-to-replaceᵢ …) 166 (syntax-local-template-metafunction-introduce 167 (fold-τ #'(_whole-type _type-to-replaceᵢ …)))]))] 168 169 @CHUNK[<fold-τ> 170 (define fold-τ 171 (syntax-parser 172 [(_whole-type:type _type-to-replaceᵢ:type …) 173 #:with rec-args #'([_type-to-replaceᵢ _Tᵢ] …) 174 (cached [τ- 175 (get-τ-cache) 176 (get-τ-defs) 177 #'(_whole-type _type-to-replaceᵢ …)] 178 (define replacements 179 (make-immutable-free-id-tree-table 180 (list [cons #'_type-to-replaceᵢ #'_Tᵢ] …))) 181 #`(∀ (_Tᵢ …) 182 #,(syntax-parse #'_whole-type 183 #:literals (Null Pairof Listof List Vectorof Vector 184 U tagged) 185 <type-cases>)))]))] 186 187 @CHUNK[<cached> 188 (begin-for-syntax 189 (define-syntax-rule (cached [base cache defs key] . body) 190 (begin 191 (unless (and cache defs) 192 (error "fold-τ and fold-f must be called within with-folds")) 193 (if (dict-has-key? cache key) 194 (dict-ref cache key) 195 (let ([base #`#,(gensym 'base)]) 196 (dict-set! cache key base) 197 (let ([result (let () . body)]) 198 (set-box! defs `([,base . ,result] . ,(unbox defs))) 199 base))))))] 200 201 @CHUNK[<api> 202 (define-template-metafunction (!replace-in-instance stx) 203 (syntax-case stx () 204 [(_ _whole-type [_type-to-replaceᵢ _predicateᵢ _updateᵢ] …) 205 #`(#,(syntax-local-template-metafunction-introduce 206 (fold-f #'(_whole-type _type-to-replaceᵢ …))) 207 {?@ _predicateᵢ _updateᵢ} …)]))] 208 209 @CHUNK[<api> 210 (define-template-metafunction (!λ-replace-in-instance stx) 211 (syntax-case stx () 212 [(_ _whole-type _type-to-replaceᵢ …) 213 (syntax-local-introduce 214 (fold-f #'(_whole-type _type-to-replaceᵢ …)))]))] 215 216 @CHUNK[<fold-f> 217 (define fold-f 218 (syntax-parser 219 [(_whole-type:type _type-to-replaceᵢ:type …) 220 #:with rec-args #'([_type-to-replaceᵢ _predicateᵢ _updateᵢ] …) 221 (define replacements 222 (make-immutable-free-id-tree-table 223 (list [cons #'_type-to-replaceᵢ #'_updateᵢ] …))) 224 (define/with-syntax _args #'({?@ _predicateᵢ _updateᵢ} …)) 225 (cached [f- 226 (get-f-cache) 227 (get-f-defs) 228 #'(_whole-type _type-to-replaceᵢ …)] 229 #`[<fold-f-proc> 230 <fold-f-type>])]))] 231 232 @CHUNK[<fold-f-proc> 233 (λ ({?@ _predicateᵢ _updateᵢ} …) 234 (λ (v acc) 235 #,(syntax-parse #'_whole-type 236 #:literals (Null Pairof Listof List 237 Vectorof Vector U tagged) 238 <f-cases>)))] 239 240 @chunk[<fold-f-type> 241 (∀ (_Aᵢ … _Bᵢ … Acc) 242 (→ (?@ (→ Any Boolean : _Aᵢ) 243 (→ _Aᵢ Acc (Values _Bᵢ Acc))) 244 … 245 (→ (!replace-in-type _whole-type [_type-to-replaceᵢ _Aᵢ] …) 246 Acc 247 (Values (!replace-in-type _whole-type [_type-to-replaceᵢ _Bᵢ] …) 248 Acc))))] 249 250 @chunk[<f-cases> 251 [t 252 #:when (dict-has-key? replacements #'t) 253 #:with _update (dict-ref replacements #'t) 254 #'(_update v acc)]] 255 256 @chunk[<type-cases> 257 [t 258 #:when (dict-has-key? replacements #'t) 259 #:with _T (dict-ref replacements #'t) 260 #'_T]] 261 262 @chunk[<type-cases> 263 [(~or Null (List)) 264 #'Null]] 265 266 @chunk[<f-cases> 267 [(~or Null (List)) 268 #'(values v acc)]] 269 270 271 @CHUNK[<type-cases> 272 [(Pairof X Y) 273 #'(Pairof (!replace-in-type X . rec-args) 274 (!replace-in-type Y . rec-args))]] 275 276 @CHUNK[<f-cases> 277 [(Pairof X Y) 278 #'(let*-values ([(result-x acc-x) 279 ((!replace-in-instance X . rec-args) (car v) acc)] 280 [(result-y acc-y) 281 ((!replace-in-instance Y . rec-args) (cdr v) acc-x)]) 282 (values (cons result-x result-y) acc-y))]] 283 284 @CHUNK[<type-cases> 285 [(Listof X) 286 #'(Listof (!replace-in-type X . rec-args))]] 287 288 @CHUNK[<f-cases> 289 [(Listof X) 290 #'(foldl-map (!replace-in-instance X . rec-args) 291 acc v)]] 292 293 @CHUNK[<type-cases> 294 [(Vectorof X) 295 #'(Vectorof (!replace-in-type X . rec-args))]] 296 297 @CHUNK[<ftype-cases> 298 [(Vectorof X) 299 #'(vector->immutable-vector 300 (list->vector 301 (foldl-map (!replace-in-instance X . rec-args) 302 acc 303 (vector->list v))))]] 304 305 306 @CHUNK[<type-cases> 307 [(List X Y …) 308 #'(Pairof (!replace-in-type X . rec-args) 309 (!replace-in-type (List Y …) . rec-args))]] 310 311 @CHUNK[<f-cases> 312 [(List X Y …) 313 #'(let*-values ([(result-x acc-x) <f-list-car>] 314 [(result-y* acc-y*) <f-list-cdr>]) 315 (values (cons result-x result-y*) acc-y*))]] 316 317 where the replacement is applied to the @racket[car], and to the @racket[cdr] 318 as a whole (i.e. by recursion on the whole remaining list of types): 319 320 @chunk[<f-list-car> 321 ((!replace-in-instance X . rec-args) (car v) acc)] 322 323 @chunk[<f-list-cdr> 324 ((!replace-in-instance (List Y …) . rec-args) (cdr v) acc-x)] 325 326 @CHUNK[<type-cases> 327 [(U _Xⱼ …) 328 #'(U (!replace-in-type _Xⱼ . rec-args) …)]] 329 330 @CHUNK[<f-cases> 331 [(U _Xⱼ …) 332 #'(dispatch-union v 333 ([_type-to-replaceᵢ Aᵢ _predicateᵢ] …) 334 [_Xⱼ ((!replace-in-instance _Xⱼ . rec-args) v acc)] 335 …)]] 336 337 @CHUNK[<type-cases> 338 [(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …) 339 #'(tagged _name [_fieldⱼ : (!replace-in-type _Xⱼ . rec-args)] …)]] 340 341 @CHUNK[<f-cases> 342 [(tagged _name [_fieldⱼ (~optional :colon) _Xⱼ] …) 343 #'(let*-values 344 ([(_resultⱼ acc) 345 ((!replace-in-instance _Xⱼ . rec-args) (uniform-get v _fieldⱼ) 346 acc)] 347 …) 348 (values (tagged _name #:instance [_fieldⱼ _resultⱼ] …) 349 acc))]] 350 351 @chunk[<type-cases> 352 [else-T 353 #'else-T]] 354 355 @chunk[<f-cases> 356 [else-T 357 #'(values v acc)]] 358 359 360 where @racket[foldl-map] is defined as: 361 362 @chunk[<foldl-map> 363 (: foldl-map (∀ (A B Acc) (→ (→ A Acc (Values B Acc)) 364 Acc 365 (Listof A) 366 (Values (Listof B) Acc)))) 367 (define (foldl-map f acc l) 368 (if (null? l) 369 (values l 370 acc) 371 (let*-values ([(v a) (f (car l) acc)] 372 [(ll aa) (foldl-map f a (cdr l))]) 373 (values (cons v ll) 374 aa))))] 375 376 @section{Putting it all together} 377 378 @chunk[<*> 379 (require racket/require 380 phc-toolkit 381 type-expander 382 phc-adt 383 "dispatch-union.rkt" 384 (for-syntax (subtract-in racket/base 385 subtemplate/override) 386 subtemplate/override 387 phc-toolkit/untyped 388 type-expander/expander 389 "free-identifier-tree-equal.rkt" 390 racket/dict) 391 (for-meta 2 racket/base) 392 (for-meta 2 phc-toolkit/untyped) 393 (for-meta 2 syntax/parse)) 394 395 (provide (for-syntax with-folds 396 !replace-in-type 397 !∀-replace-in-type 398 !replace-in-instance 399 !λ-replace-in-instance)) 400 <foldl-map> 401 <with-folds> 402 <cached> 403 (begin-for-syntax 404 <api> 405 <fold-τ> 406 <fold-f>)]