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/

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

@ -41,17 +41,17 @@
#'(b (d (dgX n) . r) (dgX n2)))])) #'(b (d (dgX n) . r) (dgX n2)))]))
(super-define-graph/rich-return (super-define-graph/rich-return
grr3 grr3
([City [streets : (~> m-streets)]] ([City [streets : (~> m-streets)]]
[Street [sname : String]]) [Street [sname : String]])
[(m-cities [cnames : (Listof (Listof bubble))]) [(m-cities [cnames : (Listof (Listof bubble))])
: (Listof City) : (Listof City)
(define (strings→city [s : (Listof blob)]) (define (strings→city [s : (Listof blob)])
(City (m-streets s))) (City (m-streets s)))
(map strings→city cnames)] (map strings→city cnames)]
[(m-streets [snames : (Listof String)]) [(m-streets [snames : (Listof String)])
: (Listof Street) : (Listof Street)
(map Street snames)]) (map Street snames)])
;(grr3 '(("a" "b") ("c"))) ;(grr3 '(("a" "b") ("c")))
@ -98,153 +98,176 @@
;; DEBUG: ;; DEBUG:
#;(require (for-syntax racket/format #;(require (for-syntax racket/format
"rewrite-type.lp2.rkt" "rewrite-type.lp2.rkt"
racket/syntax racket/syntax
syntax/parse syntax/parse
(submod "../lib/low.rkt" untyped)) (submod "../lib/low.rkt" untyped))
(for-syntax syntax/parse (for-syntax syntax/parse
syntax/parse/experimental/template syntax/parse/experimental/template
racket/syntax racket/syntax
(submod "../lib/low.rkt" untyped) (submod "../lib/low.rkt" untyped)
"rewrite-type.lp2.rkt" #|debug|# "rewrite-type.lp2.rkt" #|debug|#
syntax/id-set syntax/id-set
racket/format racket/format
mischief/transform) mischief/transform)
(rename-in "../lib/low.rkt" [~> threading:~>]) (rename-in "../lib/low.rkt" [~> threading:~>])
"graph.lp2.rkt" "graph.lp2.rkt"
"get.lp2.rkt" "get.lp2.rkt"
"../type-expander/type-expander.lp2.rkt" "../type-expander/type-expander.lp2.rkt"
"../type-expander/multi-id.lp2.rkt" "../type-expander/multi-id.lp2.rkt"
"adt.lp2.rkt" ; debug "adt.lp2.rkt" ; debug
"fold-queues.lp2.rkt"; debug "fold-queues.lp2.rkt"; debug
"rewrite-type.lp2.rkt"; debug "rewrite-type.lp2.rkt"; debug
"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
#:definitions #:definitions
((define-type-expander ((define-type-expander
(~> stx) (~> stx)
(syntax-parse (syntax-parse
stx stx
((_ (~datum m-cities)) (template (U (grr31/first-step #:placeholder m-cities4/node) (Listof (grr31/first-step #:placeholder City))))) ((_ (~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))))))) ((_ (~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)))))) (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))) (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))) (Street (sname : (Let (~> first-step-expander2) String)) ((Street3/simple-mapping (sname : String)) (Street sname)))
(m-cities4/node (m-cities4/node
(returned : (Listof City)) (returned : (Listof City))
((m-cities (cnames : (Listof (Listof bubble)))) ((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-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))))
(define-type m-cities10/node-marker (U (grr31/first-step m-cities4/node) (Listof (grr31/first-step City)))) (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 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-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-expander (define-type second-step-City18-of-first (grr31/first-step City))
(second-step-marker2-expander stx) (define-type second-step-Street19-of-first (grr31/first-step Street))
(syntax-parse (define-type-expander
stx (second-step-marker2-expander stx)
((_ (~datum m-cities)) #'(U second-step-m-cities16/node-of-first (Listof (grr31/first-step City)))) (syntax-parse
((_ (~datum m-streets)) #'(U second-step-m-streets17/node-of-first (Listof (grr31/first-step Street)))))) stx
#;(define-type-expander ((_ (~datum m-cities)) #'(U second-step-m-cities16/node-of-first (Listof (grr31/first-step City))))
(inline-type stx) ((_ (~datum m-streets)) #'(U second-step-m-streets17/node-of-first (Listof (grr31/first-step Street))))))
(dbg (define-type-expander
("inline-type" stx) (inline-type* stx)
(syntax-parse (dbg
stx ("inline-type" stx)
((_ i-t (~and seen (:id …))) (syntax-parse
(let ((seen-list (syntax->list #'seen))) stx
(when (and (not (null? seen-list)) (member (car seen-list) (cdr seen-list) free-identifier=?)) ((_ i-tyy (~and seen (:id …)))
(raise-syntax-error (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))))
'define-graph/rich-returns #'(inline-type replt seen)))))
(~a "Cycles in types are not allowed." " The following types were already inlined: " (syntax->datum #'seen) ", but " #'t " appeared a second time.") (define-type-expander
#'t))) (inline-type stx)
(replace-in-type (dbg
#'(Let (~> second-step-marker-expander) i-t) ("inline-type" stx)
#'((m-cities10/node-marker (inline-type (Listof City) (m-cities4/node . seen))) (syntax-parse
(m-streets11/node-marker (inline-type (Listof Street) (m-streets5/node . seen))) stx
(City (grr3 #:placeholder City)) ((_ i-t (~and seen (:id …)))
(Street (grr3 #:placeholder Street)))))))) (let ((seen-list (syntax->list #'seen)))
(define-syntax (inline-instance stx) (when (and (not (null? seen-list)) (member (car seen-list) (cdr seen-list) free-identifier=?))
(dbg (raise-syntax-error
("inline-instance" stx) 'define-graph/rich-returns
(syntax-parse (~a "Cycles in types are not allowed." " The following types were already inlined: " (syntax->datum #'seen) ", but " #'t " appeared a second time.")
stx #'t)))
((_ i-t (~and seen (:id …))) (replace-in-type
(define/with-syntax typp #'(Let (~> second-step-marker2-expander) i-t)) #'(Let ((~> second-step-marker-expander)) i-t)
(define/with-syntax #'((m-cities10/node-marker (inline-type (Listof City) (m-cities4/node . seen)))
repl (m-streets11/node-marker (inline-type (Listof Street) (m-streets5/node . seen)))
(replace-in-instance (second-step-City18-of-first (grr3 #:placeholder City))
#'typp (second-step-Street19-of-first (grr3 #:placeholder Street))))))))
#'((second-step-m-cities16/node-of-first Symbol (grr31/first-step #:? m-cities4/node) (λ _ (error "NIY4"))) (define-syntax (inline-instance* stx)
(second-step-m-streets17/node-of-first Symbol (grr31/first-step #:? m-streets5/node) (λ _ (error "NIY4"))) (dbg
(City (grr3 #:placeholder City) (grr31/first-step #:? City) (λ _ (error "NIY3"))) ("inline-instance*" stx)
(Street (grr3 #:placeholder Street) (grr31/first-step #:? Street) (λ _ (error "NIY3")))))) (syntax-parse
(displayln (list "i-t=" #'typp)) stx
(let ((seen-list (syntax->list #'seen))) ((_ i-ty seen)
(when (and (not (null? seen-list)) (member (car seen-list) (cdr seen-list) free-identifier=?)) (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))))
(raise-syntax-error (displayln (list "replt=" #'replt))
'define-graph/rich-returns #'(inline-instance replt seen)))))
(~a "Cycles in types are not allowed." " The following types were already inlined: " (syntax->datum #'seen) ", but " #'t " appeared a second time.") (define-syntax (inline-instance stx)
#'t))) (dbg
#'(λ ((x : (Let (~> second-step-marker2-expander) i-t))) repl (error "NIY2"))))))) ("inline-instance" stx)
(City (streets : (Let (~> ~>-to-result-type) (~> m-streets))) (syntax-parse
((City6/extract/mapping (from : (grr31/first-step City))) stx
(City ((_ 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))))))
(;;(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
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)))))))

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

@ -119,26 +119,27 @@ 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 '~>))
(quasitemplate/debug debug (quasitemplate/debug debug
(begin (begin
#,(dbg #,(dbg
("first-pass" stx) ("first-pass" stx)
(quasitemplate (quasitemplate
(define-graph name/first-step (define-graph name/first-step
#:definitions [<first-pass-type-expander>] #:definitions [<first-pass-type-expander>]
[node [field c (Let [id-~> first-step-expander2] field-type)] … [node [field c (Let [id-~> first-step-expander2] field-type)] …
[(node/simple-mapping [field c field-type] …) [(node/simple-mapping [field c field-type] …)
;<first-pass-field-type>] …) ;<first-pass-field-type>] …)
(node field …)]] … (node field …)]] …
[mapping/node [returned cm result-type] [mapping/node [returned cm result-type]
[(mapping [param cp param-type] …) [(mapping [param cp param-type] …)
(mapping/node (mapping/node
(let ([node node/simple-mapping] …) (let ([node node/simple-mapping] …)
. body))]] . body))]]
…))) …)))
;; TODO: how to return something else than a node?? ;; TODO: how to return something else than a node??
;; Possibility 1: add a #:main function to define-graph, which can ;; Possibility 1: add a #:main function to define-graph, which can
;; call (make-root). ;; call (make-root).
@ -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,8 +272,8 @@ in all of its fields:
@chunk[<inlined-node> @chunk[<inlined-node>
;; inline from the field-type of the old node. ;; inline from the field-type of the old node.
(node ((inline-instance field-type;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (node ((inline-instance* field-type;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
()) (get from field)) ()) (get from field))
…)] …)]
@subsection{Inlining instances} @subsection{Inlining instances}
@ -280,41 +286,52 @@ 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)
(error "NIY2")) (error "NIY2"))
#;(replace-in-instance #'(Let (id-~> second-step-marker2-expander) i-t) #;(replace-in-instance #'(Let (id-~> second-step-marker2-expander) i-t)
#'(<inline-instance-replacement> #'(<inline-instance-replacement>
<inline-instance-nodes>))])))] <inline-instance-nodes>))])))]
@chunk[<inline-instance-replacement> @chunk[<inline-instance-replacement>
[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? (λ ([x : second-step-mapping/node-of-first]) ;; fun
#;(inline-instance result-type (mapping/node . seen)) ((inline-instance* result-type (mapping/node . seen))
(λ _ (error "NIY4"))] ;; fun (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
…] …]

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

@ -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/promise-type" (node …) #:prefix #'name)
(define-temp-ids "~a/constructor" (node …) #:first-base root (define-temp-ids "~a/constructor" (node …) #:first-base root
#:prefix #'name) #:prefix #'name)
(define-temp-ids "~a?" (node …) #:prefix #'name) (define-temp-ids "~a?" (node …) #:prefix #'name)
(define-temp-ids "~a/make-placeholder" (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 ;; 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)

31
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,17 +593,17 @@ 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
(#,(fold-instance t (#,(fold-instance t
#'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

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

@ -6,9 +6,21 @@
;(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{
found_long_lines=0 found_long_lines=0
for i in `find \ for i in `find \
\( -path ./lib/doc/bracket -prune -and -false \) \ \( -path ./lib/doc/bracket -prune -and -false \) \
@ -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

13
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.
#`#,(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 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)]