From 03984dc0f6968f2d8f0fa0fa4832dc5f7b2d22a4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Wed, 24 Feb 2016 00:35:19 +0100 Subject: [PATCH] WIP. --- graph-lib/graph/graph-6-rich-returns.lp2.rkt | 113 ++++++++++++++++--- graph-lib/graph/graph.lp2.rkt | 56 +++++---- graph-lib/graph/remember.rkt | 6 + graph-lib/graph/rewrite-type.lp2.rkt | 11 +- 4 files changed, 145 insertions(+), 41 deletions(-) diff --git a/graph-lib/graph/graph-6-rich-returns.lp2.rkt b/graph-lib/graph/graph-6-rich-returns.lp2.rkt index ebd3524e..feeec09d 100644 --- a/graph-lib/graph/graph-6-rich-returns.lp2.rkt +++ b/graph-lib/graph/graph-6-rich-returns.lp2.rkt @@ -106,8 +106,8 @@ plain list. (template (debug (begin - (define-graph first-step + #:definitions [] [node [field c field-type] … [(node/simple-mapping [field c field-type] …);] …) (node field …)]] … @@ -124,8 +124,14 @@ encapsulating the result types of mappings. @chunk[ (define-type-expander (~> stx) - (syntax-case stx () - [(_ mapping) #'(U mapping/node result-type)] …))] + (syntax-parse stx + [(_ (~literal mapping)) + (template + (U (first-step #:placeholder mapping/node) + (tmpl-replace-in-type result-type + [node (first-step #:placeholder node)] + …)))] + …))] @; TODO: replace-in-type doesn't work well here, we need to define a @; type-expander. @@ -142,7 +148,9 @@ encapsulating the result types of mappings. racket/syntax syntax/stx "../lib/low-untyped.rkt" - "../lib/low/multiassoc-syntax.rkt") + "../lib/low/multiassoc-syntax.rkt" + "rewrite-type.lp2.rkt"; debug + ) "../lib/low.rkt" "graph.lp2.rkt" "get.lp2.rkt" @@ -168,16 +176,40 @@ encapsulating the result types of mappings. - (begin - (define-type-expander (~> stx) - (displayln stx) - (displayln #'m-streets) - (syntax-parse stx - ((_ (~datum m-cities)) #'(U m-cities3/node (Listof City))) - ((_ (~datum m-streets)) #'(U (first-step #:placeholder m-streets4/node) - (Listof (first-step #:placeholder Street)))))) + #|(begin (define-graph first-step + #:definitions [ + #;(define-type-expander (~> stx) + (displayln stx) + (displayln #'m-streets) + (syntax-parse stx + ((_ (~datum m-cities)) #'(U m-cities3/node (Listof City))) + ((_ (~datum m-streets)) #'(U (first-step #:placeholder m-streets4/node) + (Listof (first-step #:placeholder Street)))))) + + + + + (define-type-expander + (~> stx) + (syntax-parse stx + ((_ (~literal m-cities)) + (template (U + (first-step #:placeholder m-cities3/node) + (tmpl-replace-in-type + (Listof City) + (City (first-step #:placeholder City)) + (Street (first-step #:placeholder Street)))))) + ((_ (~literal m-streets)) + (template (U + (first-step #:placeholder m-streets4/node) + (tmpl-replace-in-type + (Listof Street) + (City (first-step #:placeholder City)) + (Street (first-step #:placeholder Street)))))))) + + ] (City (streets : (U m-streets4/node (Listof Street))) ((City1/simple-mapping (streets : (~> m-streets) @@ -200,7 +232,59 @@ encapsulating the result types of mappings. ((m-streets (snames : (Listof String))) (m-streets4/node (let ((City City1/simple-mapping) (Street Street2/simple-mapping)) - (map Street snames))))))) + (map Street snames)))))))|# + +(begin + (define-graph + first-step + #:definitions + ((define-type-expander + (~> stx) + (syntax-parse stx + ((_ (~literal m-cities)) + (template (U + (first-step #:placeholder m-cities3/node) + (tmpl-replace-in-type + (Listof City) + (City (first-step #:placeholder City)) + (Street (first-step #:placeholder Street)))))) + ((_ (~literal m-streets)) + (template (U + (first-step #:placeholder m-streets4/node) + (tmpl-replace-in-type + (Listof Street) + (City (first-step #:placeholder City)) + (Street (first-step #:placeholder Street))))))))) + #| + (City [foo : Number] ((m1) (City 1))) + (Street [foo : Number] ((m2) (Street 2))) + (m-cities3/node [foo : Number] ((m3) (m-cities3/node 3))) + (m-streets4/node [foo : Number] ((m4) (m-streets4/node 4))) + |# + + ;; TODO: have a let-expander. + (City + (streets : (U m-streets4/node (Listof Street))) + ((City1/simple-mapping (streets : #|(~> m-streets)|# + (U (first-step #:placeholder m-streets4/node) + (Listof (first-step #:placeholder Street))) + )) (City streets))) + (Street + (sname : String) + ((Street2/simple-mapping (sname : String)) (Street sname))) + (m-cities3/node + (returned : (Listof City)) + ((m-cities (cnames : (Listof (Listof String)))) + (m-cities3/node + (let ((City City1/simple-mapping) (Street Street2/simple-mapping)) + (define (strings→city (s : (Listof String))) (City (m-streets s))) ;; + (map strings→city cnames))))) + (m-streets4/node + (returned : (Listof Street)) + ((m-streets (snames : (Listof String))) + (m-streets4/node + (let ((City City1/simple-mapping) (Street Street2/simple-mapping)) + (map Street snames))))))) @@ -249,7 +333,8 @@ encapsulating the result types of mappings. (require (submod "..") typed/rackunit) - #;)] + ; + )] @chunk[<*> (begin diff --git a/graph-lib/graph/graph.lp2.rkt b/graph-lib/graph/graph.lp2.rkt index 19028ce6..afb3678d 100644 --- a/graph-lib/graph/graph.lp2.rkt +++ b/graph-lib/graph/graph.lp2.rkt @@ -208,12 +208,14 @@ We derive identifiers for these based on the @tc[node] name: (define-temp-ids "~a/main-constructor" name) (define-temp-ids "~a/constructor" (node …) #:first-base root) (define-temp-ids "~a/make-placeholder" (node …) #:first-base root) + (define-temp-ids "~a/make-placeholder-type" (node …)) (define-temp-ids "~a/placeholder-struct" (node …)) (define-temp-ids "~a/placeholder-type" (node …)) (define-temp-ids "~a/placeholder-queue" (node …)) (define-temp-ids "~a/incomplete-type" (node …)) (define-temp-ids "~a/make-incomplete" (node …)) + (define-temp-ids "~a/make-incomplete-type" (node …)) (define-temp-ids "~a/incomplete-tag" (node …)) (define-temp-ids "~a/with-indices-type" (node …)) @@ -228,6 +230,7 @@ We derive identifiers for these based on the @tc[node] name: (define-temp-ids "~a/with-promises-tag" (node …)) (define-temp-ids "~a/mapping-function" (node …)) + (define-temp-ids "~a/mapping-function-type" (node …)) (define-temp-ids "~a/database" (node …) #:first-base root) @@ -330,10 +333,13 @@ arguments, tagged with the @tc[node]'s name): Then we define the @tc[node/make-placeholder] function: +@chunk[ + (define-type node/make-placeholder-type + (→ param-type … node/placeholder-type))] @chunk[ - (: node/make-placeholder (→ param-type … node/placeholder-type)) + (: node/make-placeholder node/make-placeholder-type) (define (node/make-placeholder param …) - ((inst node/placeholder-struct (List param-type …)) (list param …)))] + (node/placeholder-struct (list param …)))] @subsection{Making with-indices nodes} @@ -392,16 +398,18 @@ library. We replace all occurrences of a @tc[node] name with its @; TODO: use a type-expander here, instead of a template metafunction. -@CHUNK[ +@chunk[ (define-type node/incomplete-type (List 'node/incomplete-tag …)) - (: node/make-incomplete (→ … - node/incomplete-type)) + (define-type node/make-incomplete-type + (→ … node/incomplete-type))] +@chunk[ + (: node/make-incomplete node/make-incomplete-type) (define (node/make-incomplete field …) (list 'node/incomplete-tag field …))] -@CHUNK[ +@chunk[ (tmpl-replace-in-type field-type [node node/placeholder-type] …)] @@ -454,14 +462,14 @@ important change: Instead of returning an @emph{ideal} node type, we expect them to return an @emph{incomplete} node type. @chunk[ - (: node/mapping-function (→ param-type … node/incomplete-type)) + (: node/mapping-function node/mapping-function-type) (define node/mapping-function - (let ([mapping node/make-placeholder] - … - [node node/make-incomplete] - …) - (λ ([param : param-type] …) : node/incomplete-type - . mapping-body)))] + (ann (λ (param …) . mapping-body) + node/mapping-function-type))] + +@chunk[ + (define-type node/mapping-function-type + (→ param-type … node/incomplete-type))] @subsection{Returning a with-promises nodes} @@ -606,21 +614,21 @@ We will be able to use this type expander in function types, for example: [(_ . rest) (syntax/loc stx (root/constructor . rest))])) #:id (λ (stx) #'root/constructor)) - - (?? (splicing-let ([mapping node/make-placeholder] - … - [node node/make-incomplete] - …) - extra-definition - …)) - - (begin ) … + (begin ) … + (begin ) … + (splicing-let ([mapping node/make-placeholder] … + [node node/make-incomplete] …) + (?? (begin extra-definition …)) + (begin ) …) + + (begin ) … + (begin ) … (begin ) … (begin ) … - (begin ) … + (begin ) … - (begin ) … + (begin ) … (: fq (case→ (→ 'node/placeholder-queue node/placeholder-type (List (Vectorof node/with-indices-type) …)) diff --git a/graph-lib/graph/remember.rkt b/graph-lib/graph/remember.rkt index e10ef011..c4731e6e 100644 --- a/graph-lib/graph/remember.rkt +++ b/graph-lib/graph/remember.rkt @@ -94,3 +94,9 @@ (structure returned) (structure returned) (structure returned) +(structure foo) +(structure foo) +(structure foo) +(structure foo) +(structure foo) +(structure foo) diff --git a/graph-lib/graph/rewrite-type.lp2.rkt b/graph-lib/graph/rewrite-type.lp2.rkt index 2d303450..0475418a 100644 --- a/graph-lib/graph/rewrite-type.lp2.rkt +++ b/graph-lib/graph/rewrite-type.lp2.rkt @@ -584,9 +584,14 @@ one for @tc[replace-in-type]: @CHUNK[ (define-template-metafunction (tmpl-replace-in-type stx) (syntax-parse stx - [(_ type:expr [from to] …) - #`#,(replace-in-type #'type - #'([from to] …))]))] + [(_ (~optional (~and debug? #:debug)) type:expr [from to] …) + (when (attribute debug?) + (displayln (format "~a" stx))) + (let ([res #`#,(replace-in-type #'type + #'([from to] …))]) + (when (attribute debug?) + (displayln (format "=> ~a" res))) + res)]))] And one each for @tc[fold-instance] and @tc[replace-in-instance2]: