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

Fixed compilation errors.

Browse Source
This commit is contained in:
Georges Dupéron 2016-03-22 16:26:27 +01:00
parent c905501b70
commit 6324e1862b
10 changed files with 292 additions and 373 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
graph-lib/.gitignore vendored
View File

@ -4,3 +4,4 @@
/docs/ /docs/
*~ *~
compiled compiled
/build/

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

@ -121,6 +121,10 @@
"meta-struct.rkt"; debug "meta-struct.rkt"; debug
racket/stxparam racket/stxparam
racket/splicing) racket/splicing)
#;(begin #;(begin
(define-graph (define-graph
grr31/first-step grr31/first-step
@ -140,7 +144,7 @@
(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-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)))))) (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 (define-graph
grr3 grr3
#:definitions #:definitions
((define-type-expander (~>-to-result-type stx) (syntax-parse stx ((_ (~datum m-cities)) #'(Listof City)) ((_ (~datum m-streets)) #'(Listof Street)))) ((define-type-expander (~>-to-result-type stx) (syntax-parse stx ((_ (~datum m-cities)) #'(Listof City)) ((_ (~datum m-streets)) #'(Listof Street))))
@ -149,13 +153,24 @@
(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-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-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-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 (define-type-expander
(second-step-marker2-expander stx) (second-step-marker2-expander stx)
(syntax-parse (syntax-parse
stx stx
((_ (~datum m-cities)) #'(U second-step-m-cities16/node-of-first (Listof (grr31/first-step City)))) ((_ (~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)))))) ((_ (~datum m-streets)) #'(U second-step-m-streets17/node-of-first (Listof (grr31/first-step Street))))))
#;(define-type-expander (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) (inline-type stx)
(dbg (dbg
("inline-type" stx) ("inline-type" stx)
@ -169,26 +184,35 @@
(~a "Cycles in types are not allowed." " The following types were already inlined: " (syntax->datum #'seen) ", but " #'t " appeared a second time.") (~a "Cycles in types are not allowed." " The following types were already inlined: " (syntax->datum #'seen) ", but " #'t " appeared a second time.")
#'t))) #'t)))
(replace-in-type (replace-in-type
#'(Let (~> second-step-marker-expander) i-t) #'(Let ((~> second-step-marker-expander)) i-t)
#'((m-cities10/node-marker (inline-type (Listof City) (m-cities4/node . seen))) #'((m-cities10/node-marker (inline-type (Listof City) (m-cities4/node . seen)))
(m-streets11/node-marker (inline-type (Listof Street) (m-streets5/node . seen))) (m-streets11/node-marker (inline-type (Listof Street) (m-streets5/node . seen)))
(City (grr3 #:placeholder City)) (second-step-City18-of-first (grr3 #:placeholder City))
(Street (grr3 #:placeholder Street)))))))) (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) (define-syntax (inline-instance stx)
(dbg (dbg
("inline-instance" stx) ("inline-instance" stx)
(syntax-parse (syntax-parse
stx stx
((_ i-t (~and seen (:id …))) ((_ i-t (~and seen (:id …)))
(define/with-syntax typp #'(Let (~> second-step-marker2-expander) i-t)) (define/with-syntax typp #'i-t)
(define/with-syntax (define/with-syntax
repl repl
(replace-in-instance (replace-in-instance
#'typp #'typp
#'((second-step-m-cities16/node-of-first Symbol (grr31/first-step #:? m-cities4/node) (λ _ (error "NIY4"))) #'((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 Symbol (grr31/first-step #:? m-streets5/node) (λ _ (error "NIY4"))) (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)))
(City (grr3 #:placeholder City) (grr31/first-step #:? City) (λ _ (error "NIY3"))) (second-step-City18-of-first (grr3 #:placeholder City) (grr31/first-step #:? City) City6/extract/mapping)
(Street (grr3 #:placeholder Street) (grr31/first-step #:? Street) (λ _ (error "NIY3")))))) (second-step-Street19-of-first (grr3 #:placeholder Street) (grr31/first-step #:? Street) Street7/extract/mapping))))
(displayln (list "i-t=" #'typp)) (displayln (list "i-t=" #'typp))
(let ((seen-list (syntax->list #'seen))) (let ((seen-list (syntax->list #'seen)))
(when (and (not (null? seen-list)) (member (car seen-list) (cdr seen-list) free-identifier=?)) (when (and (not (null? seen-list)) (member (car seen-list) (cdr seen-list) free-identifier=?))
@ -196,26 +220,31 @@
'define-graph/rich-returns '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.") (~a "Cycles in types are not allowed." " The following types were already inlined: " (syntax->datum #'seen) ", but " #'t " appeared a second time.")
#'t))) #'t)))
#'(λ ((x : (Let (~> second-step-marker2-expander) i-t))) repl (error "NIY2"))))))) #'(λ ((x : i-t)) repl (error "NIY2")))))))
(City (streets : (Let (~> ~>-to-result-type) (~> m-streets))) (City (streets : (Let (~> ~>-to-result-type) (~> m-streets)))
((City6/extract/mapping (from : (grr31/first-step City))) ((City6/extract/mapping (from : (grr31/first-step City)))
(City (City
;((inline-instance* (~> m-streets) ()) (get from streets))
(;;(inline-instance (~> m-streets) ()) #;((inline-instance
(λ ((x : (Let (~> second-step-marker2-expander) (~> m-streets)))) (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))))) (λ ((val : (U second-step-m-streets17/node-of-first (Listof (grr31/first-step Street)))))
(first-value (first-value
((λ ((val : (U second-step-m-streets17/node-of-first (Listof (grr31/first-step Street)))) (acc : Void)) ((λ ((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) (values (U (inline-type* (Listof Street) (m-streets5/node)) (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 (cond
(((grr31/first-step #:? m-streets5/node) val) (((grr31/first-step #:? m-streets5/node) val)
#;(if (equal? (ann 0 Number) 0) ((ann
(ann val Nothing);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;PROBLEM (λ ((x : second-step-m-streets17/node-of-first) (acc : Void)) (values ((inline-instance* (Listof Street) (m-streets5/node)) (get x returned)) acc))
#f) (→ second-step-m-streets17/node-of-first Void (values (inline-type* (Listof Street) (m-streets5/node)) Void)))
((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)) val
acc))
(#t (#t
((λ ((val : (Listof (grr31/first-step Street))) (acc : Void)) ((λ ((val : (Listof (grr31/first-step Street))) (acc : Void))
: :
@ -231,20 +260,14 @@
acc)) acc))
(else (else
(typecheck-fail (typecheck-fail
(Let (~> second-step-marker2-expander) (~> m-streets)) (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:(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:(U second-step-m-streets17/node-of-first (Listof (grr31/first-step Street)))"))))
val val
(void)))) (void))))
(error "NIY2")) (error "NIY2"))
(get from 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))))))
)
#;((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
View File

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

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

@ -119,6 +119,7 @@ plain list.
(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-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 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 '~>))
@ -205,13 +206,18 @@ produced by the first step.
(name/first-step mapping/node)) (name/first-step mapping/node))
… …
(define-type second-step-node-of-first
(name/first-step node))
…
(define-type-expander (second-step-marker2-expander stx) (define-type-expander (second-step-marker2-expander stx)
(syntax-parse stx (syntax-parse stx
;; TODO: should be ~literal ;; TODO: should be ~literal
[(_ (~datum mapping)) #'(U second-step-mapping/node-of-first [(_ (~datum mapping)) #'(U second-step-mapping/node-of-first
(tmpl-replace-in-type result-type (tmpl-replace-in-type result-type
[mapping/node (name/first-step mapping/node)] [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? ;; TODO: should fall-back to outer definition of ~>, if any?
))] ))]
@ -266,7 +272,7 @@ 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;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (node ((inline-instance* field-type;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
()) (get from field)) ()) (get from field))
…)] …)]
@ -280,18 +286,30 @@ recursively:
(foo bar (U m-street (Listof Street)) baz quux) (foo bar (U m-street (Listof Street)) baz quux)
@CHUNK[<inline-instance> @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) (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 typp #'i-t)
(define/with-syntax repl (replace-in-instance #'typp (define/with-syntax repl (replace-in-instance #'typp
#'(<inline-instance-replacement> #'(<inline-instance-replacement>
<inline-instance-nodes>))) <inline-instance-nodes>)))
(displayln (list "i-t=" #'typp)) (displayln (list "i-t=" #'typp))
<inline-check-seen> <inline-check-seen>
#'(λ ([x : (Let (id-~> second-step-marker2-expander) i-t)]) #'(λ ([x : i-t])
;( ;(
repl repl
;x) ;x)
@ -302,19 +320,18 @@ recursively:
@chunk[<inline-instance-replacement> @chunk[<inline-instance-replacement>
[second-step-mapping/node-of-first ;; from [second-step-mapping/node-of-first ;; from
;(inline-type result-type (mapping/node . seen)) ;; to (inline-type* result-type (mapping/node . seen)) ;; to
Symbol ;; DEBUG
(name/first-step #:? mapping/node) ;; pred? (name/first-step #:? mapping/node) ;; pred?
#;(inline-instance result-type (mapping/node . seen)) (λ ([x : second-step-mapping/node-of-first]) ;; fun
(λ _ (error "NIY4"))] ;; fun ((inline-instance* result-type (mapping/node . seen))
(get x returned)))]
…] …]
@chunk[<inline-instance-nodes> @chunk[<inline-instance-nodes>
[node ;; from ;; generated by the first pass [second-step-node-of-first ;; node of first step ;; from
(name #:placeholder node) ;; to ;; new type (name #:placeholder node) ;; new type ;; to
(name/first-step #:? node) ;; pred? (name/first-step #:? node) ;; pred?
#;node/extract/mapping node/extract/mapping] ;; call mapping ;; fun
(λ _ (error "NIY3"))] ;; fun ;; call mapping
…] …]
@subsection{Inlining types} @subsection{Inlining types}
@ -429,13 +446,24 @@ which does not allow variants of (~> …).
---- ----
@chunk[<inline-type> @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) (define-type-expander (inline-type stx)
(dbg (dbg
("inline-type" stx) ("inline-type" stx)
(syntax-parse stx (syntax-parse stx
[(_ i-t (~and seen (:id (… …)))) [(_ i-t (~and seen (:id (… …))))
<inline-check-seen> <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-replacement>
<inline-type-nodes>))])))] <inline-type-nodes>))])))]
@ -446,7 +474,7 @@ which does not allow variants of (~> …).
…] …]
@chunk[<inline-type-nodes> @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 (name #:placeholder node)] ;; new type
…] …]

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

@ -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 ;; 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))
((λ (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) [(_ . rest)
(syntax/loc stx (root/constructor . rest))])) (syntax/loc stx (root/constructor . rest))]))

6
graph-lib/graph/graph_old.lp2.rkt
View File

@ -846,8 +846,7 @@ checker, unless it is absorbed by a larger type, like in
(prefix-in DEBUG-tr: typed/racket) (prefix-in DEBUG-tr: typed/racket)
syntax/parse syntax/parse
"../lib/low.rkt" "../lib/low.rkt"
"structure.lp2.rkt" "adt.lp2.rkt"
"variant.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")
(provide make-graph-constructor (provide make-graph-constructor
@ -873,8 +872,7 @@ checker, unless it is absorbed by a larger type, like in
<pre-declare-transform/link-request> <pre-declare-transform/link-request>
(require syntax/parse (require syntax/parse
"../lib/low.rkt" "../lib/low.rkt"
"structure.lp2.rkt" "adt.lp2.rkt"
"variant.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")
;; ;;

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

@ -172,3 +172,7 @@
(constructor . tabc) (constructor . tabc)
(constructor . t) (constructor . t)
(constructor . t) (constructor . t)
(constructor . ma/incomplete)
(constructor . mb/incomplete)
(constructor . ma/incomplete)
(constructor . ma/incomplete)

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

@ -1,4 +1,4 @@
#lang debug scribble/lp2 #lang scribble/lp2
@(require "../lib/doc.rkt") @(require "../lib/doc.rkt")
@doc-lib-setup @doc-lib-setup
@(require racket/format) @(require racket/format)
@ -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 replace-in-instance2 (lambda/debug (t r) (define (replace-in-instance2 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
@ -601,9 +601,9 @@ efficient than the separate implementation.
#'Void #'Void
#'([from to pred? (λ ([x : from] [acc : Void]) #'([from to pred? (λ ([x : from] [acc : Void])
(values (fun x) acc))] (values (fun x) acc))]
...)) …))
val val
(void))))))] (void)))))]
@section{Conclusion} @section{Conclusion}
@ -618,12 +618,12 @@ one for @tc[replace-in-type]:
(parameterize-push-stx ([current-replacement stx]) (parameterize-push-stx ([current-replacement stx])
(syntax-parse stx (syntax-parse stx
#:context `(tmpl-replace-in-type-6 ,(current-replacement)) #:context `(tmpl-replace-in-type-6 ,(current-replacement))
[(_ (~optional (~and debug? #:debug)) type:expr [from to] …) [(_ (~optkw #:debug) type:expr [from to] …)
(when (attribute debug?) (when (attribute debug)
(displayln (format "~a" stx))) (displayln (format "~a" stx)))
(let ([res #`#,(replace-in-type #'type (let ([res #`#,(replace-in-type #'type
#'([from to] …))]) #'([from to] …))])
(when (attribute debug?) (when (attribute debug)
(displayln (format "=> ~a" res))) (displayln (format "=> ~a" res)))
res)])))] res)])))]
@ -666,7 +666,6 @@ These metafunctions just extract the arguments for @tc[replace-in-type] and
expand-type) expand-type)
"meta-struct.rkt" "meta-struct.rkt"
"../lib/low/backtrace.rkt" "../lib/low/backtrace.rkt"
debug
racket/require racket/require
(for-template (subtract-in (for-template (subtract-in
typed/racket typed/racket

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

@ -6,6 +6,18 @@
;(current-directory "..") ;(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") #;(run! (list (find-executable-path-or-fail "sh")
"-c" "-c"
@string-append{ @string-append{
@ -138,7 +150,7 @@
(run! `(,(find-executable-path-or-fail "raco") (run! `(,(find-executable-path-or-fail "raco")
"make" "make"
"-v" "-v"
"-j" "5" "-j" "3"
,@rkt-files)) ,@rkt-files))
;; Create root MathJax link, must be done before the others ;; Create root MathJax link, must be done before the others

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

@ -161,14 +161,19 @@ else.
#,(expand-type #'T (bind-type-vars #'(TVar ...) env)))] #,(expand-type #'T (bind-type-vars #'(TVar ...) env)))]
[((~literal Rec) R:id T:expr) [((~literal Rec) R:id T:expr)
#`(Rec R #,(expand-type #'T (bind-type-vars #'(R) env)))] #`(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: ~literal instead of ~datum
;; TODO: ~commit when we find Let, so that syntax errors are not (syntax-parse #'bindings
;; interpreted as an arbitrary call.
;; TODO : for now we only allow aliasing (which means E is an id), ;; TODO : for now we only allow aliasing (which means E is an id),
;; not on-the-fly declaration of type expanders. This would require ;; not on-the-fly declaration of type expanders. This would require
;; us to (expand) them. ;; us to (expand) them.
[[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 (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 quote) T) (expand-quasiquote 'quote 1 env #'T)]
[((~literal quasiquote) T) (expand-quasiquote 'quasiquote 1 env #'T)] [((~literal quasiquote) T) (expand-quasiquote 'quasiquote 1 env #'T)]
[((~literal syntax) T) (expand-quasiquote 'syntax 1 env #'T)] [((~literal syntax) T) (expand-quasiquote 'syntax 1 env #'T)]