diff --git a/graph/graph/__DEBUG_graph__.rkt b/graph/graph/__DEBUG_graph__.rkt index a77cac58..7b0111fb 100644 --- a/graph/graph/__DEBUG_graph__.rkt +++ b/graph/graph/__DEBUG_graph__.rkt @@ -1,9 +1,12 @@ #lang debug typed/racket -(require "structure.lp2.rkt") -(require "../type-expander/type-expander.lp2.rkt") +;(require "structure.lp2.rkt") +;(require "variant.lp2.rkt") +;(require "../type-expander/type-expander.lp2.rkt") (require "../lib/low.rkt") +#| + (define-structure st [a Number] [b String]) (check-equal:? (st 1 "b") (structure [a 1] [b "b"])) (check-equal:? (st 1 "b") (structure [a : Number 1] [b : String "b"])) @@ -12,6 +15,12 @@ (check-equal:? (st 1 "b") ((structure a b) 1 "b")) (check-equal:? (st 1 "b") ((structure [a] b) 1 "b")) +((tagged t a b c) 1 'b "c") +((tagged t a [b] c) 1 'b "c") +((tagged t [a] [b] [c]) 1 'b "c") +((tagged t [a : Number] [b : Symbol] [c : String]) 1 'b "c") +(tagged t [a : Number 1] [b : Symbol 'b] [c : String "c"]) +(tagged t [a 1] [b 'b] [c "c"]) #| (require (submod "graph3.lp2.rkt" test)) @@ -49,4 +58,5 @@ (forceall 5 g) +|# |# \ No newline at end of file diff --git a/graph/graph/remember.rkt b/graph/graph/remember.rkt index 3807ba91..61d92eb5 100644 --- a/graph/graph/remember.rkt +++ b/graph/graph/remember.rkt @@ -39,4 +39,4 @@ (structure fba fbv) (structure fav) (structure a) -(structure a) +(structure a) \ No newline at end of file diff --git a/graph/graph/structure.lp2.rkt b/graph/graph/structure.lp2.rkt index 3ff518ea..fe25d04b 100644 --- a/graph/graph/structure.lp2.rkt +++ b/graph/graph/structure.lp2.rkt @@ -28,62 +28,51 @@ types, it wouldn't be clear what fields the remaining type parameters affect). (~or field:id [field:id (~maybe (~lit :) type:expr) (~maybe value:expr)]))))} +A call to @tc[(structure)] with no field, is ambiguous: it could return a +constructor function, or an instance. We added two optional keywords, +@tc[#:instance] and @tc[#:constructor], to disambiguate. They can also be used +when fields with or without values are provided, so that macros don't need to +handle the empty structure as a special case. + +@chunk[ + (define-splicing-syntax-class structure-args-stx-class + (pattern + (~or (~seq #:instance (~parse (field … value …) #'())) + (~seq #:constructor (~parse (field …) #'())) + (~seq (~maybe #:constructor ~!) + (~or (~seq (~or-bug [field:id] field:id) …+) + (~seq [field:id (~and C (~lit :)) type:expr] …+))) + (~seq (~maybe #:instance ~!) + (~or (~seq [field:id value:expr] …+) + (~seq [field:id (~and C (~lit :)) type:expr + value:expr] …+))))))] + @chunk[ + (begin-for-syntax ) + (define-multi-id structure #:type-expander structure-type-expander #:match-expander structure-match-expander - #:call (λ (stx) - (syntax-parse stx - [(_) ] - [(_ (~or (~seq (~or-bug [field:id] field:id) …) - (~seq [field:id (~lit :) type:expr] …) - (~seq [field:id value:expr] …) - (~seq [field:id (~lit :) type:expr value:expr] …))) - (define/with-syntax c - #'(make-structure-constructor field …)) - (define/with-syntax ct - (if (and (attribute type) (not (stx-null? #'(type …)))) - #'(inst c type …) - #'c)) - (template (?? (ct value …) ct))])))] - -@subsection[#:tag "structure|hybrid-empty"]{Hybrid constructor / instance for - the empty structure} - -A call to @tc[(structure)] with no field, is ambiguous: it could return a -constructor function, or an instance. We use @tc[define-struct/exec] to make it -behave like both. - -@CHUNK[ - (struct empty/noexec-type ()) - - (define-struct/exec (empty/exec-type empty) - () - [(λ _ empty-instance) : (→ Any empty)]) - - (define empty-instance (empty/exec-type))] - -@CHUNK[ - (check-equal:? empty-instance : empty empty-instance) - (check-equal:? empty-instance : empty (empty-instance)) - (check-equal:? (empty-instance) : empty empty-instance) - (check-equal:? (empty-instance) : empty (empty-instance))] - -@CHUNK[ - (check-equal:? (structure) (structure)) - (check-equal:? (structure) ((structure))) - (check-equal:? ((structure)) (structure)) - (check-equal:? ((structure)) ((structure)))] + #:call + (λ (stx) + (syntax-parse stx + [(_ :structure-args-stx-class) + (define/with-syntax c #'(make-structure-constructor field …)) + (define/with-syntax ct (template (?? (inst c type …) c))) + (syntax-property + (template (?? (ct value …) ct)) + 'disappeared-use (stx-map syntax-local-introduce + (template ((?? (?@ (C …)))))))])))] @chunk[ (let () (define-structure empty-st) (define-structure stA [a Number]) - (check-equal:? (empty-st) ((structure))) + (check-equal:? (empty-st) ((structure #:constructor))) (check-not-equal:? (empty-st) (structure [a 1])) - (check-not-equal:? (structure) (structure [a 1])) + (check-not-equal:? (structure #:constructor) (structure [a 1])) (check-not-equal:? (empty-st) (stA 1)) - (check-not-equal:? (structure) (stA 1))) + (check-not-equal:? (structure #:constructor) (stA 1))) #;(let () (define-structure st [a Number] [b String]) (define-structure stA [a Number]) @@ -247,18 +236,10 @@ one low-level @tc[struct] is generated for them. @CHUNK[ (define-for-syntax named-sorted-structures (for/list ([s (remove-duplicates (map (λ (s) (sort s symbol))] + (get-remembered 'structure)))] [i (in-naturals)]) `(,(string->symbol (format "struct-~a" i)) . ,s)))] -We add the empty struct (with no fields) to the list of remembered structs as a -special case, because we need it to define the hybrid instance/constructor in -section @secref{structure|hybrid-empty}. - -@chunk[ - (cons '() - (get-remembered 'structure))] - We will also need utility functions to sort the fields when querying this associative list. @@ -306,9 +287,8 @@ should succeed. (let () (define/with-syntax (sorted-field ...) (sort-fields #'(field ...))) - (define/with-syntax (TTemp ...) - (generate-temporaries #'(field ...))) - #`(λ #:∀ (TTemp ...) ([field : TTemp] ...) + (define-temp-ids "~a/TTemp" (field …)) + #`(λ #:∀ (field/TTemp …) ([field : field/TTemp] …) (#,(fields→stx-name #'(field ...)) sorted-field ...))) (remember-all-errors #'list stx #'(field ...))))] @@ -443,13 +423,20 @@ instead of needing an extra recompilation. @CHUNK[ (define-for-syntax (structure-type-expander stx) (syntax-parse stx - [(_ [field type] ...) + [(_ (~or-bug [field:id] field:id) …) + (if (check-remember-fields #'(field ...)) + (let () + (define/with-syntax (sorted-field …) + (sort-fields #'(field …))) + (fields→stx-name #'(field …))) + (remember-all-errors #'U stx #'(field ...)))] + [(_ (~seq [field:id type:expr] …)) (if (check-remember-fields #'(field ...)) (let () (define/with-syntax ([sorted-field sorted-type] ...) (sort-car-fields #'((field type) ...))) (if (stx-null? #'(sorted-type ...)) - (fields→stx-name #'(field …)) ; #'(field …) is empty here. + (fields→stx-name #'()) ; #'(field …) is empty here. #`(#,(fields→stx-name #'(field ...)) sorted-type ...))) (remember-all-errors #'U stx #'(field ...)))]))] @@ -549,6 +536,9 @@ chances that we could write a definition for that identifier. get structure) + (begin-for-syntax + (provide structure-args-stx-class)) + @@ -558,9 +548,6 @@ chances that we could write a definition for that identifier. - - (require typed/rackunit) - @@ -590,7 +577,6 @@ chances that we could write a definition for that identifier. - (require (submod ".." doc))))] diff --git a/graph/graph/variant.lp2.rkt b/graph/graph/variant.lp2.rkt index 9661a6cf..1dc488a2 100644 --- a/graph/graph/variant.lp2.rkt +++ b/graph/graph/variant.lp2.rkt @@ -117,10 +117,34 @@ number of name collisions. (λ/syntax-parse (_ tag:id . structure-pat) #`(constructor tag #,(syntax/loc #'structure-pat (structure . structure-pat)))) - #:call - (λ/syntax-parse (_ tag:id . structure-field-value) - #`(constructor tag #,(syntax/loc #'structure-field-value - (structure . structure-field-value)))))] + #:call ;; TODO: clean this up a bit, and explain it. + (λ/syntax-parse + (~and (_ (~and (~seq disambiguate …) (~or (~seq #:instance) + (~seq #:constructor) + (~seq))) + tag:id . fields) + (~parse (sa:structure-args-stx-class) + #'(disambiguate … . fields))) + (define-temp-ids "~a/TTemp" (sa.field …)) + (define/with-syntax c + (if (attribute sa.type) + #`(λ ([sa.field : sa.type] …) + : (constructor tag #,(syntax/loc #'fields + (structure [sa.field sa.type] …))) + (constructor tag + #,(syntax/loc #'fields + (structure #:instance + [sa.field : sa.type sa.field] …)))) + #`(λ #:∀ (sa.field/TTemp …) ([sa.field : sa.field/TTemp] …) + : (constructor tag #,(syntax/loc #'fields + (structure [sa.field sa.field/TTemp] …))) + (constructor tag + #,(syntax/loc #'fields + (structure #:instance + [sa.field sa.field] …)))))) + (if (attribute sa.value) + #'(c sa.value …) + #'c)))] @chunk[ (check-equal? (match (ann (tagged foo [x "o"] [y 3] [z 'z]) @@ -146,7 +170,7 @@ number of name collisions. #'(tagged tag [field pat] ...)) #:call (λ/syntax-parse (_ value ...) - #'(tagged tag [field value] ...))))] + #'(tagged tag #:instance [field value] ...))))] @chunk[ (define-tagged tagged-s1) diff --git a/graph/lib/low.rkt b/graph/lib/low.rkt index 64fb6d9d..0a4a11f4 100644 --- a/graph/lib/low.rkt +++ b/graph/lib/low.rkt @@ -10,11 +10,19 @@ (provide half-typed-module typed/untyped-prefix define-modules) ;; half-typed-module -(define-syntax-rule (typed-module m typed-language untyped-language . body) - (module m typed-language . body)) +(define-syntax-rule (typed-module m t u typed-language untyped-language . body) + (begin + (module m typed-language + (module t typed-language . body) + (module u untyped-language . body) + . body))) -(define-syntax-rule (untyped-module m typed-language untyped-language . body) - (module m untyped-language . body)) +(define-syntax-rule (untyped-module m u typed-language untyped-language . body) + (begin + (module m untyped-language + (module t typed-language . body) + (module u untyped-language . body) + . body))) (define-typed/untyped-identifier half-typed-module typed-module untyped-module) @@ -92,74 +100,76 @@ (check-equal? require-provide-foo 7)) ;; ==== low/syntax-parse.rkt ==== -(require syntax/parse - syntax/parse/define - (for-syntax racket/syntax)) -(provide define-syntax/parse - λ/syntax-parse - ~maybe - ~lit - ~or-bug) - -(define-syntax ~maybe - (pattern-expander - (λ (stx) - (syntax-case stx () - [(~maybe pat ...) - (datum->syntax #'~maybe - #'(~optional (~seq pat ...)))])))) - -;; Circumvent the bug that causes "syntax-parse: duplicate attribute in: a" in: -;; (syntax-parse #'(x y z) [((~or a (a b c)) ...) #'(a ...)]) -(define-syntax ~or-bug - (pattern-expander - (λ (stx) - (syntax-case stx () - [(~or-bug pat ...) - (let () - (define (s stx) (datum->syntax #'~or-bug stx)) - ;(define/with-syntax ~~and (datum->syntax #'~or-bug #'~and)) - ;(define/with-syntax ~~parse (datum->syntax #'~or-bug #'~parse)) - ;(define/with-syntax ~~or (datum->syntax #'~or-bug #'~parse)) - #;#'(~~and x (~~parse (~~or pat ...) #'x)) - #`(#,(s #'~and) x (#,(s #'~parse) #,(s #'(~or pat ...)) #'x)) - )])))) - -(define-syntax ~lit - (pattern-expander - (λ (stx) - (syntax-case stx () - [(~lit lit) - (datum->syntax #'~lit - #'(~literal lit))] - [(~lit lit …) - (datum->syntax #'lit - #'(~seq (~literal lit)))])))) - -(begin-for-syntax - (require (for-syntax racket/base - racket/stxparam) - racket/stxparam) +(define-modules ([no-submodule] + [syntax-parse-extensions-untyped typed/racket/no-check]) + (require syntax/parse + syntax/parse/define + (for-syntax racket/base + racket/syntax)) - (provide stx) + (provide define-syntax/parse + λ/syntax-parse + ~maybe + ~lit + ~or-bug) - (define-syntax-parameter stx - (lambda (stx) - (raise-syntax-error (syntax-e stx) - "Can only be used in define-syntax/parse")))) - -(define-simple-macro (define-syntax/parse (name . args) . body) - (define-syntax (name stx2) - (syntax-parameterize ([stx (make-rename-transformer #'stx2)]) - (syntax-parse stx2 - [(_ . args) . body])))) - -(define-simple-macro (λ/syntax-parse args . body) - (λ (stx2) - ;(syntax-parameterize ([stx (make-rename-transformer #'stx2)]) - (syntax-parse stx2 - [args . body])));) + (define-syntax ~maybe + (pattern-expander + (λ (stx) + (syntax-parse stx + [(self pat ...) + (define (s stx) (datum->syntax #'self stx stx stx)) + #`(#,(s #'~optional) (#,(s #'~seq) pat ...))])))) + + ;; Circumvent the bug that causes "syntax-parse: duplicate attribute in: a" in + ;; (syntax-parse #'(x y z) [((~or a (a b c)) ...) #'(a ...)]) + (define-syntax ~or-bug + (pattern-expander + (λ (stx) + (syntax-parse stx + [(self pat ...) + (define (s stx) (datum->syntax #'self stx stx stx)) + #`(#,(s #'~and) x (#,(s #'~parse) (#,(s #'~or) pat ...) #'x))])))) + + (define-syntax ~lit + (pattern-expander + (λ (stx) + (syntax-parse stx + [(self (~optional (~seq name:id (~literal ~))) lit) + (define (s stx) (datum->syntax #'self stx stx stx)) + (if (attribute name) + #`(#,(s #'~and) name (#,(s #'~literal) lit)) + #`(#,(s #'~literal) lit))] + [(self (~optional (~seq name:id (~literal ~))) lit …) + (define (s stx) (datum->syntax #'self stx stx stx)) + (if (attribute name) + #`(#,(s #'~and) name (#,(s #'~seq) (#,(s #'~literal) lit))) + #`(#,(s #'~seq) (#,(s #'~literal) lit)))])))) + + (begin-for-syntax + (require (for-syntax racket/base + racket/stxparam) + racket/stxparam) + + (provide stx) + + (define-syntax-parameter stx + (lambda (stx) + (raise-syntax-error (syntax-e stx) + "Can only be used in define-syntax/parse")))) + + (define-simple-macro (define-syntax/parse (name . args) body0 . body) + (define-syntax (name stx2) + (syntax-parameterize ([stx (make-rename-transformer #'stx2)]) + (syntax-parse stx2 + [(_ . args) body0 . body])))) + + (define-simple-macro (λ/syntax-parse args . body) + (λ (stx2) + ;(syntax-parameterize ([stx (make-rename-transformer #'stx2)]) + (syntax-parse stx2 + [args . body])))) ;; If you include this as a file, you need to do: ;(begin-for-syntax (provide stx)) @@ -220,6 +230,7 @@ sixth-value seventh-value eighth-value ninth-value tenth-value ∘ … + …+ stx-list stx-e stx-pair @@ -240,7 +251,9 @@ (require (only-in racket [compose ∘] - [... …])) + [... …]) + (only-in syntax/parse + [...+ …+])) (require (for-syntax syntax/parse syntax/parse/experimental/template)) @@ -437,7 +450,7 @@ ([x : (Listof Number) (in-heads '(1 2 3 4 5))]) x) '((1) (1 2) (1 2 3) (1 2 3 4) (1 2 3 4 5)))) -;; Can't write the type of on-split, because typed/racket doesn't allow writing +;; Can't write the type of in-split, because typed/racket doesn't allow writing ;; (Sequenceof A B), just (Sequenceof A). ;; in-parallel's type has access to the multi-valued version of Sequenceof, ;; though, so we let typed/racket propagate the inferred type. @@ -998,4 +1011,186 @@ [(_ expr )])) |# +;; ==== low/repeat-stx.rkt === + +(define-modules ([no-submodule] [repeat-stx-untyped typed/racket/no-check]) + (require syntax/stx + (for-syntax racket/base + racket/syntax + syntax/parse)) + + (provide repeat-stx) + + (define-for-syntax (repeat-stx-2 stx) + (syntax-parse stx + [(a:id b:id) + #'(λ _ a)] + [(a:id (b:expr (~literal ...))) + #`(λ (bs) (stx-map #,(repeat-stx-2 #'(a b)) bs))])) + + (define-for-syntax (repeat-stx-1 stx) + (syntax-parse stx + [(a:id b:expr) + #`(λ (a bs) (#,(repeat-stx-2 #'(a b)) bs))] + [((a:expr (~literal ...)) (b:expr (~literal ...))) + #`(λ (s1 s2) (stx-map #,(repeat-stx-1 #'(a b)) s1 s2))])) + + (define-syntax (repeat-stx stx) + (syntax-parse stx + [(_ a:expr b:expr) + #`(#,(repeat-stx-1 #'(a b)) #'a #'b)]))) + +(module repeat-stx-test racket + (require (submod ".." repeat-stx-untyped)) + (require syntax/parse + rackunit) + + (check-equal? + (syntax-parse #'(1 2) + [(a b) + (syntax->datum + (datum->syntax + #'dummy + (repeat-stx a b)))]) + 1) + + (check-equal? + (syntax-parse #'(1 2 3) + [(a b ...) + (syntax->datum + (datum->syntax + #'dummy + (repeat-stx a (b ...))))]) + '(1 1)) + + (check-equal? + (syntax-parse #'(1 (2 3) (uu vv ww) (xx yy)) + [(a (b ...) ...) + (syntax->datum + (datum->syntax + #'dummy + (repeat-stx a ((b ...) ...))))]) + '((1 1) (1 1 1) (1 1))) + + (check-equal? + (syntax-parse #'(1 ((2) (3 3)) ((uu) (vv vv) (ww ww ww)) ((xx) (yy))) + [(a ((b ...) ...) ...) + (syntax->datum + (datum->syntax + #'dummy + (repeat-stx a (((b ...) ...) ...))))]) + '(((1) (1 1)) ((1) (1 1) (1 1 1)) ((1) (1)))) + + (check-equal? + (syntax-parse #'([1 x] [2 y] [3 z]) + [([a b] ...) + (syntax->datum + (datum->syntax + #'dummy + (repeat-stx (a ...) (b ...))))]) + '(1 2 3)) + + (check-equal? + (syntax-parse #'((1 2 3) (a b)) + [([a b ...] ...) + (syntax->datum + (datum->syntax + #'dummy + (repeat-stx (a ...) ((b ...) ...))))]) + '((1 1) (a))) + + (check-equal? + (syntax-parse #'(((1 2 3) (a b)) ((x y z t) (-1 -2))) + [[[[a b ...] ...] ...] + (syntax->datum + (datum->syntax + #'dummy + (repeat-stx ((a ...) ...) (((b ...) ...) ...))))]) + '(((1 1) (a)) ((x x x) (-1)))) + + (check-equal? + (syntax-parse #'((f (1 2 3) (a b)) (g (x y z t) (-1 -2))) + [[[a (b ...) ...] ...] + (syntax->datum + (datum->syntax + #'dummy + (repeat-stx (a ...) (((b ...) ...) ...))))]) + '(((f f f) (f f)) ((g g g g) (g g)))) + + (check-equal? + (syntax-parse #'((h () ()) (i () (x y z) ())) + [([a (b ...) ...] ...) + (syntax->datum + (datum->syntax + #'dummy + (repeat-stx (a ...) (((b ...) ...) ...))))]) + '((() ()) (() (i i i) ())))) + +(module+ test + (require (submod ".." repeat-stx-test))) + +;; ==== low/test-framework.rkt ==== +(require (for-syntax syntax/parse) + (for-syntax (submod "." syntax-parse-extensions-untyped)) + (for-syntax (submod "." repeat-stx-untyped)) + typed/rackunit) + +(provide check-equal?-classes + check-equal?-classes:) + +(: check-equal?-classes (∀ (A ...) (→ (Pairof String (Listof A)) ... Void))) +(define (check-equal?-classes . classes) + (for* ([(head tail) (in-split* classes)]) + (let ([this-class (sequence-ref tail 0)] + [different-classes (in-sequences head (sequence-tail tail 1))]) + (for ([val (cdr this-class)]) + (for ([other-val (cdr this-class)]) + #;(displayln (format "Test ~a ∈ ~a = ~a ∈ ~a …" + val + this-class + other-val + this-class)) + (check-equal? val other-val + (format "Test ~a ∈ ~a = ~a ∈ ~a failed." + val + this-class + other-val + this-class))) + (for ([different-class different-classes]) + (for ([different-val (cdr different-class)]) + #;(displayln (format "Test ~a ∈ ~a != ~a ∈ ~a ∈ ~a …" + val + this-class + different-val + different-class + (sequence->list different-classes))) + (check-not-equal? val different-val + (format "Test ~a ∈ ~a != ~a ∈ ~a ∈ ~a failed." + val + this-class + different-val + different-class + (sequence->list different-classes))))))))) + +(define-syntax/parse (check-equal?-classes: + (~seq [(~maybe #:name name:expr) + (~maybe (~lit :) c-type) + (~seq val (~maybe (~lit :) v-type)) …]) + …) + (define/with-syntax ([a-val …] …) + (template ([(?? (ann val v-type) val) …] …))) + (define/with-syntax ([aa-val …] …) + (let () + ;; TODO: this is ugly, repeat-stx should handle missing stuff instead. + (define/with-syntax (xx-c-type …) (template ((?? (c-type) ()) …))) + (syntax-parse (repeat-stx (xx-c-type …) ([val …] …)) + [([((~optional c-type-rep)) …] …) + (template ([(?? name "") (?? (ann a-val c-type-rep) a-val) …] …))]))) + (template + (check-equal?-classes (list aa-val …) …))) + +;; ==== low/typed-not-implemented-yet.rkt ==== + +(define-syntax-rule (? t) ((λ () : t (error "Not implemented yet")))) + ;; ==== end ==== \ No newline at end of file diff --git a/graph/type-expander/type-expander.lp2.rkt b/graph/type-expander/type-expander.lp2.rkt index 709ba9fa..535435e4 100644 --- a/graph/type-expander/type-expander.lp2.rkt +++ b/graph/type-expander/type-expander.lp2.rkt @@ -495,10 +495,6 @@ them. (~and name+parent (~or name:id [name:id parent:id])) ([field:id :colon type:expr] ...) . rest) - (displayln #'(tvars= tvars - name+parent= name+parent - field...= field ... - rest= rest)) (template (struct (?? tvars.maybe) name (?? parent) ([field : (tmpl-expand-type tvars.vars type)] ...) . rest))]))] @@ -631,7 +627,6 @@ them. (check-equal? ((caddr ((se4 4 5 "f") 'd (λ ([x : Number]) (* x 2)))) 123) 246) (check-not-exn (λ () (ann (car ((se3 4 5 "f") 'd 'e)) se2))) - (check-not-exn (λ () (ann (car ((se3 4 5 "f") 'd 'e)) se3))) (check-true (se2? (car ((se2 2 3) 'd)))) (check-true (se3? (car ((se2 2 3) 'e))))]