diff --git a/graph/graph/__DEBUG_graph__.rkt b/graph/graph/__DEBUG_graph__.rkt index b709ba2c..79a8cb51 100644 --- a/graph/graph/__DEBUG_graph__.rkt +++ b/graph/graph/__DEBUG_graph__.rkt @@ -1,5 +1,6 @@ #lang debug typed/racket +#| (require "structure.lp2.rkt") (require "variant.lp2.rkt") (require "../type-expander/type-expander.lp2.rkt") @@ -12,14 +13,23 @@ (tagged t [a : Number 1] [b : Symbol 'b] [c : String "c"]) (tagged t [a 1] [b 'b] [c "c"]) -#| +(tagged t [a 1] [b 'b] [c "c"]) + +(define-tagged tabc t [a 1] [b 'b] [c "c"]) +|# + (require (submod "graph3.lp2.rkt" test)) +(require "structure.lp2.rkt") (require "../lib/low.rkt") (require racket/list) (define #:∀ (A) (map-force [l : (Listof (Promise A))]) (map (inst force A) l)) +(map-force (get g people)) +(map-force (get g streets)) + +#| (let () (map-force (second g)) (cars (map-force (second g))) diff --git a/graph/graph/fold-queues.lp2.rkt b/graph/graph/fold-queues.lp2.rkt index 29103914..919db04b 100644 --- a/graph/graph/fold-queues.lp2.rkt +++ b/graph/graph/fold-queues.lp2.rkt @@ -12,10 +12,10 @@ @chunk[ (fold-queues root-value - [(name [element (~literal :) Element-Type] - [Δ-queues (~literal :) Δ-Queues-Type-Name] + [(name [element :colon Element-Type] + [Δ-queues :colon Δ-Queues-Type-Name] enqueue) - (~literal :) Result-Type + :colon Result-Type . body] … (~parse (root-name . _) #'(name …)))] @@ -279,7 +279,8 @@ added to the @tc[Δ-Hash] since its creation from a simple @tc[HashTable]. racket/syntax racket/pretty; DEBUG "../lib/low-untyped.rkt") - "../lib/low.rkt") + "../lib/low.rkt" + "../type-expander/type-expander.lp2.rkt") (provide fold-queues) diff --git a/graph/graph/graph3.lp2.rkt b/graph/graph/graph3.lp2.rkt index 9e42d7b6..394ddbe9 100644 --- a/graph/graph/graph3.lp2.rkt +++ b/graph/graph/graph3.lp2.rkt @@ -30,7 +30,7 @@ these constructors: @chunk[ [City [streets : (Listof Street)] [people : (Listof Person)] ] - [Street [name : String] [houses : (Listof House)] ] + [Street [sname : String] [houses : (Listof House)] ] [House [owner : Person] [location : Street] ] [Person [name : String] ]] @@ -161,12 +161,12 @@ wrapper macros. Where @tc[] is: @chunk[ - [field:id (~literal :) field-type:expr]] + [field:id :colon field-type:expr]] And @tc[] is: @chunk[ - ((mapping:id [param:id (~literal :) param-type:expr] …) + ((mapping:id [param:id :colon param-type:expr] …) . mapping-body)] @subsection{The different types of a node} @@ -229,7 +229,9 @@ We derive identifiers for these based on the @tc[node] name: (define-temp-ids "~a/mapping-function" (node …)) - (define-temp-ids "~a/database" (node …) #:first-base root)] + (define-temp-ids "~a/database" (node …) #:first-base root) + + (define-temp-ids "~a/value" ((field …) …))] @subsection{Overview} @@ -372,13 +374,15 @@ that node's @tc[with-promises] type. … (define-type node/with-promises-type - (List 'node/with-promises-tag - field/with-promises-type …)) + (tagged node/with-promises-tag + [field : field/with-promises-type] …)) (: node/make-with-promises (→ field/with-promises-type … node/with-promises-type)) - (define (node/make-with-promises field …) - (list 'node/with-promises-tag field …))] + (define (node/make-with-promises field/value …) + (tagged node/with-promises-tag + [field : field/with-promises-type field/value] + …))] @subsection{Making incomplete nodes} @@ -616,7 +620,10 @@ are replaced by tagged indices: alexis/util/threading; DEBUG "fold-queues.lp2.rkt" "rewrite-type.lp2.rkt" - "../lib/low.rkt") + "../lib/low.rkt" + "structure.lp2.rkt" + "variant.lp2.rkt" + "../type-expander/type-expander.lp2.rkt") ;(begin-for-syntax ;) @@ -624,12 +631,20 @@ are replaced by tagged indices: (provide define-graph) )] +In @tc[module-test], we have to require @tc[type-expander] because it provides a +@tc[:] macro which is a different identifier than the one from typed/racket, +therefore the @tc[:] bound in the @tc[graph] macro with @tc[:colon] would +not match the one from @tc[typed/racket] + @chunk[ (module* test typed/racket (require (submod "..") "fold-queues.lp2.rkt"; DEBUG "rewrite-type.lp2.rkt"; DEBUG "../lib/low.rkt"; DEBUG + "structure.lp2.rkt"; DEBUG + "variant.lp2.rkt"; DEBUG + "../type-expander/type-expander.lp2.rkt" typed/rackunit) (provide g) diff --git a/graph/graph/remember.rkt b/graph/graph/remember.rkt index 61d92eb5..8d84678a 100644 --- a/graph/graph/remember.rkt +++ b/graph/graph/remember.rkt @@ -39,4 +39,19 @@ (structure fba fbv) (structure fav) (structure a) -(structure a) \ No newline at end of file +(structure a) +(structure people/with-promises-type streets/with-promises-type) +(structure houses/with-promises-type name/with-promises-type) +(structure location/with-promises-type owner/with-promises-type) +(structure name/with-promises-type) +(structure people streets) +(structure people streets) +(structure houses name) +(structure houses name) +(structure location owner) +(structure location owner) +(structure name) +(structure name) +(structure houses/with-promises-type sname/with-promises-type) +(structure houses sname) +(structure houses sname) diff --git a/graph/graph/structure.lp2.rkt b/graph/graph/structure.lp2.rkt index 74b4378d..58663f9d 100644 --- a/graph/graph/structure.lp2.rkt +++ b/graph/graph/structure.lp2.rkt @@ -103,21 +103,29 @@ handle the empty structure as a special case. @chunk[ (define-syntax (define-structure stx) (syntax-parse stx - [(_ name [field type] ...) + [(_ name [field type] ... (~maybe #:? name?)) (define/with-syntax ([sorted-field sorted-type] ...) (sort-car-fields #'([field type] ...))) (define/with-syntax (pat ...) (generate-temporaries #'(field ...))) - #'(define-multi-id name - #:type-expand-once - (structure [field type] ...) - #:match-expander - (λ (stx2) - (syntax-case stx2 () - [(_ pat ...) #'(structure [field pat] ...)])) - #:else - (if (not (stx-null? #'(type …))) - #'(inst (make-structure-constructor field ...) type ...) - #'(make-structure-constructor field ...)))]))] + (define/with-syntax default-name? (format-id #'name "~a?" #'name)) + (template + (begin + (define-multi-id name + #:type-expand-once + (structure [field type] ...) + #:match-expander + (λ (stx2) + (syntax-case stx2 () + [(_ pat ...) #'(structure [field pat] ...)])) + #:else + (if (not (stx-null? #'(type …))) + #'(inst (make-structure-constructor field ...) type ...) + #'(make-structure-constructor field ...))) + (: (?? name? default-name?) (→ Any Any)) + (define ((?? name? default-name?) x) + (match x + [(structure [field _] …) #t] + [_ #f]))))]))] @chunk[ @@ -135,10 +143,10 @@ Test constructor: Test constructor, as id: @chunk[ - (check-equal?: (get (cadr (map st '(1 2 3) '("x" "y" "z"))) b) - : String "y") - (check-equal?: (get (cadr (map st2 '("d" "e" "f") '(1 2 3))) b) - : String "e")] + (check-equal?: (get (cadr (map st '(1 2 3) '("x" "y" "z"))) b) : String + "y") + (check-equal?: (get (cadr (map st2 '("d" "e" "f") '(1 2 3))) b) : String + "e")] Test the type-expander: @@ -293,21 +301,44 @@ The fields in @tc[fields→stx-name-alist] are already sorted. @subsection{Accessor} @CHUNK[ - (define-syntax/parse (get v field:id) - (define structs (filter (λ (s) - (member (syntax->datum #'field) (car s))) - fields→stx-name-alist)) - (define/with-syntax (name? ...) - (map (λ (s) ) structs)) - (define/with-syntax (name-field ...) - (map (λ (s) ) structs)) - #`(let ([v-cache v]) - (cond - [(name? v-cache) - (let ([accessor name-field]) - (accessor v-cache))]; cover does not see the call otherwise? - ... - [else (typecheck-fail #,stx #:covered-id v-cache)])))] + (define-syntax (get stx) + (syntax-parse stx + [(_ v field:id) + (define struct-names + (filter (λ (s) + (member (syntax->datum #'field) (car s))) + fields→stx-name-alist)) + (define/with-syntax (name? ...) + (map (λ (s) ) struct-names)) + (define/with-syntax (name-field ...) + (map (λ (s) ) struct-names)) + #`(let ([v-cache v]) + (cond + [(name? v-cache) + (let ([accessor name-field]) + (accessor v-cache))]; cover doesn't see the call otherwise? + … + ;; For variants: + ;; If we hit the bug where refinements cause loss of precision + ;; in later clauses, then just use separate functions, forming + ;; a BTD: + ;; (λ ([x : (U A1 A2 A3 B1 B2 B3)]) (if (A? x) (fa x) (fb x))) + [(and (pair? v-cache) + (symbol? (car v-cache)) + (null? (cddr v-cache)) + (name? (cadr v-cache))) + (let ([accessor name-field]) + (accessor (cadr v-cache)))] + … + [else (typecheck-fail #,stx #:covered-id v-cache)]))] + [(_ field:id) + (define/with-syntax (struct-name …) + (filter (λ (s) + (member (syntax->datum #'field) (car s))) + fields→stx-name-alist)) + #'(λ ([v : (U struct-name … + (List Symbol struct-name) …)]) + (get v field))]))] @chunk[ (my-st-type-info-predicate (get-struct-info stx (cdr s)))] @@ -418,7 +449,7 @@ instead of needing an extra recompilation. (sort-fields #'(field …))) (fields→stx-name #'(field …))) (remember-all-errors #'U stx #'(field ...)))] - [(_ (~seq [field:id type:expr] …)) + [(_ (~seq [field:id (~optional :colon) type:expr] …)) (if (check-remember-fields #'(field ...)) (let () (define/with-syntax ([sorted-field sorted-type] ...) diff --git a/graph/graph/variant.lp2.rkt b/graph/graph/variant.lp2.rkt index f83c4336..21902828 100644 --- a/graph/graph/variant.lp2.rkt +++ b/graph/graph/variant.lp2.rkt @@ -78,8 +78,20 @@ twice, and it is likely that a constructor will have the same identifier as an existing variable or function. @chunk[ - (define-syntax/parse (define-variant name [tag:id type:expr ...] ...) - #'(define-type name (U (constructor tag type ...) ...)))] + (define-syntax/parse (define-variant name [tag:id type:expr ...] ... + (~maybe #:? name?)) + (define/with-syntax default-name? (format-id #'name "~a?" #'name)) + (define-temp-ids "pat" ((type …) …)) + (template + (begin + (define-type name (U (constructor tag type ...) ...)) + ;; TODO: for now, we don't check properly, it could be any list with + ;; that symbol as the first element. + (define ((?? name? default-name?) [x : Any]) + (match x + [(constructor tag pat …) #t] + … + [_ #f])))))] @chunk[ (define-variant v1 [x Number String] [y String Number] [z Number String]) @@ -161,18 +173,27 @@ number of name collisions. @chunk[ (define-syntax/parse (define-tagged tag:id [field type] ... - (~optional #:type-noexpand)) + (~optional #:type-noexpand) + (~maybe #:? tag?)) (define/with-syntax (pat ...) (generate-temporaries #'(field ...))) (define/with-syntax (value ...) (generate-temporaries #'(field ...))) - #'(define-multi-id tag - #:type-expand-once - (tagged tag [field type] ...) - #:match-expander - (λ/syntax-parse (_ pat ...) - #'(tagged tag [field pat] ...)) - #:call - (λ/syntax-parse (_ value ...) - #'(tagged tag #:instance [field value] ...))))] + (define/with-syntax default-tag? (format-id #'tag "~a?" #'tag)) + (template + (begin + (define-multi-id tag + #:type-expand-once + (tagged tag [field type] ...) + #:match-expander + (λ/syntax-parse (_ pat ...) + #'(tagged tag [field pat] ...)) + #:call + (λ/syntax-parse (_ value ...) + #'(tagged tag #:instance [field value] ...))) + (: (?? tag? default-tag?) (→ Any Any)) + (define ((?? tag? default-tag?) x) + (match x + [(tagged tag [field _] …) #t] + [_ #f])))))] @chunk[ (define-tagged tagged-s1) @@ -248,6 +269,7 @@ number of name collisions. (begin (module main typed/racket (require (for-syntax syntax/parse + syntax/parse/experimental/template racket/syntax "../lib/low-untyped.rkt") "../lib/low.rkt" diff --git a/graph/lib/low.rkt b/graph/lib/low.rkt index 534baeb7..cdfb7e56 100644 --- a/graph/lib/low.rkt +++ b/graph/lib/low.rkt @@ -746,7 +746,6 @@ [(_ format:simple-format base:dotted - (~optional (~seq #:first-base first-base)) (~optional (~seq #:first first))) (let* ([base-len (string-length (symbol->string (syntax-e #'base.id)))]) (define/with-syntax pat @@ -790,14 +789,33 @@ (syntax-local-introduce #'format) (attribute format.right-start) (attribute format.right-len)) - '()))) - )] - [(_ format (base:id (~literal ...))) + '()))))] + [(_ format base:dotted) #:when (string? (syntax-e #'format)) - (with-syntax ([pat (format-id #'base (syntax-e #'format) #'base)]) - #'(define/with-syntax (pat (... ...)) - (format-temp-ids format #'(base (... ...)))))] - [(_ name:expr format:expr . vs) + #:when (regexp-match #rx"^[^~]*$" (syntax-e #'format)) + (define/with-syntax pat (format-id #'base (syntax-e #'format))) + (define/with-syntax pat-dotted ((attribute base.make-dotted) #'pat)) + (define/with-syntax format-temp-ids* + ((attribute base.wrap) #'(λ (x) + (car (format-temp-ids + (string-append format "~a") + ""))) + (λ (x deepest?) + (if deepest? + x + #`(curry stx-map #,x))))) + (syntax-cons-property + #'(define/with-syntax pat-dotted + (format-temp-ids* #'base)) + 'sub-range-binders + (list (vector (syntax-local-introduce #'pat) + 0 + (string-length (syntax-e #'format)) + + (syntax-local-introduce #'format) + 1 + (string-length (syntax-e #'format)))))] + [(_ name:id format:expr . vs) #`(define/with-syntax name (format-temp-ids format . vs))]))) (module+ test diff --git a/graph/type-expander/type-expander.lp2.rkt b/graph/type-expander/type-expander.lp2.rkt index 3459cbf0..2f6ce2fa 100644 --- a/graph/type-expander/type-expander.lp2.rkt +++ b/graph/type-expander/type-expander.lp2.rkt @@ -305,7 +305,7 @@ them. @CHUNK[ (define-syntax-class colon - (pattern (~literal new-:))) + (pattern (~or (~literal new-:) (~literal :)))) (define-splicing-syntax-class (new-maybe-kw-type-vars) #:attributes (vars maybe) @@ -1012,7 +1012,9 @@ We can finally define the overloaded forms, as well as the extra (begin-for-syntax - ) + + + (provide colon))