Fixed bug due to improper implementation of #:?, FB case #107.
This commit is contained in:
Georges Dupéron
parent
4d73b476d3
commit
3516d1aac8
31
graph-lib/graph/__.rkt.tmp
Normal file
31
graph-lib/graph/__.rkt.tmp
Normal file
|
|
@ -0,0 +1,31 @@
|
||||||
|
#lang racket
|
||||||
|
|
||||||
|
[<graph-example>
|
||||||
|
(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) …])]
|
||||||
|
|
@ -86,3 +86,165 @@
|
||||||
(dg grr)
|
(dg grr)
|
||||||
(dg grra)
|
(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)))))))
|
||||||
|
|
|
||||||
150
graph-lib/graph/__DEBUG_graph6_B.rkt
Normal file
150
graph-lib/graph/__DEBUG_graph6_B.rkt
Normal file
|
|
@ -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)))))))
|
||||||
|
|
@ -113,6 +113,7 @@ whose single value is a promise for a structure)@note{This
|
||||||
constructor?
|
constructor?
|
||||||
constructor-values
|
constructor-values
|
||||||
tagged
|
tagged
|
||||||
|
tagged?
|
||||||
define-tagged
|
define-tagged
|
||||||
variant
|
variant
|
||||||
define-variant
|
define-variant
|
||||||
|
|
|
||||||
|
|
@ -129,6 +129,7 @@ otherwise):
|
||||||
(datum->syntax #f constructor-name))
|
(datum->syntax #f constructor-name))
|
||||||
constructor-name→stx-name/alist))])
|
constructor-name→stx-name/alist))])
|
||||||
. body)
|
. body)
|
||||||
|
;; TODO: set srcloc of fallback to stx on the next line:
|
||||||
(remember-all-errors2 fallback constructor-name)))]
|
(remember-all-errors2 fallback constructor-name)))]
|
||||||
|
|
||||||
@section{@racket[constructor]}
|
@section{@racket[constructor]}
|
||||||
|
|
@ -191,7 +192,7 @@ instance:
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ constructor-name (~maybe #:with-struct with-struct) v)
|
[(_ constructor-name (~maybe #:with-struct with-struct) v)
|
||||||
(quasisyntax/loc stx
|
(quasisyntax/loc stx
|
||||||
(#,(syntax/loc stx
|
(#,(template/loc stx
|
||||||
(Constructor-predicate? constructor-name
|
(Constructor-predicate? constructor-name
|
||||||
(?? (?@ #:with-struct with-struct))))
|
(?? (?@ #:with-struct with-struct))))
|
||||||
v))]
|
v))]
|
||||||
|
|
|
||||||
|
|
@ -118,11 +118,15 @@ plain list.
|
||||||
(define-temp-ids "~a/node-marker" (mapping …))
|
(define-temp-ids "~a/node-marker" (mapping …))
|
||||||
(define-temp-ids "~a/node-marker2" (mapping …))
|
(define-temp-ids "~a/node-marker2" (mapping …))
|
||||||
(define-temp-ids "~a/from-first-pass" (node …))
|
(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 step2-introducer (make-syntax-introducer))
|
||||||
;(define/with-syntax id-~> (datum->syntax #'name '~>))
|
;(define/with-syntax id-~> (datum->syntax #'name '~>))
|
||||||
;(define/with-syntax introduced-~> (datum->syntax #'name '~>))
|
;(define/with-syntax introduced-~> (datum->syntax #'name '~>))
|
||||||
(quasitemplate/debug debug
|
(quasitemplate/debug debug
|
||||||
(begin
|
(begin
|
||||||
|
#,(dbg
|
||||||
|
("first-pass" stx)
|
||||||
|
(quasitemplate
|
||||||
(define-graph name/first-step
|
(define-graph name/first-step
|
||||||
#:definitions [<first-pass-type-expander>]
|
#:definitions [<first-pass-type-expander>]
|
||||||
[node [field c (Let [id-~> first-step-expander2] field-type)] …
|
[node [field c (Let [id-~> first-step-expander2] field-type)] …
|
||||||
|
|
@ -134,7 +138,7 @@ plain list.
|
||||||
(mapping/node
|
(mapping/node
|
||||||
(let ([node node/simple-mapping] …)
|
(let ([node node/simple-mapping] …)
|
||||||
. body))]]
|
. body))]]
|
||||||
…)
|
…)))
|
||||||
;; TODO: how to return something else than a node??
|
;; TODO: how to return something else than a node??
|
||||||
;; Possibility 1: add a #:main function to define-graph, which can
|
;; Possibility 1: add a #:main function to define-graph, which can
|
||||||
;; call (make-root).
|
;; 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?
|
;; 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[<pass-2-mapping-body>
|
|
||||||
(define-syntax/parse (pass-2-mapping-body name
|
|
||||||
<pass-2-mapping-body-args>)
|
|
||||||
<inline-temp-nodes>
|
|
||||||
(template
|
|
||||||
(node (<replace-in-instance> (get from field))
|
|
||||||
…)))]
|
|
||||||
|
|
||||||
We need to provide to that staged macro all the identifiers it needs:
|
|
||||||
|
|
||||||
@chunk[<pass-2-mapping-body-args>
|
|
||||||
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
|
The goal of these mappings is to inline the temporary nodes, and return a value
|
||||||
which does not refer to them anymore:
|
which does not refer to them anymore:
|
||||||
|
|
||||||
@chunk[<replace-in-instance>
|
|
||||||
(!inline-temp-nodes/instance field-type)
|
|
||||||
#;(tmpl-replace-in-instance (Let (id-~> second-step-marker-expander)
|
|
||||||
field-type)
|
|
||||||
<second-pass-replace>)]
|
|
||||||
|
|
||||||
Where @tc[second-step-marker-expander] (in the input type
|
Where @tc[second-step-marker-expander] (in the input type
|
||||||
to @tc[replace-in-instance]) expands to the temporary marker
|
to @tc[replace-in-instance]) expands to the temporary marker
|
||||||
|
|
@ -207,30 +178,46 @@ produced by the first step.
|
||||||
@chunk[<second-step-marker-expander>
|
@chunk[<second-step-marker-expander>
|
||||||
;; TODO: should use Let or replace-in-type, instead of defining the node
|
;; TODO: should use Let or replace-in-type, instead of defining the node
|
||||||
;; globally like this.
|
;; 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
|
(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;^^;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;; TODO ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;TODO;^^;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
(define-type-expander (second-step-marker-expander stx)
|
(define-type-expander (second-step-marker-expander stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
;; TODO: should be ~literal
|
;; TODO: should be ~literal
|
||||||
[(_ (~datum mapping)) #'mapping/node-marker] …
|
[(_ (~datum mapping)) #'mapping/node-marker] …
|
||||||
;; TODO: should fall-back to outer definition of ~>, if any?
|
;; 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
|
Replacing a marker node is as simple as extracting the
|
||||||
contents of its single field.
|
contents of its single field.
|
||||||
|
|
||||||
@chunk[<second-pass-replace>
|
|
||||||
[mapping/node-marker
|
|
||||||
<fully-replaced-mapping/result-type>
|
|
||||||
(graph #:? mapping/node)
|
|
||||||
(λ ([m : (first-pass mapping/node)])
|
|
||||||
(get m val))]
|
|
||||||
…]
|
|
||||||
|
|
||||||
@subsection{Fully-inlined type}
|
@subsection{Fully-inlined type}
|
||||||
|
|
||||||
The result of recursively inlining the temporary mapping nodes may be a
|
The result of recursively inlining the temporary mapping nodes may be a
|
||||||
|
|
@ -279,7 +266,8 @@ in all of its fields:
|
||||||
|
|
||||||
@chunk[<inlined-node>
|
@chunk[<inlined-node>
|
||||||
;; inline from the field-type of the old node.
|
;; 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}
|
@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
|
@tc[replace-in-instance], and call the inline-instance
|
||||||
recursively:
|
recursively:
|
||||||
|
|
||||||
@chunk[<inline-instance>
|
;; HERE, we should expand a type of the shape:
|
||||||
|
|
||||||
|
(foo bar (U m-street (Listof Street)) baz quux)
|
||||||
|
|
||||||
|
@CHUNK[<inline-instance>
|
||||||
(define-syntax (inline-instance stx)
|
(define-syntax (inline-instance stx)
|
||||||
(dbg
|
(dbg
|
||||||
("inline-instance" stx)
|
("inline-instance" stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ i-t (~and seen (:id (… …))))
|
[(_ 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
|
||||||
|
#'(<inline-instance-replacement>
|
||||||
|
<inline-instance-nodes>)))
|
||||||
|
(displayln (list "i-t=" #'typp))
|
||||||
<inline-check-seen>
|
<inline-check-seen>
|
||||||
(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)
|
||||||
#'(<inline-instance-replacement>
|
#'(<inline-instance-replacement>
|
||||||
<inline-instance-nodes>))])))]
|
<inline-instance-nodes>))])))]
|
||||||
|
|
||||||
@chunk[<inline-instance-replacement>
|
@chunk[<inline-instance-replacement>
|
||||||
[mapping/node-marker ;; from
|
[second-step-mapping/node-of-first ;; from
|
||||||
(inline-type result-type (mapping/node . seen)) ;; to
|
;(inline-type result-type (mapping/node . seen)) ;; to
|
||||||
(first-pass #:? mapping/node) ;; pred?
|
Symbol ;; DEBUG
|
||||||
(inline-instance result-type (mapping/node . seen))] ;; fun
|
(name/first-step #:? mapping/node) ;; pred?
|
||||||
|
#;(inline-instance result-type (mapping/node . seen))
|
||||||
|
(λ _ (error "NIY4"))] ;; fun
|
||||||
…]
|
…]
|
||||||
|
|
||||||
@chunk[<inline-instance-nodes>
|
@chunk[<inline-instance-nodes>
|
||||||
[node ;; generated by the first pass
|
[node ;; from ;; generated by the first pass
|
||||||
(name #:placeholder node) ;; new type
|
(name #:placeholder node) ;; to ;; new type
|
||||||
(first-pass #:? node)
|
(name/first-step #:? node) ;; pred?
|
||||||
node/extract/mapping] ;; call mapping
|
#;node/extract/mapping
|
||||||
|
(λ _ (error "NIY3"))] ;; fun ;; call mapping
|
||||||
…]
|
…]
|
||||||
|
|
||||||
@subsection{Inlining types}
|
@subsection{Inlining types}
|
||||||
|
|
@ -385,7 +390,8 @@ Which is equivalent to:
|
||||||
(first-pass m-3)
|
(first-pass m-3)
|
||||||
#:or some-abritrary-type-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[|<example (V (~> 1) (~> 2) …) generated >|
|
@chunk[|<example (V (~> 1) (~> 2) …) generated >|
|
||||||
(λ ([v : (V (first-pass m-1)
|
(λ ([v : (V (first-pass m-1)
|
||||||
|
|
@ -518,20 +524,21 @@ encapsulating the result types of mappings.
|
||||||
"meta-struct.rkt"; debug
|
"meta-struct.rkt"; debug
|
||||||
racket/stxparam
|
racket/stxparam
|
||||||
racket/splicing)
|
racket/splicing)
|
||||||
(provide define-graph/rich-return); ~>)
|
(provide define-graph/rich-return
|
||||||
|
(for-syntax dbg) ;; DEBUG
|
||||||
|
); ~>)
|
||||||
|
|
||||||
;(define-syntax-parameter ~> (make-rename-transformer #'threading:~>))
|
;(define-syntax-parameter ~> (make-rename-transformer #'threading:~>))
|
||||||
|
|
||||||
(require (for-syntax racket/pretty))
|
(require (for-syntax racket/pretty))
|
||||||
|
|
||||||
;<pass-2-mapping-body>
|
|
||||||
(begin-for-syntax
|
(begin-for-syntax
|
||||||
(define-syntax-rule (dbg log . body)
|
(define-syntax-rule (dbg log . body)
|
||||||
(begin
|
(begin
|
||||||
(display ">>> ")(displayln (list . log))
|
(display ">>> ")(displayln (list . log))
|
||||||
(let ((res (let () . body)))
|
(let ((res (let () . body)))
|
||||||
(display "<<< ")(displayln (list . log))
|
(display "<<< ")(displayln (list . log))
|
||||||
(display "<<<= ")(displayln res)
|
(display "<<<= ")(display (car (list . log)))(displayln res)
|
||||||
res))))
|
res))))
|
||||||
<graph-rich-return>)]
|
<graph-rich-return>)]
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -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
|
;; so we should wrap the nodes in a tag, which contains a
|
||||||
;; promise, instead of the opposite (tag inside promise).
|
;; promise, instead of the opposite (tag inside promise).
|
||||||
[(_ #:? (~datum node))
|
[(_ #:? (~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)
|
[(_ . rest)
|
||||||
(syntax/loc stx (root/constructor . 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.
|
that node's @tc[with-promises] type.
|
||||||
|
|
||||||
@CHUNK[<define-promise-type/first-step>
|
@CHUNK[<define-promise-type/first-step>
|
||||||
(define-constructor node/promise-type #:private
|
(define-constructor node/promise-type
|
||||||
|
#:private
|
||||||
|
#:? node?
|
||||||
(Promise node/with-promises))]
|
(Promise node/with-promises))]
|
||||||
@CHUNK[<define-with-promises>
|
@CHUNK[<define-with-promises>
|
||||||
(define-plain-structure node/with-promises
|
(define-plain-structure node/with-promises
|
||||||
|
|
@ -750,8 +753,8 @@ via @tc[(g Street)].
|
||||||
(λ (stx)
|
(λ (stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ (~datum node)) #'node/promise-type] …
|
[(_ (~datum node)) #'node/promise-type] …
|
||||||
[(_ (~datum node) (~datum field))
|
;[(_ (~datum node) (~datum field))
|
||||||
(template <field/with-promises-type>)] … …
|
; (template <field/with-promises-type>)] … …
|
||||||
[(_ #:incomplete (~datum node)) #'node/incomplete-type] …
|
[(_ #:incomplete (~datum node)) #'node/incomplete-type] …
|
||||||
[(_ #:make-incomplete (~datum node))
|
[(_ #:make-incomplete (~datum node))
|
||||||
#'(→ field/incomplete-type … node/incomplete-type)] …
|
#'(→ field/incomplete-type … node/incomplete-type)] …
|
||||||
|
|
|
||||||
|
|
@ -168,3 +168,7 @@
|
||||||
(constructor . structure)
|
(constructor . structure)
|
||||||
(constructor . wstructure)
|
(constructor . wstructure)
|
||||||
(constructor . wstructure)
|
(constructor . wstructure)
|
||||||
|
(constructor . m-streets5/node)
|
||||||
|
(constructor . tabc)
|
||||||
|
(constructor . t)
|
||||||
|
(constructor . t)
|
||||||
|
|
|
||||||
|
|
@ -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.
|
calls itself on the components of the type.
|
||||||
|
|
||||||
@CHUNK[<replace-in-type>
|
@CHUNK[<replace-in-type>
|
||||||
(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 (recursive-replace new-t) (replace-in-type new-t r))
|
||||||
(define/with-syntax ([from to] ...) r)
|
(define/with-syntax ([from to] ...) r)
|
||||||
#;(displayln (format "~a\n=> ~a"
|
#;(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.
|
offloaded to a separate subroutine.
|
||||||
|
|
||||||
@CHUNK[<replace-in-instance>
|
@CHUNK[<replace-in-instance>
|
||||||
(define-for-syntax (replace-in-instance val t r)
|
(define (replace-in-instance val t r)
|
||||||
(parameterize-push-stx ([current-replacement
|
(parameterize-push-stx ([current-replacement
|
||||||
`(replace-in-instance ,val ,t ,r)])
|
`(replace-in-instance ,val ,t ,r)])
|
||||||
(define/with-syntax ([from to fun] ...) r)
|
(define/with-syntax ([from to fun] ...) r)
|
||||||
|
|
@ -401,7 +401,7 @@ functions is undefined.
|
||||||
@subsection{The code}
|
@subsection{The code}
|
||||||
|
|
||||||
@CHUNK[<fold-instance>
|
@CHUNK[<fold-instance>
|
||||||
(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
|
(parameterize-push-stx ([current-replacement
|
||||||
`(fold-instance ,whole-type ,stx-acc-type ,r)])
|
`(fold-instance ,whole-type ,stx-acc-type ,r)])
|
||||||
(define/with-syntax acc-type stx-acc-type)
|
(define/with-syntax acc-type stx-acc-type)
|
||||||
|
|
@ -593,7 +593,7 @@ better consistency between the behaviour of @tc[replace-in-instance] and
|
||||||
efficient than the separate implementation.
|
efficient than the separate implementation.
|
||||||
|
|
||||||
@CHUNK[<replace-in-instance2>
|
@CHUNK[<replace-in-instance2>
|
||||||
(define-for-syntax (replace-in-instance2 t r)
|
(define replace-in-instance2 (lambda/debug (t r)
|
||||||
(define/with-syntax ([from to pred? fun] ...) r)
|
(define/with-syntax ([from to pred? fun] ...) r)
|
||||||
#`(λ ([val : #,(expand-type t)])
|
#`(λ ([val : #,(expand-type t)])
|
||||||
(first-value
|
(first-value
|
||||||
|
|
@ -603,7 +603,7 @@ efficient than the separate implementation.
|
||||||
(values (fun x) acc))]
|
(values (fun x) acc))]
|
||||||
...))
|
...))
|
||||||
val
|
val
|
||||||
(void)))))]
|
(void))))))]
|
||||||
|
|
||||||
@section{Conclusion}
|
@section{Conclusion}
|
||||||
|
|
||||||
|
|
@ -654,9 +654,9 @@ These metafunctions just extract the arguments for @tc[replace-in-type] and
|
||||||
|
|
||||||
@CHUNK[<*>
|
@CHUNK[<*>
|
||||||
(begin
|
(begin
|
||||||
(module main typed/racket
|
(module main racket/base
|
||||||
(require
|
(require
|
||||||
(for-syntax syntax/parse
|
syntax/parse
|
||||||
racket/syntax
|
racket/syntax
|
||||||
racket/format
|
racket/format
|
||||||
syntax/parse/experimental/template
|
syntax/parse/experimental/template
|
||||||
|
|
@ -665,39 +665,44 @@ These metafunctions just extract the arguments for @tc[replace-in-type] and
|
||||||
(only-in "../type-expander/type-expander.lp2.rkt"
|
(only-in "../type-expander/type-expander.lp2.rkt"
|
||||||
expand-type)
|
expand-type)
|
||||||
"meta-struct.rkt"
|
"meta-struct.rkt"
|
||||||
"../lib/low/backtrace.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/multi-id.lp2.rkt"
|
||||||
"../type-expander/type-expander.lp2.rkt"
|
"../type-expander/type-expander.lp2.rkt"
|
||||||
"../lib/low.rkt")
|
"../lib/low.rkt"))
|
||||||
(begin-for-syntax (provide replace-in-type
|
(provide replace-in-type
|
||||||
;replace-in-instance
|
;replace-in-instance
|
||||||
fold-instance
|
fold-instance
|
||||||
(rename-out [replace-in-instance2
|
(rename-out [replace-in-instance2
|
||||||
replace-in-instance])
|
replace-in-instance])
|
||||||
tmpl-replace-in-type
|
tmpl-replace-in-type
|
||||||
tmpl-fold-instance
|
tmpl-fold-instance
|
||||||
tmpl-replace-in-instance))
|
tmpl-replace-in-instance)
|
||||||
|
|
||||||
|
|
||||||
(begin-for-syntax
|
|
||||||
(define current-replacement (make-parameter #'()))
|
(define current-replacement (make-parameter #'()))
|
||||||
;; TODO: move to lib
|
;; TODO: move to lib
|
||||||
(require (for-syntax racket/base))
|
(require (for-syntax racket/base))
|
||||||
(define-syntax-rule (parameterize-push ([p val] ...) . body)
|
(define-syntax-rule (parameterize-push ([p val] ...) . body)
|
||||||
(parameterize ([p (cons val (p))] ...) . body))
|
(parameterize ([p (cons val (p))] ...) . body))
|
||||||
(define-syntax-rule (parameterize-push-stx ([p val] ...) . body)
|
(define-syntax-rule (parameterize-push-stx ([p val] ...) . body)
|
||||||
(parameterize ([p #`(#,val . #,(p))] ...) . body)))
|
(parameterize ([p #`(#,val . #,(p))] ...) . body))
|
||||||
|
|
||||||
<replace-in-type>
|
<replace-in-type>
|
||||||
<replace-in-instance>
|
<replace-in-instance>
|
||||||
<replace-in-instance2>
|
<replace-in-instance2>
|
||||||
<fold-instance>
|
<fold-instance>
|
||||||
(begin-for-syntax <template-metafunctions>))
|
<template-metafunctions>)
|
||||||
|
|
||||||
(require 'main)
|
(require 'main)
|
||||||
(provide (all-from-out 'main))
|
(provide (all-from-out 'main))
|
||||||
|
|
||||||
(module* test typed/racket
|
(module* test typed/racket
|
||||||
(require (submod "..")
|
(require (for-syntax (submod ".."))
|
||||||
typed/rackunit
|
typed/rackunit
|
||||||
"../type-expander/multi-id.lp2.rkt"
|
"../type-expander/multi-id.lp2.rkt"
|
||||||
"../type-expander/type-expander.lp2.rkt")
|
"../type-expander/type-expander.lp2.rkt")
|
||||||
|
|
|
||||||
|
|
@ -38,7 +38,7 @@ new type.
|
||||||
to the new type, using the provided replacement functions
|
to the new type, using the provided replacement functions
|
||||||
for each part.}
|
for each part.}
|
||||||
|
|
||||||
@defform[#:kind "function"
|
@defform[#:kind "procedure"
|
||||||
(replace-in-type old-type #'([from to] …))
|
(replace-in-type old-type #'([from to] …))
|
||||||
#:contracts ([old-type type]
|
#:contracts ([old-type type]
|
||||||
[from identifier?]
|
[from identifier?]
|
||||||
|
|
@ -47,7 +47,7 @@ new type.
|
||||||
@racket[old-type], with all occurrences of @racket[from]
|
@racket[old-type], with all occurrences of @racket[from]
|
||||||
replaced with @racket[to] in the type.}
|
replaced with @racket[to] in the type.}
|
||||||
|
|
||||||
@defform[#:kind "function"
|
@defform[#:kind "procedure"
|
||||||
(replace-in-instance old-type #'([from to pred? fun] …))
|
(replace-in-instance old-type #'([from to pred? fun] …))
|
||||||
#:contracts ([old-type type]
|
#:contracts ([old-type type]
|
||||||
[from identifier?]
|
[from identifier?]
|
||||||
|
|
|
||||||
|
|
@ -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
|
A call to @tc[(structure)] with no field, is ambiguous: it could return a
|
||||||
constructor function, or an instance. We added two optional keywords,
|
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
|
when fields with or without values are provided, so that macros don't need to
|
||||||
handle the empty structure as a special case.
|
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
|
(define-splicing-syntax-class structure-args-stx-class
|
||||||
(pattern
|
(pattern
|
||||||
(~or (~seq #:instance (~parse (field … value …) #'()))
|
(~or (~seq #:instance (~parse (field … value …) #'()))
|
||||||
(~seq #:constructor (~parse (field …) #'()))
|
(~seq #:make-instance (~parse (field …) #'()))
|
||||||
(~seq (~maybe #:constructor ~!)
|
(~seq (~maybe #:make-instance ~!)
|
||||||
(~or (~seq (~or-bug [field:id] field:id) …+)
|
(~or (~seq (~or-bug [field:id] field:id) …+)
|
||||||
(~seq [field:id (~and C :colon) type:expr] …+)))
|
(~seq [field:id (~and C :colon) type:expr] …+)))
|
||||||
(~seq (~maybe #:instance ~!)
|
(~seq (~maybe #:instance ~!)
|
||||||
|
|
@ -51,8 +51,8 @@ handle the empty structure as a special case.
|
||||||
(begin-for-syntax <structure-args-stx-class>)
|
(begin-for-syntax <structure-args-stx-class>)
|
||||||
|
|
||||||
(define-multi-id structure
|
(define-multi-id structure
|
||||||
#:type-expander structure-type-expander
|
#:type-expander <type-expander>
|
||||||
#:match-expander structure-match-expander
|
#:match-expander <match-expander>
|
||||||
#:call
|
#:call
|
||||||
(λ (stx)
|
(λ (stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
|
|
@ -68,11 +68,11 @@ handle the empty structure as a special case.
|
||||||
(let ()
|
(let ()
|
||||||
(define-structure empty-st)
|
(define-structure empty-st)
|
||||||
(define-structure stA [a Number])
|
(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?: (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?: (empty-st) (stA 1))
|
||||||
(check-not-equal?: (structure #:constructor) (stA 1)))
|
(check-not-equal?: (structure #:make-instance) (stA 1)))
|
||||||
#;(let ()
|
#;(let ()
|
||||||
(define-structure st [a Number] [b String])
|
(define-structure st [a Number] [b String])
|
||||||
(define-structure stA [a Number])
|
(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 ...) #'())))]
|
(pattern field:id #:with (pat ...) #'())))]
|
||||||
|
|
||||||
@chunk[<match-expander>
|
@chunk[<match-expander>
|
||||||
(define-for-syntax (structure-match-expander stx)
|
(λ/syntax-parse (_ :match-field-or-field-pat ...)
|
||||||
(syntax-parse stx
|
|
||||||
[(_ :match-field-or-field-pat ...)
|
|
||||||
(if (check-remember-fields #'(field ...))
|
(if (check-remember-fields #'(field ...))
|
||||||
(let ()
|
(let ()
|
||||||
(define/with-syntax name (fields→stx-name #'(field ...)))
|
(define/with-syntax name (fields→stx-name #'(field ...)))
|
||||||
(define/with-syntax ([sorted-field sorted-pat ...] ...)
|
(define/with-syntax ([sorted-field sorted-pat ...] ...)
|
||||||
(sort-car-fields #'((field pat ...) ...)))
|
(sort-car-fields #'((field pat ...) ...)))
|
||||||
#'(name (and sorted-field sorted-pat ...) ...))
|
#'(name (and sorted-field sorted-pat ...) ...))
|
||||||
<match-expander-remember-error>)]))]
|
<match-expander-remember-error>))]
|
||||||
|
|
||||||
If we just return @racket[(remember-all-errors list stx #'(field ...))] when a
|
If we just return @racket[(remember-all-errors list stx #'(field ...))] when a
|
||||||
recompilation is needed, then the identifier @tc[delayed-error-please-recompile]
|
recompilation is needed, then the identifier @tc[delayed-error-please-recompile]
|
||||||
|
|
@ -506,7 +504,7 @@ instead of needing an extra recompilation.
|
||||||
@subsection{Type-expander}
|
@subsection{Type-expander}
|
||||||
|
|
||||||
@CHUNK[<type-expander>
|
@CHUNK[<type-expander>
|
||||||
(define-for-syntax (structure-type-expander stx)
|
(λ (stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ (~or-bug [field:id] field:id) …)
|
[(_ (~or-bug [field:id] field:id) …)
|
||||||
(if (check-remember-fields #'(field ...))
|
(if (check-remember-fields #'(field ...))
|
||||||
|
|
@ -595,8 +593,6 @@ its arguments across compilations, and adds them to the file
|
||||||
<syntax-class-for-match>
|
<syntax-class-for-match>
|
||||||
<structure-supertype>
|
<structure-supertype>
|
||||||
<structure-supertype*>
|
<structure-supertype*>
|
||||||
<match-expander>
|
|
||||||
<type-expander>
|
|
||||||
|
|
||||||
<structure?>
|
<structure?>
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -108,10 +108,11 @@ for a structure.
|
||||||
@CHUNK[<tagged?>
|
@CHUNK[<tagged?>
|
||||||
(define-syntax/parse (tagged? tag (~maybe #:with-struct with-struct)
|
(define-syntax/parse (tagged? tag (~maybe #:with-struct with-struct)
|
||||||
field …)
|
field …)
|
||||||
#'(λ (v) (and (constructor? tag (?? (?@ #:with-struct with-struct)) v)
|
(template
|
||||||
|
(λ (v) (and (constructor? tag (?? (?@ #:with-struct with-struct)) v)
|
||||||
(promise? (constructor-values v))
|
(promise? (constructor-values v))
|
||||||
((structure? field …)
|
((structure? field …)
|
||||||
(force (constructor-values v))))))]
|
(force (constructor-values v)))))))]
|
||||||
|
|
||||||
@section{Tests}
|
@section{Tests}
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -4,8 +4,7 @@
|
||||||
(require (submod "graph.lp2.rkt" test))
|
(require (submod "graph.lp2.rkt" test))
|
||||||
(require "get.lp2.rkt")
|
(require "get.lp2.rkt")
|
||||||
(require "map.rkt")
|
(require "map.rkt")
|
||||||
(require "structure.lp2.rkt")
|
(require "adt.lp2.rkt")
|
||||||
(require "variant.lp2.rkt")
|
|
||||||
(require "../lib/low.rkt")
|
(require "../lib/low.rkt")
|
||||||
(require "../type-expander/type-expander.lp2.rkt")
|
(require "../type-expander/type-expander.lp2.rkt")
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -25,6 +25,8 @@
|
||||||
~or-bug
|
~or-bug
|
||||||
define-simple-macro
|
define-simple-macro
|
||||||
λstx
|
λstx
|
||||||
|
;template/loc
|
||||||
|
;quasitemplate/loc
|
||||||
template/debug
|
template/debug
|
||||||
quasitemplate/debug
|
quasitemplate/debug
|
||||||
meta-eval)
|
meta-eval)
|
||||||
|
|
@ -134,6 +136,16 @@
|
||||||
(check-equal? (syntax->datum ((λstx (foo bar) #'(foo bar)) #'a #'b))
|
(check-equal? (syntax->datum ((λstx (foo bar) #'(foo bar)) #'a #'b))
|
||||||
(syntax->datum #'(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
|
;; template/debug
|
||||||
(begin
|
(begin
|
||||||
(define-syntax (template/debug stx)
|
(define-syntax (template/debug stx)
|
||||||
|
|
|
||||||
|
|
@ -6,7 +6,7 @@
|
||||||
|
|
||||||
;(current-directory "..")
|
;(current-directory "..")
|
||||||
|
|
||||||
(run! (list (find-executable-path-or-fail "sh")
|
#;(run! (list (find-executable-path-or-fail "sh")
|
||||||
"-c"
|
"-c"
|
||||||
@string-append{
|
@string-append{
|
||||||
found_long_lines=0
|
found_long_lines=0
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user