From 6324e1862ba7685007f46b67e4e761ed7de63aa4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Tue, 22 Mar 2016 16:26:27 +0100 Subject: [PATCH] Fixed compilation errors. --- graph-lib/.gitignore | 1 + graph-lib/graph/__DEBUG_graph6.rkt | 341 ++++++++++-------- graph-lib/graph/__DEBUG_graph6_B.rkt | 150 -------- graph-lib/graph/graph-6-rich-returns.lp2.rkt | 96 +++-- graph-lib/graph/graph.lp2.rkt | 5 +- graph-lib/graph/graph_old.lp2.rkt | 6 +- graph-lib/graph/remember.rkt | 4 + graph-lib/graph/rewrite-type.lp2.rkt | 31 +- graph-lib/make/make.rkt | 18 +- graph-lib/type-expander/type-expander.lp2.rkt | 13 +- 10 files changed, 292 insertions(+), 373 deletions(-) delete mode 100644 graph-lib/graph/__DEBUG_graph6_B.rkt diff --git a/graph-lib/.gitignore b/graph-lib/.gitignore index 80a4d9b3..4843142d 100644 --- a/graph-lib/.gitignore +++ b/graph-lib/.gitignore @@ -4,3 +4,4 @@ /docs/ *~ compiled +/build/ \ No newline at end of file diff --git a/graph-lib/graph/__DEBUG_graph6.rkt b/graph-lib/graph/__DEBUG_graph6.rkt index 157e0aa2..f7bd2988 100644 --- a/graph-lib/graph/__DEBUG_graph6.rkt +++ b/graph-lib/graph/__DEBUG_graph6.rkt @@ -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)))))) + +) \ No newline at end of file diff --git a/graph-lib/graph/__DEBUG_graph6_B.rkt b/graph-lib/graph/__DEBUG_graph6_B.rkt deleted file mode 100644 index 47afa249..00000000 --- a/graph-lib/graph/__DEBUG_graph6_B.rkt +++ /dev/null @@ -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))))))) \ No newline at end of file diff --git a/graph-lib/graph/graph-6-rich-returns.lp2.rkt b/graph-lib/graph/graph-6-rich-returns.lp2.rkt index 2d2d060a..cdbd84fe 100644 --- a/graph-lib/graph/graph-6-rich-returns.lp2.rkt +++ b/graph-lib/graph/graph-6-rich-returns.lp2.rkt @@ -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 [] - [node [field c (Let [id-~> first-step-expander2] field-type)] … - [(node/simple-mapping [field c 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 [] + [node [field c (Let [id-~> first-step-expander2] field-type)] … + [(node/simple-mapping [field c 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[ ;; 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[ + (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 #'( ))) (displayln (list "i-t=" #'typp)) - #'(λ ([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) #'( ))])))] @chunk[ - [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[ - [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[ + (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 (… …)))) - (replace-in-type #'(Let (id-~> second-step-marker-expander) i-t) + (replace-in-type #'(Let ([id-~> second-step-marker-expander]) i-t) #'( ))])))] @@ -446,7 +474,7 @@ which does not allow variants of (~> …). …] @chunk[ - [node ;; generated by the first pass + [second-step-node-of-first ;; generated by the first pass (name #:placeholder node)] ;; new type …] diff --git a/graph-lib/graph/graph.lp2.rkt b/graph-lib/graph/graph.lp2.rkt index 0d463f28..a96255fc 100644 --- a/graph-lib/graph/graph.lp2.rkt +++ b/graph-lib/graph/graph.lp2.rkt @@ -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))])) diff --git a/graph-lib/graph/graph_old.lp2.rkt b/graph-lib/graph/graph_old.lp2.rkt index a9dfa1ee..6f980664 100644 --- a/graph-lib/graph/graph_old.lp2.rkt +++ b/graph-lib/graph/graph_old.lp2.rkt @@ -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 (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") ;; diff --git a/graph-lib/graph/remember.rkt b/graph-lib/graph/remember.rkt index 5a4771e4..51aca616 100644 --- a/graph-lib/graph/remember.rkt +++ b/graph-lib/graph/remember.rkt @@ -172,3 +172,7 @@ (constructor . tabc) (constructor . t) (constructor . t) +(constructor . ma/incomplete) +(constructor . mb/incomplete) +(constructor . ma/incomplete) +(constructor . ma/incomplete) diff --git a/graph-lib/graph/rewrite-type.lp2.rkt b/graph-lib/graph/rewrite-type.lp2.rkt index 093b465a..2edfddc3 100644 --- a/graph-lib/graph/rewrite-type.lp2.rkt +++ b/graph-lib/graph/rewrite-type.lp2.rkt @@ -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[ - (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 diff --git a/graph-lib/make/make.rkt b/graph-lib/make/make.rkt index d63093eb..c2173ef5 100644 --- a/graph-lib/make/make.rkt +++ b/graph-lib/make/make.rkt @@ -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 diff --git a/graph-lib/type-expander/type-expander.lp2.rkt b/graph-lib/type-expander/type-expander.lp2.rkt index 9c9c3c0c..56a2a6c9 100644 --- a/graph-lib/type-expander/type-expander.lp2.rkt +++ b/graph-lib/type-expander/type-expander.lp2.rkt @@ -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)]