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

WIP.

Browse Source
This commit is contained in:
Georges Dupéron 2016-02-24 00:35:19 +01:00
parent 3d7441cef0
commit 03984dc0f6
4 changed files with 145 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -106,8 +106,8 @@ plain list.
(template
(debug
(begin
<first-pass-type-expander>
(define-graph first-step
#:definitions [<first-pass-type-expander>]
[node [field c field-type] …
[(node/simple-mapping [field c field-type] …);<first-pass-field-type>] …)
(node field …)]] …
@ -124,8 +124,14 @@ encapsulating the result types of mappings.
@chunk[<first-pass-type-expander>
(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)
#;<test-graph-rich-return>)]
;<test-graph-rich-return>
)]
@chunk[<*>
(begin

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

@ -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-make-placeholder-type>
(define-type node/make-placeholder-type
(→ param-type … node/placeholder-type))]
@chunk[<define-make-placeholder>
(: 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[<define-incomplete>
@chunk[<define-incomplete-type>
(define-type node/incomplete-type
(List 'node/incomplete-tag <field/incomplete-type> …))
(: node/make-incomplete (→ <field/incomplete-type> …
node/incomplete-type))
(define-type node/make-incomplete-type
(→ <field/incomplete-type> … node/incomplete-type))]
@chunk[<define-incomplete>
(: node/make-incomplete node/make-incomplete-type)
(define (node/make-incomplete field …)
(list 'node/incomplete-tag field …))]
@CHUNK[<field/incomplete-type>
@chunk[<field/incomplete-type>
(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[<define-mapping-function>
(: 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-mapping-function-type>
(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 <define-placeholder-type>) …
(begin <define-make-placeholder>) …
(begin <define-incomplete>) …
(splicing-let ([mapping node/make-placeholder] …
[node node/make-incomplete] …)
(?? (begin extra-definition …))
(begin <define-mapping-function>) …)
(begin <define-placeholder-type>) …
(begin <define-make-placeholder-type>) …
(begin <define-with-indices>) …
(begin <define-with-promises>) …
(begin <define-incomplete>) …
(begin <define-incomplete-type>) …
(begin <define-mapping-function>) …
(begin <define-mapping-function-type>) …
(: fq (case→ (→ 'node/placeholder-queue node/placeholder-type
(List (Vectorof node/with-indices-type) …))

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

@ -94,3 +94,9 @@
(structure returned)
(structure returned)
(structure returned)
(structure foo)
(structure foo)
(structure foo)
(structure foo)
(structure foo)
(structure foo)

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

@ -584,9 +584,14 @@ one for @tc[replace-in-type]:
@CHUNK[<template-metafunctions>
(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]: