From 3516d1aac8e30f29042e75a40af7dda1f193db12 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Tue, 22 Mar 2016 13:33:45 +0100 Subject: [PATCH] Fixed bug due to improper implementation of #:?, FB case #107. --- graph-lib/graph/__.rkt.tmp | 31 ++++ graph-lib/graph/__DEBUG_graph6.rkt | 162 +++++++++++++++++++ graph-lib/graph/__DEBUG_graph6_B.rkt | 150 +++++++++++++++++ graph-lib/graph/adt.lp2.rkt | 1 + graph-lib/graph/constructor.lp2.rkt | 3 +- graph-lib/graph/graph-6-rich-returns.lp2.rkt | 133 +++++++-------- graph-lib/graph/graph.lp2.rkt | 11 +- graph-lib/graph/remember.rkt | 4 + graph-lib/graph/rewrite-type.lp2.rkt | 109 +++++++------ graph-lib/graph/rewrite-type.scrbl | 4 +- graph-lib/graph/structure.lp2.rkt | 40 +++-- graph-lib/graph/tagged.lp2.rkt | 9 +- graph-lib/graph/test-map-get.rkt | 3 +- graph-lib/lib/low/syntax-parse.rkt | 12 ++ graph-lib/make/make.rkt | 2 +- 15 files changed, 523 insertions(+), 151 deletions(-) create mode 100644 graph-lib/graph/__.rkt.tmp create mode 100644 graph-lib/graph/__DEBUG_graph6_B.rkt diff --git a/graph-lib/graph/__.rkt.tmp b/graph-lib/graph/__.rkt.tmp new file mode 100644 index 00000000..428a2e7b --- /dev/null +++ b/graph-lib/graph/__.rkt.tmp @@ -0,0 +1,31 @@ +#lang racket + +[ + (define-graph g1 + ;; Node types (same): + [(a [field₁ : (List Foo Bar n-mb/placeholder Baz Quux)] + [field₂ : (Pairof …c/placeholder …a/placeholder)])] + [(b [field₃] …)] + [(c [field₇] …)] + + [(n-ma [val : a])] + ;[(n-ma1 [val : a])] + ;[(n-ma2 [val : a])] + [(n-mb [val : (Listof b)])] + [(n-mc [val : c])] + ;; Mappings: functions from external data to nodes + [m-n-ma1 (→ (Listof String) n-ma1) + (n-ma1/incomplete + (ma (… (m-n-mb some-data) …) + (cons (m-n-mc more-data) + (m-n-ma2 other-data))))] + ;[m-n-ma2 (→ String Integer n-ma2) …] + [m-n-mb (→ Integer n-mb) …] + [m-n-mc (→ … n-mc) …] + [ma (→ arg1: (List Foo Bar n-mb/placeholder Baz Quux) + arg2: (Pairof n-mc/placeholder + n-ma2/placeholder) + a) + (a/incomplete arg1 arg2)] + [mb (→ ? b) …] + [mc (→ ? c) …])] \ No newline at end of file diff --git a/graph-lib/graph/__DEBUG_graph6.rkt b/graph-lib/graph/__DEBUG_graph6.rkt index 01eac8d7..157e0aa2 100644 --- a/graph-lib/graph/__DEBUG_graph6.rkt +++ b/graph-lib/graph/__DEBUG_graph6.rkt @@ -86,3 +86,165 @@ (dg grr) (dg grra) |# + + + + + + + + + + +;; DEBUG: +#;(require (for-syntax racket/format + "rewrite-type.lp2.rkt" + racket/syntax + syntax/parse + (submod "../lib/low.rkt" untyped)) + (for-syntax syntax/parse + syntax/parse/experimental/template + racket/syntax + (submod "../lib/low.rkt" untyped) + "rewrite-type.lp2.rkt" #|debug|# + syntax/id-set + racket/format + mischief/transform) + (rename-in "../lib/low.rkt" [~> threading:~>]) + "graph.lp2.rkt" + "get.lp2.rkt" + "../type-expander/type-expander.lp2.rkt" + "../type-expander/multi-id.lp2.rkt" + "adt.lp2.rkt" ; debug + "fold-queues.lp2.rkt"; debug + "rewrite-type.lp2.rkt"; debug + "meta-struct.rkt"; debug + racket/stxparam + racket/splicing) +#;(begin + (define-graph + grr31/first-step + #:definitions + ((define-type-expander + (~> stx) + (syntax-parse + stx + ((_ (~datum m-cities)) (template (U (grr31/first-step #:placeholder m-cities4/node) (Listof (grr31/first-step #:placeholder City))))) + ((_ (~datum m-streets)) (template (U (grr31/first-step #:placeholder m-streets5/node) (Listof (grr31/first-step #:placeholder Street))))))) + (define-type-expander (first-step-expander2 stx) (syntax-parse stx ((_ (~datum m-cities)) #'(U m-cities4/node (Listof City))) ((_ (~datum m-streets)) #'(U m-streets5/node (Listof Street)))))) + (City (streets : (Let (~> first-step-expander2) (~> m-streets))) ((City2/simple-mapping (streets : (~> m-streets))) (City streets))) + (Street (sname : (Let (~> first-step-expander2) String)) ((Street3/simple-mapping (sname : String)) (Street sname))) + (m-cities4/node + (returned : (Listof City)) + ((m-cities (cnames : (Listof (Listof bubble)))) + (m-cities4/node (let ((City City2/simple-mapping) (Street Street3/simple-mapping)) (define (strings→city (s : (Listof blob))) (City (m-streets s))) (map strings→city cnames))))) + (m-streets5/node (returned : (Listof Street)) ((m-streets (snames : (Listof String))) (m-streets5/node (let ((City City2/simple-mapping) (Street Street3/simple-mapping)) (map Street snames)))))) + + (define-graph + grr3 + #:definitions + ((define-type-expander (~>-to-result-type stx) (syntax-parse stx ((_ (~datum m-cities)) #'(Listof City)) ((_ (~datum m-streets)) #'(Listof Street)))) + (define-type m-cities10/node-marker (U (grr31/first-step m-cities4/node) (Listof (grr31/first-step City)))) + (define-type m-streets11/node-marker (U (grr31/first-step m-streets5/node) (Listof (grr31/first-step Street)))) + (define-type-expander (second-step-marker-expander stx) (syntax-parse stx ((_ (~datum m-cities)) #'m-cities10/node-marker) ((_ (~datum m-streets)) #'m-streets11/node-marker))) + (define-type second-step-m-cities16/node-of-first (grr31/first-step m-cities4/node)) + (define-type second-step-m-streets17/node-of-first (grr31/first-step m-streets5/node)) + (define-type-expander + (second-step-marker2-expander stx) + (syntax-parse + stx + ((_ (~datum m-cities)) #'(U second-step-m-cities16/node-of-first (Listof (grr31/first-step City)))) + ((_ (~datum m-streets)) #'(U second-step-m-streets17/node-of-first (Listof (grr31/first-step Street)))))) + #;(define-type-expander + (inline-type stx) + (dbg + ("inline-type" stx) + (syntax-parse + stx + ((_ i-t (~and seen (:id …))) + (let ((seen-list (syntax->list #'seen))) + (when (and (not (null? seen-list)) (member (car seen-list) (cdr seen-list) free-identifier=?)) + (raise-syntax-error + 'define-graph/rich-returns + (~a "Cycles in types are not allowed." " The following types were already inlined: " (syntax->datum #'seen) ", but " #'t " appeared a second time.") + #'t))) + (replace-in-type + #'(Let (~> second-step-marker-expander) i-t) + #'((m-cities10/node-marker (inline-type (Listof City) (m-cities4/node . seen))) + (m-streets11/node-marker (inline-type (Listof Street) (m-streets5/node . seen))) + (City (grr3 #:placeholder City)) + (Street (grr3 #:placeholder Street)))))))) + (define-syntax (inline-instance stx) + (dbg + ("inline-instance" stx) + (syntax-parse + stx + ((_ i-t (~and seen (:id …))) + (define/with-syntax typp #'(Let (~> second-step-marker2-expander) i-t)) + (define/with-syntax + repl + (replace-in-instance + #'typp + #'((second-step-m-cities16/node-of-first Symbol (grr31/first-step #:? m-cities4/node) (λ _ (error "NIY4"))) + (second-step-m-streets17/node-of-first Symbol (grr31/first-step #:? m-streets5/node) (λ _ (error "NIY4"))) + (City (grr3 #:placeholder City) (grr31/first-step #:? City) (λ _ (error "NIY3"))) + (Street (grr3 #:placeholder Street) (grr31/first-step #:? Street) (λ _ (error "NIY3")))))) + (displayln (list "i-t=" #'typp)) + (let ((seen-list (syntax->list #'seen))) + (when (and (not (null? seen-list)) (member (car seen-list) (cdr seen-list) free-identifier=?)) + (raise-syntax-error + 'define-graph/rich-returns + (~a "Cycles in types are not allowed." " The following types were already inlined: " (syntax->datum #'seen) ", but " #'t " appeared a second time.") + #'t))) + #'(λ ((x : (Let (~> second-step-marker2-expander) i-t))) repl (error "NIY2"))))))) + (City (streets : (Let (~> ~>-to-result-type) (~> m-streets))) + ((City6/extract/mapping (from : (grr31/first-step City))) + (City + + (;;(inline-instance (~> m-streets) ()) + (λ ((x : (Let (~> second-step-marker2-expander) (~> m-streets)))) + (λ ((val : (U second-step-m-streets17/node-of-first (Listof (grr31/first-step Street))))) + (first-value + ((λ ((val : (U second-step-m-streets17/node-of-first (Listof (grr31/first-step Street)))) (acc : Void)) + : + (values (U Symbol (Listof (grr31/first-step Street))) Void) + ;(ann val (U second-step-m-streets17/node-of-first (Listof (grr31/first-step Street)))) + (ann val (U (grr31/first-step m-streets5/node) (Listof (grr31/first-step Street)))) + (cond + (((grr31/first-step #:? m-streets5/node) val) + #;(if (equal? (ann 0 Number) 0) + (ann val Nothing);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;PROBLEM + #f) + ((ann (λ ((x : second-step-m-streets17/node-of-first) (acc : Void)) (values ((λ _ (error "NIY4")) x) acc)) (→ second-step-m-streets17/node-of-first Void (values Symbol Void))) val acc)) + (#t + ((λ ((val : (Listof (grr31/first-step Street))) (acc : Void)) + : + (values (Listof (grr31/first-step Street)) Void) + (let ((f + ((inst foldl (grr31/first-step Street) (Pairof (Listof (grr31/first-step Street)) Void) Nothing Nothing) + (λ ((x : (grr31/first-step Street)) (acc1 : (Pairof (Listof (grr31/first-step Street)) Void))) + (let-values (((res res-acc) ((inst values (grr31/first-step Street) Void) x (cdr acc1)))) (cons (cons res (car acc1)) res-acc))) + (cons '() acc) + val))) + (values (reverse (car f)) (cdr f)))) + val + acc)) + (else + (typecheck-fail + (Let (~> second-step-marker2-expander) (~> m-streets)) + "Unhandled union case in (U second-step-m-streets17/node-of-first (Listof (grr31/first-step Street))), whole type was:(Let (~> second-step-marker2-expander) (~> m-streets))" + )))) + val + (void)))) + (error "NIY2")) + (get from streets)) + + + + + #;((inline-instance (~> m-streets) ()) + (get from streets))))) + (Street (sname : (Let (~> ~>-to-result-type) String)) + ((Street7/extract/mapping (from : (grr31/first-step Street))) + (Street ((inline-instance String ()) + (get from sname))))))) diff --git a/graph-lib/graph/__DEBUG_graph6_B.rkt b/graph-lib/graph/__DEBUG_graph6_B.rkt new file mode 100644 index 00000000..47afa249 --- /dev/null +++ b/graph-lib/graph/__DEBUG_graph6_B.rkt @@ -0,0 +1,150 @@ +#lang typed/racket + +(require "graph-6-rich-returns.lp2.rkt" + "../lib/low.rkt" + "graph.lp2.rkt" + "get.lp2.rkt" + "../type-expander/type-expander.lp2.rkt" + "../type-expander/multi-id.lp2.rkt" + "adt.lp2.rkt" ; debug + "fold-queues.lp2.rkt"; debug + "rewrite-type.lp2.rkt"; debug + "meta-struct.rkt"; debug + racket/splicing; debug + (for-syntax syntax/parse) + (for-syntax syntax/parse/experimental/template)) + +#| +(require "__DEBUG_graph6B.rkt") + +(frozen (~>)) +|# + + +(require "../lib/debug-syntax.rkt") + +(define-type blob String) +(define-type-expander (bubble stx) #'String) + +(require (for-syntax syntax/strip-context)) + +(define-syntax (super-define-graph/rich-return stx) + (syntax-case stx () + [(_ name . rest) + (with-syntax ([(b (d (dgi n) . r) (dgi2 n2)) + (replace-context + stx + #'(begin + (define-syntax-rule (dg1 name) + (define-graph/rich-return name ~> . rest)) + (dg1 name)))]) + #'(b (d (dgX n) . r) (dgX n2)))])) + +(require (for-syntax racket/format + "rewrite-type.lp2.rkt" + racket/syntax + syntax/parse + (submod "../lib/low.rkt" untyped)) + (for-syntax syntax/parse + syntax/parse/experimental/template + racket/syntax + (submod "../lib/low.rkt" untyped) + "rewrite-type.lp2.rkt" #|debug|# + syntax/id-set + racket/format + mischief/transform) + (rename-in "../lib/low.rkt" [~> threading:~>]) + "graph.lp2.rkt" + "get.lp2.rkt" + "../type-expander/type-expander.lp2.rkt" + "../type-expander/multi-id.lp2.rkt" + "adt.lp2.rkt" ; debug + "fold-queues.lp2.rkt"; debug + "rewrite-type.lp2.rkt"; debug + "meta-struct.rkt"; debug + racket/stxparam + racket/splicing) +(begin + (define-graph + grr31/first-step + #:definitions + ((define-type-expander + (~> stx) + (syntax-parse + stx + ((_ (~datum m-cities)) (template (U (grr31/first-step #:placeholder m-cities4/node) (Listof (grr31/first-step #:placeholder City))))) + ((_ (~datum m-streets)) (template (U (grr31/first-step #:placeholder m-streets5/node) (Listof (grr31/first-step #:placeholder Street))))))) + (define-type-expander (first-step-expander2 stx) (syntax-parse stx ((_ (~datum m-cities)) #'(U m-cities4/node (Listof City))) ((_ (~datum m-streets)) #'(U m-streets5/node (Listof Street)))))) + (City (streets : (Let (~> first-step-expander2) (~> m-streets))) ((City2/simple-mapping (streets : (~> m-streets))) (City streets))) + (Street (sname : (Let (~> first-step-expander2) String)) ((Street3/simple-mapping (sname : String)) (Street sname))) + (m-cities4/node + (returned : (Listof City)) + ((m-cities (cnames : (Listof (Listof bubble)))) + (m-cities4/node (let ((City City2/simple-mapping) (Street Street3/simple-mapping)) (define (strings→city (s : (Listof blob))) (City (m-streets s))) (map strings→city cnames))))) + (m-streets5/node (returned : (Listof Street)) ((m-streets (snames : (Listof String))) (m-streets5/node (let ((City City2/simple-mapping) (Street Street3/simple-mapping)) (map Street snames)))))) + + (define-graph + grr3 + #:definitions + ((define-type-expander (~>-to-result-type stx) (syntax-parse stx ((_ (~datum m-cities)) #'(Listof City)) ((_ (~datum m-streets)) #'(Listof Street)))) + (define-type m-cities10/node-marker (U (grr31/first-step m-cities4/node) (Listof (grr31/first-step City)))) + (define-type m-streets11/node-marker (U (grr31/first-step m-streets5/node) (Listof (grr31/first-step Street)))) + (define-type-expander (second-step-marker-expander stx) (syntax-parse stx ((_ (~datum m-cities)) #'m-cities10/node-marker) ((_ (~datum m-streets)) #'m-streets11/node-marker))) + (define-type second-step-m-cities16/node-of-first (grr31/first-step m-cities4/node)) + (define-type second-step-m-streets17/node-of-first (grr31/first-step m-streets5/node)) + (define-type-expander + (second-step-marker2-expander stx) + (syntax-parse + stx + ((_ (~datum m-cities)) #'(U second-step-m-cities16/node-of-first (Listof (grr31/first-step City)))) + ((_ (~datum m-streets)) #'(U second-step-m-streets17/node-of-first (Listof (grr31/first-step Street)))))) + #;(define-type-expander + (inline-type stx) + (dbg + ("inline-type" stx) + (syntax-parse + stx + ((_ i-t (~and seen (:id …))) + (let ((seen-list (syntax->list #'seen))) + (when (and (not (null? seen-list)) (member (car seen-list) (cdr seen-list) free-identifier=?)) + (raise-syntax-error + 'define-graph/rich-returns + (~a "Cycles in types are not allowed." " The following types were already inlined: " (syntax->datum #'seen) ", but " #'t " appeared a second time.") + #'t))) + (replace-in-type + #'(Let (~> second-step-marker-expander) i-t) + #'((m-cities10/node-marker (inline-type (Listof City) (m-cities4/node . seen))) + (m-streets11/node-marker (inline-type (Listof Street) (m-streets5/node . seen))) + (City (grr3 #:placeholder City)) + (Street (grr3 #:placeholder Street)))))))) + (define-syntax (inline-instance stx) + (dbg + ("inline-instance" stx) + (syntax-parse + stx + ((_ i-t (~and seen (:id …))) + (define/with-syntax typp #'(Let (~> second-step-marker2-expander) i-t)) + (define/with-syntax + repl + (replace-in-instance + #'typp + #'((second-step-m-cities16/node-of-first Symbol (grr31/first-step #:? m-cities4/node) (λ _ (error "NIY4"))) + (second-step-m-streets17/node-of-first Symbol (grr31/first-step #:? m-streets5/node) (λ _ (error "NIY4"))) + (City (grr3 #:placeholder City) (grr31/first-step #:? City) (λ _ (error "NIY3"))) + (Street (grr3 #:placeholder Street) (grr31/first-step #:? Street) (λ _ (error "NIY3")))))) + (displayln (list "i-t=" #'typp)) + (let ((seen-list (syntax->list #'seen))) + (when (and (not (null? seen-list)) (member (car seen-list) (cdr seen-list) free-identifier=?)) + (raise-syntax-error + 'define-graph/rich-returns + (~a "Cycles in types are not allowed." " The following types were already inlined: " (syntax->datum #'seen) ", but " #'t " appeared a second time.") + #'t))) + #'(λ ((x : (Let (~> second-step-marker2-expander) i-t))) repl (error "NIY2"))))))) + (City (streets : (Let (~> ~>-to-result-type) (~> m-streets))) + ((City6/extract/mapping (from : (grr31/first-step City))) + (City ((inline-instance (~> m-streets) ()) + (get from streets))))) + (Street (sname : (Let (~> ~>-to-result-type) String)) + ((Street7/extract/mapping (from : (grr31/first-step Street))) + (Street ((inline-instance String ()) + (get from sname))))))) \ No newline at end of file diff --git a/graph-lib/graph/adt.lp2.rkt b/graph-lib/graph/adt.lp2.rkt index 4f4e3122..6cd8f098 100644 --- a/graph-lib/graph/adt.lp2.rkt +++ b/graph-lib/graph/adt.lp2.rkt @@ -113,6 +113,7 @@ whose single value is a promise for a structure)@note{This constructor? constructor-values tagged + tagged? define-tagged variant define-variant diff --git a/graph-lib/graph/constructor.lp2.rkt b/graph-lib/graph/constructor.lp2.rkt index af242c01..9380e282 100644 --- a/graph-lib/graph/constructor.lp2.rkt +++ b/graph-lib/graph/constructor.lp2.rkt @@ -129,6 +129,7 @@ otherwise): (datum->syntax #f constructor-name)) constructor-name→stx-name/alist))]) . body) + ;; TODO: set srcloc of fallback to stx on the next line: (remember-all-errors2 fallback constructor-name)))] @section{@racket[constructor]} @@ -191,7 +192,7 @@ instance: (syntax-parse stx [(_ constructor-name (~maybe #:with-struct with-struct) v) (quasisyntax/loc stx - (#,(syntax/loc stx + (#,(template/loc stx (Constructor-predicate? constructor-name (?? (?@ #:with-struct with-struct)))) v))] diff --git a/graph-lib/graph/graph-6-rich-returns.lp2.rkt b/graph-lib/graph/graph-6-rich-returns.lp2.rkt index 90026d38..2d2d060a 100644 --- a/graph-lib/graph/graph-6-rich-returns.lp2.rkt +++ b/graph-lib/graph/graph-6-rich-returns.lp2.rkt @@ -118,12 +118,16 @@ plain list. (define-temp-ids "~a/node-marker" (mapping …)) (define-temp-ids "~a/node-marker2" (mapping …)) (define-temp-ids "~a/from-first-pass" (node …)) + (define-temp-ids "second-step-~a/node-of-first" (mapping …)) ;(define step2-introducer (make-syntax-introducer)) ;(define/with-syntax id-~> (datum->syntax #'name '~>)) ;(define/with-syntax introduced-~> (datum->syntax #'name '~>)) (quasitemplate/debug debug (begin - (define-graph name/first-step + #,(dbg + ("first-pass" stx) + (quasitemplate + (define-graph name/first-step #:definitions [] [node [field c (Let [id-~> first-step-expander2] field-type)] … [(node/simple-mapping [field c field-type] …) @@ -134,7 +138,7 @@ plain list. (mapping/node (let ([node node/simple-mapping] …) . body))]] - …) + …))) ;; TODO: how to return something else than a node?? ;; Possibility 1: add a #:main function to define-graph, which can ;; call (make-root). @@ -163,42 +167,9 @@ result type of the user-provided mappings, for example @tc[(Listof Street)]: ;; TODO: should fall-back to outer definition of ~>, if any? ))] -We define the mapping's body in the second pass as a separate macro, so that -when it is expanded, the @tc[second-step-marker-expander] has already been -introduced. - -@CHUNK[ - (define-syntax/parse (pass-2-mapping-body name - ) - - (template - (node ( (get from field)) - …)))] - -We need to provide to that staged macro all the identifiers it needs: - -@chunk[ - id-~> - second-step-marker-expander - first-pass - node - (node* …) - from - (field …) - (field-type …) - (result-type …) - (mapping/node-marker …) - (mapping/node …) - val] - The goal of these mappings is to inline the temporary nodes, and return a value which does not refer to them anymore: -@chunk[ - (!inline-temp-nodes/instance field-type) - #;(tmpl-replace-in-instance (Let (id-~> second-step-marker-expander) - field-type) - )] Where @tc[second-step-marker-expander] (in the input type to @tc[replace-in-instance]) expands to the temporary marker @@ -207,30 +178,46 @@ produced by the first step. @chunk[ ;; TODO: should use Let or replace-in-type, instead of defining the node ;; globally like this. - (define-type node (name/first-step node)) - … + ;(define-type node (name/first-step node)) + ;… + #| (define-type mapping/node-marker (U result-type - (name/first-step node))) + (name/first-step node))) + ;; TODO: shouldn't it be (name/first-step mapping/node) ? … + |# + (define-type mapping/node-marker + (U (name/first-step mapping/node) + (tmpl-replace-in-type result-type + [mapping/node (name/first-step mapping/node)] + [node (name/first-step node)]))) + … + ;; TODO ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;TODO;^^;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-type-expander (second-step-marker-expander stx) (syntax-parse stx ;; TODO: should be ~literal [(_ (~datum mapping)) #'mapping/node-marker] … ;; TODO: should fall-back to outer definition of ~>, if any? + )) + + (define-type second-step-mapping/node-of-first + (name/first-step mapping/node)) + … + + (define-type-expander (second-step-marker2-expander stx) + (syntax-parse stx + ;; TODO: should be ~literal + [(_ (~datum mapping)) #'(U second-step-mapping/node-of-first + (tmpl-replace-in-type result-type + [mapping/node (name/first-step mapping/node)] + [node (name/first-step node)]))] … + ;; TODO: should fall-back to outer definition of ~>, if any? ))] Replacing a marker node is as simple as extracting the contents of its single field. -@chunk[ - [mapping/node-marker - - (graph #:? mapping/node) - (λ ([m : (first-pass mapping/node)]) - (get m val))] - …] - @subsection{Fully-inlined type} The result of recursively inlining the temporary mapping nodes may be a @@ -279,7 +266,8 @@ in all of its fields: @chunk[ ;; inline from the field-type of the old node. - (node ((inline-instance field-type ()) (get from field));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (node ((inline-instance field-type;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ()) (get from field)) …)] @subsection{Inlining instances} @@ -287,29 +275,46 @@ To inline the temporary nodes in the instance, we use @tc[replace-in-instance], and call the inline-instance recursively: -@chunk[ +;; HERE, we should expand a type of the shape: + +(foo bar (U m-street (Listof Street)) baz quux) + +@CHUNK[ (define-syntax (inline-instance stx) (dbg ("inline-instance" stx) (syntax-parse stx [(_ i-t (~and seen (:id (… …)))) + (define/with-syntax typp #'(Let (id-~> second-step-marker2-expander) i-t)) + (define/with-syntax repl (replace-in-instance #'typp + #'( + ))) + (displayln (list "i-t=" #'typp)) - (replace-in-instance #'(Let (id-~> second-step-marker-expander) i-t) - #'( - ))])))] + #'(λ ([x : (Let (id-~> second-step-marker2-expander) i-t)]) + ;( + repl + ;x) + (error "NIY2")) + #;(replace-in-instance #'(Let (id-~> second-step-marker2-expander) i-t) + #'( + ))])))] @chunk[ - [mapping/node-marker ;; from - (inline-type result-type (mapping/node . seen)) ;; to - (first-pass #:? mapping/node) ;; pred? - (inline-instance result-type (mapping/node . seen))] ;; fun + [second-step-mapping/node-of-first ;; from + ;(inline-type result-type (mapping/node . seen)) ;; to + Symbol ;; DEBUG + (name/first-step #:? mapping/node) ;; pred? + #;(inline-instance result-type (mapping/node . seen)) + (λ _ (error "NIY4"))] ;; fun …] @chunk[ - [node ;; generated by the first pass - (name #:placeholder node) ;; new type - (first-pass #:? node) - node/extract/mapping] ;; call mapping + [node ;; from ;; generated by the first pass + (name #:placeholder node) ;; to ;; new type + (name/first-step #:? node) ;; pred? + #;node/extract/mapping + (λ _ (error "NIY3"))] ;; fun ;; call mapping …] @subsection{Inlining types} @@ -385,7 +390,8 @@ Which is equivalent to: (first-pass m-3) #:or some-abritrary-type-3)] -The generated code would be: +The generated code would roughly be (possibly without +merging the node + return-type pairs): @chunk[| 1) (~> 2) …) generated >| (λ ([v : (V (first-pass m-1) @@ -518,20 +524,21 @@ encapsulating the result types of mappings. "meta-struct.rkt"; debug racket/stxparam racket/splicing) - (provide define-graph/rich-return); ~>) + (provide define-graph/rich-return + (for-syntax dbg) ;; DEBUG + ); ~>) ;(define-syntax-parameter ~> (make-rename-transformer #'threading:~>)) (require (for-syntax racket/pretty)) - ; (begin-for-syntax (define-syntax-rule (dbg log . body) (begin (display ">>> ")(displayln (list . log)) (let ((res (let () . body))) (display "<<< ")(displayln (list . log)) - (display "<<<= ")(displayln res) + (display "<<<= ")(display (car (list . log)))(displayln res) res)))) )] diff --git a/graph-lib/graph/graph.lp2.rkt b/graph-lib/graph/graph.lp2.rkt index 4eaf219d..0d463f28 100644 --- a/graph-lib/graph/graph.lp2.rkt +++ b/graph-lib/graph/graph.lp2.rkt @@ -313,7 +313,8 @@ The graph name will be used in several ways: ;; so we should wrap the nodes in a tag, which contains a ;; promise, instead of the opposite (tag inside promise). [(_ #:? (~datum node)) - (syntax/loc stx node?)] + ((λ (v) (display "graph node?")(displayln v) v) + (syntax/loc stx node?))] ;;;;;;;;;;;;;;;TODO: implement node? properly here! FB case 107 … [(_ . rest) (syntax/loc stx (root/constructor . rest))])) @@ -568,7 +569,9 @@ library. We replace all occurrences of a @tc[node] name with a @tc[Promise] for that node's @tc[with-promises] type. @CHUNK[ - (define-constructor node/promise-type #:private + (define-constructor node/promise-type + #:private + #:? node? (Promise node/with-promises))] @CHUNK[ (define-plain-structure node/with-promises @@ -750,8 +753,8 @@ via @tc[(g Street)]. (λ (stx) (syntax-parse stx [(_ (~datum node)) #'node/promise-type] … - [(_ (~datum node) (~datum field)) - (template )] … … + ;[(_ (~datum node) (~datum field)) + ; (template )] … … [(_ #:incomplete (~datum node)) #'node/incomplete-type] … [(_ #:make-incomplete (~datum node)) #'(→ field/incomplete-type … node/incomplete-type)] … diff --git a/graph-lib/graph/remember.rkt b/graph-lib/graph/remember.rkt index 670139d2..5a4771e4 100644 --- a/graph-lib/graph/remember.rkt +++ b/graph-lib/graph/remember.rkt @@ -168,3 +168,7 @@ (constructor . structure) (constructor . wstructure) (constructor . wstructure) +(constructor . m-streets5/node) +(constructor . tabc) +(constructor . t) +(constructor . t) diff --git a/graph-lib/graph/rewrite-type.lp2.rkt b/graph-lib/graph/rewrite-type.lp2.rkt index a80a3407..093b465a 100644 --- a/graph-lib/graph/rewrite-type.lp2.rkt +++ b/graph-lib/graph/rewrite-type.lp2.rkt @@ -84,7 +84,7 @@ set of known type constructors like @tc[List] or @tc[Pairof], and recursively calls itself on the components of the type. @CHUNK[ - (define-for-syntax (replace-in-type t r) + (define (replace-in-type t r) (define (recursive-replace new-t) (replace-in-type new-t r)) (define/with-syntax ([from to] ...) r) #;(displayln (format "~a\n=> ~a" @@ -143,7 +143,7 @@ with an internal definition for @tc[recursive-replace]. The case of unions is offloaded to a separate subroutine. @CHUNK[ - (define-for-syntax (replace-in-instance val t r) + (define (replace-in-instance val t r) (parameterize-push-stx ([current-replacement `(replace-in-instance ,val ,t ,r)]) (define/with-syntax ([from to fun] ...) r) @@ -401,7 +401,7 @@ functions is undefined. @subsection{The code} @CHUNK[ - (define-for-syntax (fold-instance whole-type stx-acc-type r) + (define (fold-instance whole-type stx-acc-type r) (parameterize-push-stx ([current-replacement `(fold-instance ,whole-type ,stx-acc-type ,r)]) (define/with-syntax acc-type stx-acc-type) @@ -559,12 +559,12 @@ functions is undefined. (show-backtrace) (displayln (current-replacement)) (raise-syntax-error - 'replace-in-type - (~a "Type-fold-replace on untagged Unions isn't supported yet: " - (syntax->datum ta) - " in " - (syntax->datum #'whole)) - ta)])] + 'replace-in-type + (~a "Type-fold-replace on untagged Unions isn't supported yet: " + (syntax->datum ta) + " in " + (syntax->datum #'whole)) + ta)])] For cases of the union which are a tagged list, we use a simple guard, and call @tc[recursive-replace] on the whole @tc[(List 'tag b ...)] type. @@ -593,17 +593,17 @@ better consistency between the behaviour of @tc[replace-in-instance] and efficient than the separate implementation. @CHUNK[ - (define-for-syntax (replace-in-instance2 t r) - (define/with-syntax ([from to pred? fun] ...) r) - #`(λ ([val : #,(expand-type t)]) - (first-value - (#,(fold-instance t - #'Void - #'([from to pred? (λ ([x : from] [acc : Void]) - (values (fun x) acc))] - ...)) - val - (void)))))] + (define replace-in-instance2 (lambda/debug (t r) + (define/with-syntax ([from to pred? fun] ...) r) + #`(λ ([val : #,(expand-type t)]) + (first-value + (#,(fold-instance t + #'Void + #'([from to pred? (λ ([x : from] [acc : Void]) + (values (fun x) acc))] + ...)) + val + (void))))))] @section{Conclusion} @@ -654,50 +654,55 @@ These metafunctions just extract the arguments for @tc[replace-in-type] and @CHUNK[<*> (begin - (module main typed/racket + (module main racket/base (require - (for-syntax syntax/parse - racket/syntax - racket/format - syntax/parse/experimental/template - racket/sequence - (submod "../lib/low.rkt" untyped) - (only-in "../type-expander/type-expander.lp2.rkt" - expand-type) - "meta-struct.rkt" - "../lib/low/backtrace.rkt") - "../type-expander/multi-id.lp2.rkt" - "../type-expander/type-expander.lp2.rkt" - "../lib/low.rkt") - (begin-for-syntax (provide replace-in-type - ;replace-in-instance - fold-instance - (rename-out [replace-in-instance2 - replace-in-instance]) - tmpl-replace-in-type - tmpl-fold-instance - tmpl-replace-in-instance)) + syntax/parse + racket/syntax + racket/format + syntax/parse/experimental/template + racket/sequence + (submod "../lib/low.rkt" untyped) + (only-in "../type-expander/type-expander.lp2.rkt" + expand-type) + "meta-struct.rkt" + "../lib/low/backtrace.rkt" + debug + racket/require + (for-template (subtract-in + typed/racket + "../type-expander/type-expander.lp2.rkt") + "../type-expander/multi-id.lp2.rkt" + "../type-expander/type-expander.lp2.rkt" + "../lib/low.rkt")) + (provide replace-in-type + ;replace-in-instance + fold-instance + (rename-out [replace-in-instance2 + replace-in-instance]) + tmpl-replace-in-type + tmpl-fold-instance + tmpl-replace-in-instance) - (begin-for-syntax - (define current-replacement (make-parameter #'())) - ;; TODO: move to lib - (require (for-syntax racket/base)) - (define-syntax-rule (parameterize-push ([p val] ...) . body) - (parameterize ([p (cons val (p))] ...) . body)) - (define-syntax-rule (parameterize-push-stx ([p val] ...) . body) - (parameterize ([p #`(#,val . #,(p))] ...) . body))) + + (define current-replacement (make-parameter #'())) + ;; TODO: move to lib + (require (for-syntax racket/base)) + (define-syntax-rule (parameterize-push ([p val] ...) . body) + (parameterize ([p (cons val (p))] ...) . body)) + (define-syntax-rule (parameterize-push-stx ([p val] ...) . body) + (parameterize ([p #`(#,val . #,(p))] ...) . body)) - (begin-for-syntax )) + ) (require 'main) (provide (all-from-out 'main)) (module* test typed/racket - (require (submod "..") + (require (for-syntax (submod "..")) typed/rackunit "../type-expander/multi-id.lp2.rkt" "../type-expander/type-expander.lp2.rkt") diff --git a/graph-lib/graph/rewrite-type.scrbl b/graph-lib/graph/rewrite-type.scrbl index b95f9eed..96c1e099 100644 --- a/graph-lib/graph/rewrite-type.scrbl +++ b/graph-lib/graph/rewrite-type.scrbl @@ -38,7 +38,7 @@ new type. to the new type, using the provided replacement functions for each part.} -@defform[#:kind "function" +@defform[#:kind "procedure" (replace-in-type old-type #'([from to] …)) #:contracts ([old-type type] [from identifier?] @@ -47,7 +47,7 @@ new type. @racket[old-type], with all occurrences of @racket[from] replaced with @racket[to] in the type.} -@defform[#:kind "function" +@defform[#:kind "procedure" (replace-in-instance old-type #'([from to pred? fun] …)) #:contracts ([old-type type] [from identifier?] diff --git a/graph-lib/graph/structure.lp2.rkt b/graph-lib/graph/structure.lp2.rkt index bfd13371..cb541827 100644 --- a/graph-lib/graph/structure.lp2.rkt +++ b/graph-lib/graph/structure.lp2.rkt @@ -30,7 +30,7 @@ types, it wouldn't be clear what fields the remaining type parameters affect). 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 +@tc[#:instance] and @tc[#:make-instance], 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. @@ -38,8 +38,8 @@ handle the empty structure as a special case. (define-splicing-syntax-class structure-args-stx-class (pattern (~or (~seq #:instance (~parse (field … value …) #'())) - (~seq #:constructor (~parse (field …) #'())) - (~seq (~maybe #:constructor ~!) + (~seq #:make-instance (~parse (field …) #'())) + (~seq (~maybe #:make-instance ~!) (~or (~seq (~or-bug [field:id] field:id) …+) (~seq [field:id (~and C :colon) type:expr] …+))) (~seq (~maybe #:instance ~!) @@ -51,8 +51,8 @@ handle the empty structure as a special case. (begin-for-syntax ) (define-multi-id structure - #:type-expander structure-type-expander - #:match-expander structure-match-expander + #:type-expander + #:match-expander #:call (λ (stx) (syntax-parse stx @@ -68,11 +68,11 @@ handle the empty structure as a special case. (let () (define-structure empty-st) (define-structure stA [a Number]) - (check-equal?: (empty-st) ((structure #:constructor))) + (check-equal?: (empty-st) ((structure #:make-instance))) (check-not-equal?: (empty-st) (structure [a 1])) - (check-not-equal?: (structure #:constructor) (structure [a 1])) + (check-not-equal?: (structure #:make-instance) (structure [a 1])) (check-not-equal?: (empty-st) (stA 1)) - (check-not-equal?: (structure #:constructor) (stA 1))) + (check-not-equal?: (structure #:make-instance) (stA 1))) #;(let () (define-structure st [a Number] [b String]) (define-structure stA [a Number]) @@ -453,16 +453,14 @@ The fields in @tc[fields→stx-name-alist] are already sorted. (pattern field:id #:with (pat ...) #'())))] @chunk[ - (define-for-syntax (structure-match-expander stx) - (syntax-parse stx - [(_ :match-field-or-field-pat ...) - (if (check-remember-fields #'(field ...)) - (let () - (define/with-syntax name (fields→stx-name #'(field ...))) - (define/with-syntax ([sorted-field sorted-pat ...] ...) - (sort-car-fields #'((field pat ...) ...))) - #'(name (and sorted-field sorted-pat ...) ...)) - )]))] + (λ/syntax-parse (_ :match-field-or-field-pat ...) + (if (check-remember-fields #'(field ...)) + (let () + (define/with-syntax name (fields→stx-name #'(field ...))) + (define/with-syntax ([sorted-field sorted-pat ...] ...) + (sort-car-fields #'((field pat ...) ...))) + #'(name (and sorted-field sorted-pat ...) ...)) + ))] If we just return @racket[(remember-all-errors list stx #'(field ...))] when a recompilation is needed, then the identifier @tc[delayed-error-please-recompile] @@ -506,7 +504,7 @@ instead of needing an extra recompilation. @subsection{Type-expander} @CHUNK[ - (define-for-syntax (structure-type-expander stx) + (λ (stx) (syntax-parse stx [(_ (~or-bug [field:id] field:id) …) (if (check-remember-fields #'(field ...)) @@ -577,7 +575,7 @@ its arguments across compilations, and adds them to the file (begin-for-syntax (provide structure-args-stx-class)) - + @@ -595,8 +593,6 @@ its arguments across compilations, and adds them to the file - - diff --git a/graph-lib/graph/tagged.lp2.rkt b/graph-lib/graph/tagged.lp2.rkt index 92104110..0045fa8f 100644 --- a/graph-lib/graph/tagged.lp2.rkt +++ b/graph-lib/graph/tagged.lp2.rkt @@ -108,10 +108,11 @@ for a structure. @CHUNK[ (define-syntax/parse (tagged? tag (~maybe #:with-struct with-struct) field …) - #'(λ (v) (and (constructor? tag (?? (?@ #:with-struct with-struct)) v) - (promise? (constructor-values v)) - ((structure? field …) - (force (constructor-values v))))))] + (template + (λ (v) (and (constructor? tag (?? (?@ #:with-struct with-struct)) v) + (promise? (constructor-values v)) + ((structure? field …) + (force (constructor-values v)))))))] @section{Tests} diff --git a/graph-lib/graph/test-map-get.rkt b/graph-lib/graph/test-map-get.rkt index 619b2c74..13e1dbd0 100644 --- a/graph-lib/graph/test-map-get.rkt +++ b/graph-lib/graph/test-map-get.rkt @@ -4,8 +4,7 @@ (require (submod "graph.lp2.rkt" test)) (require "get.lp2.rkt") (require "map.rkt") - (require "structure.lp2.rkt") - (require "variant.lp2.rkt") + (require "adt.lp2.rkt") (require "../lib/low.rkt") (require "../type-expander/type-expander.lp2.rkt") diff --git a/graph-lib/lib/low/syntax-parse.rkt b/graph-lib/lib/low/syntax-parse.rkt index d965ac11..814d52e8 100644 --- a/graph-lib/lib/low/syntax-parse.rkt +++ b/graph-lib/lib/low/syntax-parse.rkt @@ -25,6 +25,8 @@ ~or-bug define-simple-macro λstx + ;template/loc + ;quasitemplate/loc template/debug quasitemplate/debug meta-eval) @@ -134,6 +136,16 @@ (check-equal? (syntax->datum ((λstx (foo bar) #'(foo bar)) #'a #'b)) (syntax->datum #'(a b))))) + ;; template/loc + (begin + (define-syntax-rule (template/loc loc . tmpl) + (quasisyntax/loc loc #,(template . tmpl)))) + + ;; quasitemplate/loc + (begin + (define-syntax-rule (quasitemplate/loc loc . tmpl) + (quasisyntax/loc loc #,(quasitemplate . tmpl)))) + ;; template/debug (begin (define-syntax (template/debug stx) diff --git a/graph-lib/make/make.rkt b/graph-lib/make/make.rkt index 1b763e23..d63093eb 100644 --- a/graph-lib/make/make.rkt +++ b/graph-lib/make/make.rkt @@ -6,7 +6,7 @@ ;(current-directory "..") -(run! (list (find-executable-path-or-fail "sh") +#;(run! (list (find-executable-path-or-fail "sh") "-c" @string-append{ found_long_lines=0