Fixed compilation errors.
This commit is contained in:
Georges Dupéron
parent
c905501b70
commit
6324e1862b
1
graph-lib/.gitignore
vendored
1
graph-lib/.gitignore
vendored
|
|
@ -4,3 +4,4 @@
|
|||
/docs/
|
||||
*~
|
||||
compiled
|
||||
/build/
|
||||
|
|
@ -41,17 +41,17 @@
|
|||
#'(b (d (dgX n) . r) (dgX n2)))]))
|
||||
|
||||
(super-define-graph/rich-return
|
||||
grr3
|
||||
([City [streets : (~> m-streets)]]
|
||||
[Street [sname : String]])
|
||||
[(m-cities [cnames : (Listof (Listof bubble))])
|
||||
: (Listof City)
|
||||
(define (strings→city [s : (Listof blob)])
|
||||
(City (m-streets s)))
|
||||
(map strings→city cnames)]
|
||||
[(m-streets [snames : (Listof String)])
|
||||
: (Listof Street)
|
||||
(map Street snames)])
|
||||
grr3
|
||||
([City [streets : (~> m-streets)]]
|
||||
[Street [sname : String]])
|
||||
[(m-cities [cnames : (Listof (Listof bubble))])
|
||||
: (Listof City)
|
||||
(define (strings→city [s : (Listof blob)])
|
||||
(City (m-streets s)))
|
||||
(map strings→city cnames)]
|
||||
[(m-streets [snames : (Listof String)])
|
||||
: (Listof Street)
|
||||
(map Street snames)])
|
||||
|
||||
;(grr3 '(("a" "b") ("c")))
|
||||
|
||||
|
|
@ -98,153 +98,176 @@
|
|||
|
||||
;; 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)
|
||||
"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)))))))
|
||||
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 second-step-City18-of-first (grr31/first-step City))
|
||||
(define-type second-step-Street19-of-first (grr31/first-step Street))
|
||||
(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-tyy (~and seen (:id …)))
|
||||
(define/with-syntax replt (replace-in-type #'(Let (~> second-step-marker2-expander) i-tyy) #'((City second-step-City18-of-first) (Street second-step-Street19-of-first))))
|
||||
#'(inline-type replt seen)))))
|
||||
(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)))
|
||||
(second-step-City18-of-first (grr3 #:placeholder City))
|
||||
(second-step-Street19-of-first (grr3 #:placeholder Street))))))))
|
||||
(define-syntax (inline-instance* stx)
|
||||
(dbg
|
||||
("inline-instance*" stx)
|
||||
(syntax-parse
|
||||
stx
|
||||
((_ i-ty seen)
|
||||
(define/with-syntax replt (replace-in-type #'(Let (~> second-step-marker2-expander) i-ty) #'((City second-step-City18-of-first) (Street second-step-Street19-of-first))))
|
||||
(displayln (list "replt=" #'replt))
|
||||
#'(inline-instance replt seen)))))
|
||||
(define-syntax (inline-instance stx)
|
||||
(dbg
|
||||
("inline-instance" stx)
|
||||
(syntax-parse
|
||||
stx
|
||||
((_ i-t (~and seen (:id …)))
|
||||
(define/with-syntax typp #'i-t)
|
||||
(define/with-syntax
|
||||
repl
|
||||
(replace-in-instance
|
||||
#'typp
|
||||
#'((second-step-m-cities16/node-of-first (inline-type* (Listof City) (m-cities4/node . seen)) (grr31/first-step #:? m-cities4/node) (inline-instance* (Listof City) (m-cities4/node . seen)))
|
||||
(second-step-m-streets17/node-of-first (inline-type* (Listof Street) (m-streets5/node . seen)) (grr31/first-step #:? m-streets5/node) (inline-instance* (Listof Street) (m-streets5/node . seen)))
|
||||
(second-step-City18-of-first (grr3 #:placeholder City) (grr31/first-step #:? City) City6/extract/mapping)
|
||||
(second-step-Street19-of-first (grr3 #:placeholder Street) (grr31/first-step #:? Street) Street7/extract/mapping))))
|
||||
(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 : 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))
|
||||
#;((inline-instance
|
||||
(U
|
||||
second-step-m-streets17/node-of-first
|
||||
(Listof
|
||||
grr31/first-step:Street2/promise-type))
|
||||
())
|
||||
(get from streets))
|
||||
((λ ((x : (U second-step-m-streets17/node-of-first (Listof (grr31/first-step Street)))))
|
||||
(λ ((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 (inline-type* (Listof Street) (m-streets5/node)) (Listof (grr31/first-step Street))) Void)
|
||||
(cond
|
||||
(((grr31/first-step #:? m-streets5/node) val)
|
||||
((ann
|
||||
(λ ((x : second-step-m-streets17/node-of-first) (acc : Void)) (values ((inline-instance* (Listof Street) (m-streets5/node)) (get x returned)) acc))
|
||||
(→ second-step-m-streets17/node-of-first Void (values (inline-type* (Listof Street) (m-streets5/node)) 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
|
||||
(U second-step-m-streets17/node-of-first (Listof (grr31/first-step Street)))
|
||||
"Unhandled union case in (U second-step-m-streets17/node-of-first (Listof (grr31/first-step Street))),"
|
||||
#;" whole type was:(U second-step-m-streets17/node-of-first (Listof (grr31/first-step Street)))"))))
|
||||
val
|
||||
(void))))
|
||||
(error "NIY2"))
|
||||
(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,150 +0,0 @@
|
|||
#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)))))))
|
||||
|
|
@ -119,26 +119,27 @@ plain list.
|
|||
(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-temp-ids "second-step-~a-of-first" (node …))
|
||||
;(define step2-introducer (make-syntax-introducer))
|
||||
;(define/with-syntax id-~> (datum->syntax #'name '~>))
|
||||
;(define/with-syntax introduced-~> (datum->syntax #'name '~>))
|
||||
(quasitemplate/debug debug
|
||||
(begin
|
||||
#,(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] …)
|
||||
;<first-pass-field-type>] …)
|
||||
(node field …)]] …
|
||||
[mapping/node [returned cm result-type]
|
||||
[(mapping [param cp param-type] …)
|
||||
(mapping/node
|
||||
(let ([node node/simple-mapping] …)
|
||||
. body))]]
|
||||
…)))
|
||||
("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] …)
|
||||
;<first-pass-field-type>] …)
|
||||
(node field …)]] …
|
||||
[mapping/node [returned cm result-type]
|
||||
[(mapping [param cp param-type] …)
|
||||
(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).
|
||||
|
|
@ -205,13 +206,18 @@ produced by the first step.
|
|||
(name/first-step mapping/node))
|
||||
…
|
||||
|
||||
(define-type second-step-node-of-first
|
||||
(name/first-step 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)]))] …
|
||||
[node (name/first-step node)]))]
|
||||
…
|
||||
;; TODO: should fall-back to outer definition of ~>, if any?
|
||||
))]
|
||||
|
||||
|
|
@ -266,8 +272,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}
|
||||
|
|
@ -280,41 +286,52 @@ recursively:
|
|||
(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-ty seen)
|
||||
(define/with-syntax replt
|
||||
(replace-in-type #'(Let (id-~> second-step-marker2-expander) i-ty)
|
||||
#'([node second-step-node-of-first]
|
||||
…)))
|
||||
(displayln (list "replt=" #'replt))
|
||||
#'(inline-instance replt seen)])))
|
||||
|
||||
(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 typp #'i-t)
|
||||
(define/with-syntax repl (replace-in-instance #'typp
|
||||
#'(<inline-instance-replacement>
|
||||
<inline-instance-nodes>)))
|
||||
(displayln (list "i-t=" #'typp))
|
||||
<inline-check-seen>
|
||||
#'(λ ([x : (Let (id-~> second-step-marker2-expander) i-t)])
|
||||
#'(λ ([x : i-t])
|
||||
;(
|
||||
repl
|
||||
;x)
|
||||
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>
|
||||
[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
|
||||
[second-step-mapping/node-of-first ;; from
|
||||
(inline-type* result-type (mapping/node . seen)) ;; to
|
||||
(name/first-step #:? mapping/node) ;; pred?
|
||||
(λ ([x : second-step-mapping/node-of-first]) ;; fun
|
||||
((inline-instance* result-type (mapping/node . seen))
|
||||
(get x returned)))]
|
||||
…]
|
||||
|
||||
@chunk[<inline-instance-nodes>
|
||||
[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
|
||||
[second-step-node-of-first ;; node of first step ;; from
|
||||
(name #:placeholder node) ;; new type ;; to
|
||||
(name/first-step #:? node) ;; pred?
|
||||
node/extract/mapping] ;; call mapping ;; fun
|
||||
…]
|
||||
|
||||
@subsection{Inlining types}
|
||||
|
|
@ -429,13 +446,24 @@ which does not allow variants of (~> …).
|
|||
----
|
||||
|
||||
@chunk[<inline-type>
|
||||
(define-type-expander (inline-type* stx)
|
||||
(dbg
|
||||
("inline-type" stx)
|
||||
(syntax-parse stx
|
||||
[(_ i-tyy (~and seen (:id (… …))))
|
||||
(define/with-syntax replt
|
||||
;; Same as above in inline-instance*, TODO: factor it out.
|
||||
(replace-in-type #'(Let (id-~> second-step-marker2-expander) i-tyy)
|
||||
#'([node second-step-node-of-first]
|
||||
…)))
|
||||
#'(inline-type replt seen)])))
|
||||
(define-type-expander (inline-type stx)
|
||||
(dbg
|
||||
("inline-type" stx)
|
||||
(syntax-parse stx
|
||||
[(_ i-t (~and seen (:id (… …))))
|
||||
<inline-check-seen>
|
||||
(replace-in-type #'(Let (id-~> second-step-marker-expander) i-t)
|
||||
(replace-in-type #'(Let ([id-~> second-step-marker-expander]) i-t)
|
||||
#'(<inline-type-replacement>
|
||||
<inline-type-nodes>))])))]
|
||||
|
||||
|
|
@ -446,7 +474,7 @@ which does not allow variants of (~> …).
|
|||
…]
|
||||
|
||||
@chunk[<inline-type-nodes>
|
||||
[node ;; generated by the first pass
|
||||
[second-step-node-of-first ;; generated by the first pass
|
||||
(name #:placeholder node)] ;; new type
|
||||
…]
|
||||
|
||||
|
|
|
|||
|
|
@ -212,7 +212,7 @@ We derive identifiers for these based on the @tc[node] name:
|
|||
|
||||
(define-temp-ids "~a/promise-type" (node …) #:prefix #'name)
|
||||
(define-temp-ids "~a/constructor" (node …) #:first-base root
|
||||
#:prefix #'name)
|
||||
#:prefix #'name)
|
||||
(define-temp-ids "~a?" (node …) #:prefix #'name)
|
||||
|
||||
(define-temp-ids "~a/make-placeholder" (node …) #:prefix #'name)
|
||||
|
|
@ -313,8 +313,7 @@ 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))
|
||||
((λ (v) (display "graph node?")(displayln v) v)
|
||||
(syntax/loc stx node?))] ;;;;;;;;;;;;;;;TODO: implement node? properly here! FB case 107
|
||||
(syntax/loc stx node?)] ;;;;;;;;;;;;;;;TODO: implement node? properly here! FB case 107
|
||||
…
|
||||
[(_ . rest)
|
||||
(syntax/loc stx (root/constructor . rest))]))
|
||||
|
|
|
|||
|
|
@ -846,8 +846,7 @@ checker, unless it is absorbed by a larger type, like in
|
|||
(prefix-in DEBUG-tr: typed/racket)
|
||||
syntax/parse
|
||||
"../lib/low.rkt"
|
||||
"structure.lp2.rkt"
|
||||
"variant.lp2.rkt"
|
||||
"adt.lp2.rkt"
|
||||
"../type-expander/multi-id.lp2.rkt"
|
||||
"../type-expander/type-expander.lp2.rkt")
|
||||
(provide make-graph-constructor
|
||||
|
|
@ -873,8 +872,7 @@ checker, unless it is absorbed by a larger type, like in
|
|||
<pre-declare-transform/link-request>
|
||||
(require syntax/parse
|
||||
"../lib/low.rkt"
|
||||
"structure.lp2.rkt"
|
||||
"variant.lp2.rkt"
|
||||
"adt.lp2.rkt"
|
||||
"../type-expander/multi-id.lp2.rkt"
|
||||
"../type-expander/type-expander.lp2.rkt")
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -172,3 +172,7 @@
|
|||
(constructor . tabc)
|
||||
(constructor . t)
|
||||
(constructor . t)
|
||||
(constructor . ma/incomplete)
|
||||
(constructor . mb/incomplete)
|
||||
(constructor . ma/incomplete)
|
||||
(constructor . ma/incomplete)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
#lang debug scribble/lp2
|
||||
#lang scribble/lp2
|
||||
@(require "../lib/doc.rkt")
|
||||
@doc-lib-setup
|
||||
@(require racket/format)
|
||||
|
|
@ -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 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))))))]
|
||||
(define (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)))))]
|
||||
|
||||
@section{Conclusion}
|
||||
|
||||
|
|
@ -618,12 +618,12 @@ one for @tc[replace-in-type]:
|
|||
(parameterize-push-stx ([current-replacement stx])
|
||||
(syntax-parse stx
|
||||
#:context `(tmpl-replace-in-type-6 ,(current-replacement))
|
||||
[(_ (~optional (~and debug? #:debug)) type:expr [from to] …)
|
||||
(when (attribute debug?)
|
||||
[(_ (~optkw #:debug) type:expr [from to] …)
|
||||
(when (attribute debug)
|
||||
(displayln (format "~a" stx)))
|
||||
(let ([res #`#,(replace-in-type #'type
|
||||
#'([from to] …))])
|
||||
(when (attribute debug?)
|
||||
(when (attribute debug)
|
||||
(displayln (format "=> ~a" res)))
|
||||
res)])))]
|
||||
|
||||
|
|
@ -666,7 +666,6 @@ These metafunctions just extract the arguments for @tc[replace-in-type] and
|
|||
expand-type)
|
||||
"meta-struct.rkt"
|
||||
"../lib/low/backtrace.rkt"
|
||||
debug
|
||||
racket/require
|
||||
(for-template (subtract-in
|
||||
typed/racket
|
||||
|
|
|
|||
|
|
@ -6,9 +6,21 @@
|
|||
|
||||
;(current-directory "..")
|
||||
|
||||
;; Build a copy, so that changing files midway doesn't break the build.
|
||||
;; Problem: the MathJax directory is huge, and copying it is a pain.
|
||||
#;(begin
|
||||
(make-directory* "build")
|
||||
(run! (list (find-executable-path-or-fail "find")
|
||||
"."
|
||||
"-maxdepth" "1"
|
||||
"!" "-path" "."
|
||||
"!" "-path" "./build"
|
||||
"-exec" "cp" "-af" "{}" "./build/" ";"))
|
||||
(current-directory "build"))
|
||||
|
||||
#;(run! (list (find-executable-path-or-fail "sh")
|
||||
"-c"
|
||||
@string-append{
|
||||
"-c"
|
||||
@string-append{
|
||||
found_long_lines=0
|
||||
for i in `find \
|
||||
\( -path ./lib/doc/bracket -prune -and -false \) \
|
||||
|
|
@ -138,7 +150,7 @@
|
|||
(run! `(,(find-executable-path-or-fail "raco")
|
||||
"make"
|
||||
"-v"
|
||||
"-j" "5"
|
||||
"-j" "3"
|
||||
,@rkt-files))
|
||||
|
||||
;; Create root MathJax link, must be done before the others
|
||||
|
|
|
|||
|
|
@ -161,14 +161,19 @@ else.
|
|||
#,(expand-type #'T (bind-type-vars #'(TVar ...) env)))]
|
||||
[((~literal Rec) R:id T:expr)
|
||||
#`(Rec R #,(expand-type #'T (bind-type-vars #'(R) env)))]
|
||||
[((~commit (~datum Let)) [V:id E:id] T:expr)
|
||||
[((~commit (~datum Let)) bindings T:expr)
|
||||
;; TODO: ~literal instead of ~datum
|
||||
;; TODO: ~commit when we find Let, so that syntax errors are not
|
||||
;; interpreted as an arbitrary call.
|
||||
(syntax-parse #'bindings
|
||||
;; TODO : for now we only allow aliasing (which means E is an id),
|
||||
;; not on-the-fly declaration of type expanders. This would require
|
||||
;; us to (expand) them.
|
||||
#`#,(expand-type #'T (let-type-todo #'V #'E env))]
|
||||
[[V:id E:id] ;; TODO: remove the single-binding clause case in Let
|
||||
#`#,(expand-type #'T (let-type-todo #'V #'E env))]
|
||||
[()
|
||||
#`#,(expand-type #'T env)]
|
||||
[([V₀:id E₀:id] [Vᵢ:id Eᵢ:id] …)
|
||||
#`#,(expand-type #'(Let ([Vᵢ Eᵢ] …) T)
|
||||
(let-type-todo #'V₀ #'E₀ env))])]
|
||||
[((~literal quote) T) (expand-quasiquote 'quote 1 env #'T)]
|
||||
[((~literal quasiquote) T) (expand-quasiquote 'quasiquote 1 env #'T)]
|
||||
[((~literal syntax) T) (expand-quasiquote 'syntax 1 env #'T)]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user