suzanne.soy/scribble-enhanced
1
0
Fork 0
Code Issues 1 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

Fixed bug due to improper implementation of #:?, FB case #107.

Browse Source
This commit is contained in:
Georges Dupéron 2016-03-22 13:33:45 +01:00
parent 4d73b476d3
commit 3516d1aac8
15 changed files with 523 additions and 151 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
graph-lib/graph/__.rkt.tmp Normal file
View 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) …])]

162
graph-lib/graph/__DEBUG_graph6.rkt
View File

@ -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)))))))

150
graph-lib/graph/__DEBUG_graph6_B.rkt Normal file
View 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)))))))

1
graph-lib/graph/adt.lp2.rkt
View File

@ -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

3
graph-lib/graph/constructor.lp2.rkt
View File

@ -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))]

133
graph-lib/graph/graph-6-rich-returns.lp2.rkt
View File

@ -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 [<first-pass-type-expander>]
[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[<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
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
to @tc[replace-in-instance]) expands to the temporary marker
@ -207,30 +178,46 @@ produced by the first step.
@chunk[<second-step-marker-expander>
;; 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[<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}
The result of recursively inlining the temporary mapping nodes may be a
@ -279,7 +266,8 @@ in all of its fields:
@chunk[<inlined-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}
@ -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[<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)
(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
#'(<inline-instance-replacement>
<inline-instance-nodes>)))
(displayln (list "i-t=" #'typp))
<inline-check-seen>
(replace-in-instance #'(Let (id-~> second-step-marker-expander) i-t)
#'(<inline-instance-replacement>
<inline-instance-nodes>))])))]
#'(λ ([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-nodes>))])))]
@chunk[<inline-instance-replacement>
[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[<inline-instance-nodes>
[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[|<example (V (~> 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))
;<pass-2-mapping-body>
(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))))
<graph-rich-return>)]

11
graph-lib/graph/graph.lp2.rkt
View File

@ -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-promise-type/first-step>
(define-constructor node/promise-type #:private
(define-constructor node/promise-type
#:private
#:? node?
(Promise node/with-promises))]
@CHUNK[<define-with-promises>
(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 <field/with-promises-type>)] … …
;[(_ (~datum node) (~datum field))
; (template <field/with-promises-type>)] … …
[(_ #:incomplete (~datum node)) #'node/incomplete-type] …
[(_ #:make-incomplete (~datum node))
#'(→ field/incomplete-type … node/incomplete-type)] …

4
graph-lib/graph/remember.rkt
View File

@ -168,3 +168,7 @@
(constructor . structure)
(constructor . wstructure)
(constructor . wstructure)
(constructor . m-streets5/node)
(constructor . tabc)
(constructor . t)
(constructor . t)

109
graph-lib/graph/rewrite-type.lp2.rkt
View File

@ -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[<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/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[<replace-in-instance>
(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[<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
`(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[<replace-in-instance2>
(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))
<replace-in-type>
<replace-in-instance>
<replace-in-instance2>
<fold-instance>
(begin-for-syntax <template-metafunctions>))
<template-metafunctions>)
(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")

4
graph-lib/graph/rewrite-type.scrbl
View File

@ -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?]

40
graph-lib/graph/structure.lp2.rkt
View File

@ -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 <structure-args-stx-class>)
(define-multi-id structure
#:type-expander structure-type-expander
#:match-expander structure-match-expander
#:type-expander <type-expander>
#:match-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[<match-expander>
(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 ...) ...))
<match-expander-remember-error>)]))]
(λ/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 ...) ...))
<match-expander-remember-error>))]
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[<type-expander>
(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))
<structure-top>
<check-remember-fields>
@ -595,8 +593,6 @@ its arguments across compilations, and adds them to the file
<syntax-class-for-match>
<structure-supertype>
<structure-supertype*>
<match-expander>
<type-expander>
<structure?>

9
graph-lib/graph/tagged.lp2.rkt
View File

@ -108,10 +108,11 @@ for a structure.
@CHUNK[<tagged?>
(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}

3
graph-lib/graph/test-map-get.rkt
View File

@ -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")

12
graph-lib/lib/low/syntax-parse.rkt
View File

@ -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)

2
graph-lib/make/make.rkt
View File

@ -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