flexible-with.hl.rkt (16028B)
1 #lang hyper-literate #:♦ (dotlambda/unhygienic . type-expander/lang) 2 3 ♦title[#:style manual-doc-style ;#:style (with-html5 manual-doc-style) 4 #:tag "flexible-with" 5 #:tag-prefix "phc-graph/flexible-with"]{Flexible functional 6 modification and extension of records} 7 8 ♦(chunks-toc-prefix 9 '("(lib phc-graph/scribblings/phc-graph-implementation.scrbl)" 10 "phc-graph/flexible-with")) 11 12 ♦section{Type of a tree-record, with a hole} 13 14 ♦CHUNK[<tree-type-with-replacement> 15 (define-for-syntax (tree-type-with-replacement n last τ*) 16 (define-values (next mod) (quotient/remainder n 2)) 17 (cond [(null? τ*) last] 18 [(= mod 0) 19 (tree-type-with-replacement next 20 #`(Pairof #,last #,(car τ*)) 21 (cdr τ*))] 22 [else 23 (tree-type-with-replacement next 24 #`(Pairof #,(car τ*) #,last) 25 (cdr τ*))]))] 26 27 ♦section{Functionally updating a tree-record} 28 29 ♦subsection{Adding and modifying fields} 30 31 Since we only deal with functional updates of immutable records, modifying a 32 field does little more than discarding the old value, and injecting the new 33 value instead into the new, updated record. 34 35 Adding a new field is done using the same exact operation: missing fields are 36 denoted by a special value, ♦racket['NONE], while present fields are 37 represented as instances of the polymorphic struct ♦racket[(Some T)]. Adding a 38 new field is therefore as simple as discarding the old ♦racket['NONE] marker, 39 and replacing it with the new value, wrapped with ♦racket[Some]. A field 40 update would instead discard the old instance of ♦racket[Some], and replace it 41 with a new one. 42 43 ♦CHUNK[<make-replace-in-tree-body> 44 (if (= i 1) 45 #'(delay/pure/stateless replacement) 46 (let* ([bits (to-bits i)] 47 [next (from-bits (cons #t (cddr bits)))] 48 [mod (cadr bits)]) 49 (define/with-syntax next-id (vector-ref low-names (sub1 next))) 50 (if mod 51 #`(replace-right (inst next-id #,@τ*-limited+T-next) 52 tree-thunk 53 replacement) 54 #`(replace-left (inst next-id #,@τ*-limited+T-next) 55 tree-thunk 56 replacement))))] 57 58 ♦CHUNK[<define-replace-in-tree> 59 (define-pure/stateless 60 (: replace-right (∀ (A B C R) (→ (→ (Promise B) R (Promise C)) 61 (Promise (Pairof A B)) 62 R 63 (Promise (Pairof A C))))) 64 (define 65 #:∀ (A B C R) 66 (replace-right [next-id : (→ (Promise B) R (Promise C))] 67 [tree-thunk : (Promise (Pairof A B))] 68 [replacement : R]) 69 (delay/pure/stateless 70 (let ([tree (force tree-thunk)]) 71 (let ([left-subtree (car tree)] 72 [right-subtree (cdr tree)]) 73 (cons left-subtree 74 (force (next-id (delay/pure/stateless right-subtree) 75 replacement)))))))) 76 (define-pure/stateless 77 (: replace-left (∀ (A B C R) (→ (→ (Promise A) R (Promise C)) 78 (Promise (Pairof A B)) 79 R 80 (Promise (Pairof C B))))) 81 (define 82 #:∀ (A B C R) 83 (replace-left [next-id : (→ (Promise A) R (Promise C))] 84 [tree-thunk : (Promise (Pairof A B))] 85 [replacement : R]) 86 (delay/pure/stateless 87 (let ([tree (force tree-thunk)]) 88 (let ([left-subtree (car tree)] 89 [right-subtree (cdr tree)]) 90 (cons (force (next-id (delay/pure/stateless left-subtree) 91 replacement)) 92 right-subtree)))))) 93 94 (define-for-syntax (define-replace-in-tree low-names names rm-names τ* i depth) 95 (define/with-syntax name (vector-ref names (sub1 i))) 96 (define/with-syntax rm-name (vector-ref rm-names (sub1 i))) 97 (define/with-syntax low-name (vector-ref low-names (sub1 i))) 98 (define/with-syntax tree-type-with-replacement-name (gensym 'tree-type-with-replacement)) 99 (define/with-syntax tree-replacement-type-name (gensym 'tree-replacement-type)) 100 (define τ*-limited (take τ* depth)) 101 (define τ*-limited+T-next (if (= depth 0) 102 (list #'T) 103 (append (take τ* (sub1 depth)) (list #'T)))) 104 #`(begin 105 (provide name rm-name) 106 (define-type (tree-type-with-replacement-name #,@τ*-limited T) 107 (Promise #,(tree-type-with-replacement i #'T τ*-limited))) 108 109 (define-pure/stateless 110 (: low-name 111 (∀ (#,@τ*-limited T) 112 (→ (tree-type-with-replacement-name #,@τ*-limited Any) 113 T 114 (tree-type-with-replacement-name #,@τ*-limited T)))) 115 (define 116 #:∀ (#,@τ*-limited T) 117 (low-name [tree-thunk : (tree-type-with-replacement-name #,@τ*-limited Any)] 118 [replacement : T]) 119 : (Promise #,(tree-type-with-replacement i #'T τ*-limited)) 120 #,<make-replace-in-tree-body>)) 121 122 (: name 123 (∀ (#,@τ*-limited T) 124 (→ (tree-type-with-replacement-name #,@τ*-limited Any) 125 T 126 (tree-type-with-replacement-name #,@τ*-limited (Some T))))) 127 (define (name tree-thunk replacement) 128 (low-name tree-thunk (Some replacement))) 129 130 (: rm-name 131 (∀ (#,@τ*-limited) 132 (→ (tree-type-with-replacement-name #,@τ*-limited (Some Any)) 133 (tree-type-with-replacement-name #,@τ*-limited 'NONE)))) 134 (define (rm-name tree-thunk) 135 (low-name tree-thunk 'NONE))))] 136 137 ♦section{Auxiliary values} 138 139 The following sections reuse a few values which are derived from the list of 140 fields: 141 142 ♦CHUNK[<utils> 143 (define all-fields #'(field …)) 144 (define depth-above (ceiling-log2 (length (syntax->list #'(field …))))) 145 (define offset (expt 2 depth-above)) 146 (define i*-above (range 1 (expt 2 depth-above))) 147 (define names (list->vector 148 (append (map (λ (i) (format-id #'here "-with-~a" i)) 149 i*-above) 150 (stx-map (λ (f) (format-id f "with-~a" f)) 151 #'(field …))))) 152 (define rm-names (list->vector 153 (append (map (λ (i) (format-id #'here "-without-~a" i)) 154 i*-above) 155 (stx-map (λ (f) (format-id f "without-~a" f)) 156 #'(field …))))) 157 (define low-names (list->vector 158 (append (map (λ (i) (format-id #'here "-u-with-~a" i)) 159 i*-above) 160 (stx-map (λ (f) (format-id f "u-with-~a" f)) 161 #'(field …)))))] 162 163 ♦section{Type of a tree-record} 164 165 ♦CHUNK[<τ-tree-with-fields> 166 (define-for-syntax (τ-tree-with-fields struct-fields fields) 167 (define/with-syntax (struct-field …) struct-fields) 168 (define/with-syntax (field …) fields) 169 <utils> 170 ;; Like in convert-from-struct 171 (define lookup 172 (make-free-id-table 173 (for/list ([n (in-syntax all-fields)] 174 [i (in-naturals)]) 175 (cons n (+ i offset))))) 176 (define fields+indices 177 (sort (stx-map λ.(cons % (free-id-table-ref lookup %)) 178 #'(struct-field …)) 179 < 180 #:key cdr)) 181 182 (define up (* offset 2)) 183 184 ;; Like in convert-fields, but with Pairof 185 (define (f i) 186 ;(displayln (list i '/ up (syntax->datum #`#,fields+indices))) 187 (if (and (pair? fields+indices) (= i (cdar fields+indices))) 188 (begin0 189 `(Some ,(caar fields+indices)) 190 (set! fields+indices (cdr fields+indices))) 191 (if (>= (* i 2) up) ;; DEPTH 192 ''NONE 193 (begin 194 `(Pairof ,(f (* i 2)) 195 ,(f (add1 (* i 2)))))))) 196 (f 1))] 197 198 ♦section{Conversion to and from record-trees} 199 200 ♦CHUNK[<define-struct↔tree> 201 (define-for-syntax (define-struct↔tree 202 offset all-fields τ* struct-name fields) 203 (define/with-syntax (field …) fields) 204 (define/with-syntax fields→tree-name 205 (format-id struct-name "~a→tree" struct-name)) 206 (define/with-syntax tree→fields-name 207 (format-id struct-name "tree→~a" struct-name)) 208 (define lookup 209 (make-free-id-table 210 (for/list ([n (in-syntax all-fields)] 211 [i (in-naturals)]) 212 (cons n (+ i offset))))) 213 (define fields+indices 214 (sort (stx-map λ.(cons % (free-id-table-ref lookup %)) 215 fields) 216 < 217 #:key cdr)) 218 #`(begin 219 (: fields→tree-name (∀ (field …) 220 (→ field … 221 (Promise #,(τ-tree-with-fields #'(field …) 222 all-fields))))) 223 (define (fields→tree-name field …) 224 (delay/pure/stateless 225 #,(convert-fields (* offset 2) fields+indices))) 226 227 (: tree→fields-name (∀ (field …) 228 (→ (Promise #,(τ-tree-with-fields #'(field …) 229 all-fields)) 230 (Values field …)))) 231 (define (tree→fields-name tree-thunk) 232 (define tree (force tree-thunk)) 233 #,(convert-back-fields (* offset 2) fields+indices))))] 234 235 ♦subsection{Creating a new tree-record} 236 237 ♦CHUNK[<convert-fields> 238 (define-for-syntax (convert-fields up fields+indices) 239 ;(displayln fields+indices) 240 (define (f i) 241 ;(displayln (list i '/ up (syntax->datum #`#,fields+indices))) 242 (if (and (pair? fields+indices) (= i (cdar fields+indices))) 243 (begin0 244 `(Some ,(caar fields+indices)) 245 (set! fields+indices (cdr fields+indices))) 246 (if (>= (* i 2) up) ;; DEPTH 247 ''NONE 248 `(cons ,(f (* i 2)) 249 ,(f (add1 (* i 2))))))) 250 ;(displayln (syntax->datum #`#,(f 1))) 251 (f 1))] 252 253 254 ♦subsection{Extracting all the fields from a tree-record} 255 256 We traverse the tree in preorder, and accumulate definitions naming the 257 interesting subparts of the trees (those where there are fields). 258 259 ♦CHUNK[<convert-back-fields> 260 (define-for-syntax (convert-back-fields up fields+indices) 261 (define result '()) 262 (define definitions '()) 263 (define (f i t) 264 (if (and (pair? fields+indices) (= i (cdar fields+indices))) 265 (begin0 266 (begin 267 (set! result (cons #`(Some-v #,t) result)) 268 #t) 269 (set! fields+indices (cdr fields+indices))) 270 (if (>= (* i 2) up) ;; DEPTH 271 #f 272 (let* ([left-t (string->symbol 273 (format "subtree-~a" (* i 2)))] 274 [right-t (string->symbol 275 (format "subtree-~a" (add1 (* i 2))))] 276 [left (f (* i 2) left-t)] 277 [right (f (add1 (* i 2)) right-t)]) 278 (cond 279 [(and left right) 280 (set! definitions (cons #`(define #,left-t (car #,t)) 281 definitions)) 282 (set! definitions (cons #`(define #,right-t (cdr #,t)) 283 definitions)) 284 #t] 285 [left 286 (set! definitions (cons #`(define #,left-t (car #,t)) 287 definitions)) 288 #t] 289 [right 290 (set! definitions (cons #`(define #,right-t (cdr #,t)) 291 definitions)) 292 #t] 293 [else 294 #f]))))) 295 (f 1 #'tree) 296 #`(begin #,@definitions (values . #,(reverse result))))] 297 298 ♦section{Defining the converters and accessors for each known record type} 299 300 ♦CHUNK[<define-trees> 301 (define-for-syntax (define-trees stx) 302 (syntax-case stx () 303 [(bt-fields-id (field …) [struct struct-field …] …) 304 (let () 305 <utils> 306 (define ∀-types (map λ.(format-id #'here "τ~a" %) 307 (range (add1 depth-above)))) 308 (define total-nb-functions (vector-length names)) 309 <define-trees-result>)]))] 310 311 ♦CHUNK[<bt-fields-type> 312 (define-for-syntax (bt-fields-type fields) 313 (λ (stx) 314 (syntax-case stx () 315 [(_ . fs) 316 #`(∀ fs (Promise #,(τ-tree-with-fields #'fs 317 fields)))])))] 318 319 ♦CHUNK[<define-trees-result> 320 #`(begin 321 (define-type-expander bt-fields-id 322 (bt-fields-type #'#,(syntax-local-introduce #'(field …)))) 323 #,@(map λ.(define-replace-in-tree low-names 324 names rm-names ∀-types % (floor-log2 %)) 325 (range 1 (add1 total-nb-functions))) 326 #;#,@(map λ.(define-remove-in-tree rm-names ∀-types % (floor-log2 %)) 327 (range 1 (add1 total-nb-functions))) 328 #,@(map λ.(define-struct↔tree 329 offset all-fields ∀-types %1 %2) 330 (syntax->list #'(struct …)) 331 (syntax->list #'([struct-field …] …))))] 332 333 ♦subsection{Putting it all together} 334 335 ♦chunk[<maybe> 336 (struct (T) Some ([v : T]) #:transparent) 337 (define-type (Maybe T) (U (Some T) 'NONE))] 338 339 ♦chunk[<*> 340 (require delay-pure 341 "flexible-with-utils.hl.rkt" 342 (for-syntax (rename-in racket/base [... …]) 343 syntax/stx 344 racket/syntax 345 racket/list 346 syntax/id-table 347 racket/sequence) 348 (for-meta 2 racket/base)) 349 350 (provide (for-syntax define-trees) 351 ;; For tests: 352 (struct-out Some) 353 354 ;;DEBUG: 355 (for-syntax τ-tree-with-fields) 356 ) 357 358 <maybe> 359 <tree-type-with-replacement> 360 <define-replace-in-tree> 361 ;<define-remove-in-tree> 362 <convert-fields> 363 <convert-back-fields> 364 <τ-tree-with-fields> 365 <define-struct↔tree> 366 <define-trees> 367 <bt-fields-type>] 368 369 ♦include-section[(submod "flexible-with-utils.hl.rkt" doc)]