suzanne.soy/phc-graph
1
0
Fork 0
Code Issues 24 Pull Requests Actions Packages Projects Releases Wiki Activity

Use dotlambda's λ. notation instead of #λ.

Browse Source
This commit is contained in:
Georges Dupéron 2017-04-26 02:22:57 +02:00
parent 37120eec9c
commit c46d371e02
3 changed files with 48 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

76
flexible-with.hl.rkt
View File

@ -1,17 +1,17 @@
#lang aful/unhygienic hyper-literate type-expander/lang #lang hyper-literate #:♦ (dotlambda/unhygienic . type-expander/lang)
@title[#:style manual-doc-style ;#:style (with-html5 manual-doc-style) ♦title[#:style manual-doc-style ;#:style (with-html5 manual-doc-style)
#:tag "flexible-with" #:tag "flexible-with"
#:tag-prefix "phc-graph/flexible-with"]{Flexible functional #:tag-prefix "phc-graph/flexible-with"]{Flexible functional
modification and extension of records} modification and extension of records}
@(chunks-toc-prefix ♦(chunks-toc-prefix
'("(lib phc-graph/scribblings/phc-graph-implementation.scrbl)" '("(lib phc-graph/scribblings/phc-graph-implementation.scrbl)"
"phc-graph/flexible-with")) "phc-graph/flexible-with"))
@section{Type of a tree-record, with a hole} ♦section{Type of a tree-record, with a hole}
@CHUNK[<tree-type-with-replacement> ♦CHUNK[<tree-type-with-replacement>
(define-for-syntax (tree-type-with-replacement n last τ*) (define-for-syntax (tree-type-with-replacement n last τ*)
(define-values (next mod) (quotient/remainder n 2)) (define-values (next mod) (quotient/remainder n 2))
(cond [(null? τ*) last] (cond [(null? τ*) last]
@ -24,23 +24,23 @@
#`(Pairof #,(car τ*) #,last) #`(Pairof #,(car τ*) #,last)
(cdr τ*))]))] (cdr τ*))]))]
@section{Functionally updating a tree-record} ♦section{Functionally updating a tree-record}
@subsection{Adding and modifying fields} ♦subsection{Adding and modifying fields}
Since we only deal with functional updates of immutable records, modifying a Since we only deal with functional updates of immutable records, modifying a
field does little more than discarding the old value, and injecting the new field does little more than discarding the old value, and injecting the new
value instead into the new, updated record. value instead into the new, updated record.
Adding a new field is done using the same exact operation: missing fields are Adding a new field is done using the same exact operation: missing fields are
denoted by a special value, @racket['NONE], while present fields are denoted by a special value, ♦racket['NONE], while present fields are
represented as instances of the polymorphic struct @racket[(Some T)]. Adding a represented as instances of the polymorphic struct ♦racket[(Some T)]. Adding a
new field is therefore as simple as discarding the old @racket['NONE] marker, new field is therefore as simple as discarding the old ♦racket['NONE] marker,
and replacing it with the new value, wrapped with @racket[Some]. A field and replacing it with the new value, wrapped with ♦racket[Some]. A field
update would instead discard the old instance of @racket[Some], and replace it update would instead discard the old instance of ♦racket[Some], and replace it
with a new one. with a new one.
@CHUNK[<make-replace-in-tree-body> ♦CHUNK[<make-replace-in-tree-body>
(if (= i 1) (if (= i 1)
#'(delay/pure/stateless replacement) #'(delay/pure/stateless replacement)
(let* ([bits (to-bits i)] (let* ([bits (to-bits i)]
@ -55,7 +55,7 @@ with a new one.
tree-thunk tree-thunk
replacement))))] replacement))))]
@CHUNK[<define-replace-in-tree> ♦CHUNK[<define-replace-in-tree>
(: replace-right (∀ (A B C R) (→ (→ (Promise B) R (Promise C)) (: replace-right (∀ (A B C R) (→ (→ (Promise B) R (Promise C))
(Promise (Pairof A B)) (Promise (Pairof A B))
R R
@ -131,12 +131,12 @@ with a new one.
(define (rm-name tree-thunk) (define (rm-name tree-thunk)
(low-name tree-thunk 'NONE))))] (low-name tree-thunk 'NONE))))]
@section{Auxiliary values} ♦section{Auxiliary values}
The following sections reuse a few values which are derived from the list of The following sections reuse a few values which are derived from the list of
fields: fields:
@CHUNK[<utils> ♦CHUNK[<utils>
(define all-fields #'(field …)) (define all-fields #'(field …))
(define depth-above (ceiling-log2 (length (syntax->list #'(field …))))) (define depth-above (ceiling-log2 (length (syntax->list #'(field …)))))
(define offset (expt 2 depth-above)) (define offset (expt 2 depth-above))
@ -157,9 +157,9 @@ fields:
(stx-map (λ (f) (format-id f "u-with-~a" f)) (stx-map (λ (f) (format-id f "u-with-~a" f))
#'(field …)))))] #'(field …)))))]
@section{Type of a tree-record} ♦section{Type of a tree-record}
@CHUNK[<τ-tree-with-fields> ♦CHUNK[<τ-tree-with-fields>
(define-for-syntax (τ-tree-with-fields struct-fields fields) (define-for-syntax (τ-tree-with-fields struct-fields fields)
(define/with-syntax (struct-field …) struct-fields) (define/with-syntax (struct-field …) struct-fields)
(define/with-syntax (field …) fields) (define/with-syntax (field …) fields)
@ -171,7 +171,7 @@ fields:
[i (in-naturals)]) [i (in-naturals)])
(cons n (+ i offset))))) (cons n (+ i offset)))))
(define fields+indices (define fields+indices
(sort (stx-map #λ(cons % (free-id-table-ref lookup %)) (sort (stx-map λ.(cons % (free-id-table-ref lookup %))
#'(struct-field …)) #'(struct-field …))
< <
#:key cdr)) #:key cdr))
@ -192,9 +192,9 @@ fields:
,(f (add1 (* i 2)))))))) ,(f (add1 (* i 2))))))))
(f 1))] (f 1))]
@section{Conversion to and from record-trees} ♦section{Conversion to and from record-trees}
@CHUNK[<define-struct↔tree> ♦CHUNK[<define-struct↔tree>
(define-for-syntax (define-struct↔tree (define-for-syntax (define-struct↔tree
offset all-fields τ* struct-name fields) offset all-fields τ* struct-name fields)
(define/with-syntax (field …) fields) (define/with-syntax (field …) fields)
@ -208,7 +208,7 @@ fields:
[i (in-naturals)]) [i (in-naturals)])
(cons n (+ i offset))))) (cons n (+ i offset)))))
(define fields+indices (define fields+indices
(sort (stx-map #λ(cons % (free-id-table-ref lookup %)) (sort (stx-map λ.(cons % (free-id-table-ref lookup %))
fields) fields)
< <
#:key cdr)) #:key cdr))
@ -229,9 +229,9 @@ fields:
(define tree (force tree-thunk)) (define tree (force tree-thunk))
#,(convert-back-fields (* offset 2) fields+indices))))] #,(convert-back-fields (* offset 2) fields+indices))))]
@subsection{Creating a new tree-record} ♦subsection{Creating a new tree-record}
@CHUNK[<convert-fields> ♦CHUNK[<convert-fields>
(define-for-syntax (convert-fields up fields+indices) (define-for-syntax (convert-fields up fields+indices)
;(displayln fields+indices) ;(displayln fields+indices)
(define (f i) (define (f i)
@ -248,12 +248,12 @@ fields:
(f 1))] (f 1))]
@subsection{Extracting all the fields from a tree-record} ♦subsection{Extracting all the fields from a tree-record}
We traverse the tree in preorder, and accumulate definitions naming the We traverse the tree in preorder, and accumulate definitions naming the
interesting subparts of the trees (those where there are fields). interesting subparts of the trees (those where there are fields).
@CHUNK[<convert-back-fields> ♦CHUNK[<convert-back-fields>
(define-for-syntax (convert-back-fields up fields+indices) (define-for-syntax (convert-back-fields up fields+indices)
(define result '()) (define result '())
(define definitions '()) (define definitions '())
@ -292,20 +292,20 @@ interesting subparts of the trees (those where there are fields).
(f 1 #'tree) (f 1 #'tree)
#`(begin #,@definitions (values . #,(reverse result))))] #`(begin #,@definitions (values . #,(reverse result))))]
@section{Defining the converters and accessors for each known record type} ♦section{Defining the converters and accessors for each known record type}
@CHUNK[<define-trees> ♦CHUNK[<define-trees>
(define-for-syntax (define-trees stx) (define-for-syntax (define-trees stx)
(syntax-case stx () (syntax-case stx ()
[(bt-fields-id (field …) [struct struct-field …] …) [(bt-fields-id (field …) [struct struct-field …] …)
(let () (let ()
<utils> <utils>
(define ∀-types (map #λ(format-id #'here "τ~a" %) (define ∀-types (map λ.(format-id #'here "τ~a" %)
(range (add1 depth-above)))) (range (add1 depth-above))))
(define total-nb-functions (vector-length names)) (define total-nb-functions (vector-length names))
<define-trees-result>)]))] <define-trees-result>)]))]
@CHUNK[<bt-fields-type> ♦CHUNK[<bt-fields-type>
(define-for-syntax (bt-fields-type fields) (define-for-syntax (bt-fields-type fields)
(λ (stx) (λ (stx)
(syntax-case stx () (syntax-case stx ()
@ -313,27 +313,27 @@ interesting subparts of the trees (those where there are fields).
#`(∀ fs (Promise #,(τ-tree-with-fields #'fs #`(∀ fs (Promise #,(τ-tree-with-fields #'fs
fields)))])))] fields)))])))]
@CHUNK[<define-trees-result> ♦CHUNK[<define-trees-result>
#`(begin #`(begin
(define-type-expander bt-fields-id (define-type-expander bt-fields-id
(bt-fields-type #'#,(syntax-local-introduce #'(field …)))) (bt-fields-type #'#,(syntax-local-introduce #'(field …))))
#,@(map #λ(define-replace-in-tree low-names #,@(map λ.(define-replace-in-tree low-names
names rm-names ∀-types % (floor-log2 %)) names rm-names ∀-types % (floor-log2 %))
(range 1 (add1 total-nb-functions))) (range 1 (add1 total-nb-functions)))
#;#,@(map #λ(define-remove-in-tree rm-names ∀-types % (floor-log2 %)) #;#,@(map λ.(define-remove-in-tree rm-names ∀-types % (floor-log2 %))
(range 1 (add1 total-nb-functions))) (range 1 (add1 total-nb-functions)))
#,@(map #λ(define-struct↔tree #,@(map λ.(define-struct↔tree
offset all-fields ∀-types %1 %2) offset all-fields ∀-types %1 %2)
(syntax->list #'(struct …)) (syntax->list #'(struct …))
(syntax->list #'([struct-field …] …))))] (syntax->list #'([struct-field …] …))))]
@subsection{Putting it all together} ♦subsection{Putting it all together}
@chunk[<maybe> ♦chunk[<maybe>
(struct (T) Some ([v : T]) #:transparent) (struct (T) Some ([v : T]) #:transparent)
(define-type (Maybe T) (U (Some T) 'NONE))] (define-type (Maybe T) (U (Some T) 'NONE))]
@chunk[<*> ♦chunk[<*>
(require delay-pure (require delay-pure
"flexible-with-utils.hl.rkt" "flexible-with-utils.hl.rkt"
(for-syntax (rename-in racket/base [... …]) (for-syntax (rename-in racket/base [... …])
@ -363,4 +363,4 @@ interesting subparts of the trees (those where there are fields).
<define-trees> <define-trees>
<bt-fields-type>] <bt-fields-type>]
@include-section[(submod "flexible-with-utils.hl.rkt" doc)] ♦include-section[(submod "flexible-with-utils.hl.rkt" doc)]

3
test/invariant-phantom/simple.rkt
View File

@ -140,4 +140,5 @@
(:a ≡ :a.f.h) (:a ≡ :a.f.h)
(:a ∉ :a.f.g)) (:a ∉ :a.f.g))
(Invariants (:a.l ≥ (+ (length :a.f.g) 2)) (Invariants (:a.l ≥ (+ (length :a.f.g) 2))
(:a ≢ :a.f.g.x))) (:a ≢ :a.f.g.0)
(:a ≢ :a.f.g.1)))

16
test/test-flexible-with.rkt
View File

@ -1,4 +1,4 @@
#lang aful/unhygienic type-expander/lang #lang dotlambda/unhygienic type-expander/lang
(require (lib "phc-graph/flexible-with.hl.rkt") (require (lib "phc-graph/flexible-with.hl.rkt")
(for-syntax racket/syntax (for-syntax racket/syntax
@ -43,37 +43,37 @@
(check-equal?: (check-equal?:
(call-with-values (call-with-values
#λ(tree→sab (sab→tree 1 2)) λ.(tree→sab (sab→tree 1 2))
list) list)
'(1 2)) '(1 2))
(check-equal?: (check-equal?:
(call-with-values (call-with-values
#λ(tree→sabc (ann (with-c (sab→tree 1 2) 'nine) λ.(tree→sabc (ann (with-c (sab→tree 1 2) 'nine)
((bt-fields a b c) One Positive-Byte 'nine))) ((bt-fields a b c) One Positive-Byte 'nine)))
list) list)
'(1 2 nine)) '(1 2 nine))
(check-equal?: (check-equal?:
(call-with-values (call-with-values
#λ(tree→sabc (with-c (sab→tree 'NONE 'NONE) 'NONE)) λ.(tree→sabc (with-c (sab→tree 'NONE 'NONE) 'NONE))
list) list)
'(NONE NONE NONE)) '(NONE NONE NONE))
(check-equal?: (check-equal?:
(call-with-values (call-with-values
#λ(tree→sab (without-c (with-c (sab→tree 'NONE 'NONE) 'NONE))) λ.(tree→sab (without-c (with-c (sab→tree 'NONE 'NONE) 'NONE)))
list) list)
'(NONE NONE)) '(NONE NONE))
(check-equal?: (check-equal?:
(call-with-values (call-with-values
#λ(tree→sbc (without-a (with-c (sab→tree 'NONE 'NONE) 'NONE))) λ.(tree→sbc (without-a (with-c (sab→tree 'NONE 'NONE) 'NONE)))
list) list)
'(NONE NONE)) '(NONE NONE))
(check-equal?: (check-equal?:
(call-with-values (call-with-values
#λ(tree→sbc (without-a (with-c (sab→tree 1 2) 3))) λ.(tree→sbc (without-a (with-c (sab→tree 1 2) 3)))
list) list)
'(2 3)) '(2 3))