From 5169b73bf57809a6a4b947ce947e06f0806ec274 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Mon, 30 Nov 2015 16:24:48 +0100 Subject: [PATCH] WIP, fixed arrows given by define-temp-ids, using syntax-local-get-shadower, see __DEBUG__.rkt for an example. --- graph/graph/graph2.lp2.rkt | 137 ++++++++++++++++++++++++------------- graph/lib/__DEBUG__.rkt | 10 +++ graph/lib/low.rkt | 129 +++++++++++++++++++++++++++++++++- 3 files changed, 225 insertions(+), 51 deletions(-) create mode 100644 graph/lib/__DEBUG__.rkt diff --git a/graph/graph/graph2.lp2.rkt b/graph/graph/graph2.lp2.rkt index 9439879f..05c3a312 100644 --- a/graph/graph/graph2.lp2.rkt +++ b/graph/graph/graph2.lp2.rkt @@ -15,6 +15,20 @@ This module provides a @tc[graph] macro which helps constructing immutable graphs (using lambdas to defer potentially cyclic references). + + + + + + + + + +@subsection{Example usage} + +We will start with a running example, which will help us both show the macro's +syntax, and show some of the key advantages offered by this graph library. + @subsection{The graph's type} Each node type in the graph is a variant's constructor, tagged with the node @@ -22,19 +36,14 @@ name. For example, a graph representing a city and its inhabitants could use these variants: @chunk[ - [City [streets : (Listof Street)] [inhabitants : (Listof Person)]] - [Street [houses : (Listof House)]] - [House [owner : Person] [location : Street]] - [Person [name : String]]] + [City [streets : (Listof Street)] [people : (Listof Person)] ] + [Street [houses : (Listof House)] ] + [House [owner : Person] [location : Street] ] + [Person [name : String]] ] Notice the cycle in the type: a street contains houses, which are located on the same street. -@subsection{Example usage} - -We will start with a running example, which will help us both show the macro's -syntax, and show some of the key advantages offered by this graph library. - @subsubsection{A seed from which to unravel the graph: the root parameters} In order to build a graph with that type, we start from the root parameters. @@ -59,17 +68,17 @@ the @tc[Person] node constructor. @; Would be nicer with (map (∘ (curry street c) my-car) c)), but that doesn't @; typecheck (yet). -@chunk[ +@chunk[ [(m-city [c : (Listof (Pairof String String))]) : City (City (remove-duplicates (map (curry m-street c) (cars c))) - (remove-duplicates (map Person (cdrs c))))]] + (remove-duplicates (map m-person (cdrs c))))]] @subsubsection{More mappings} Next, we write the @tc[m-street] mapping, which takes a street name and the whole city @tc[c] in list form, and creates a @tc[Street] node. -@chunk[ +@chunk[ [(m-street [c : (Listof (Pairof String String))] [s : String]) : Street (Street (map (curry (curry m-house s) c) (cars (filter (λ ([x : (Pairof String String)]) @@ -91,12 +100,16 @@ no risk of forcing one before it is available. Finally, we write the @tc[m-house] mapping. -@chunk[ +@chunk[ [(m-house [s : String] [c : (Listof (Pairof String String))] [p : String]) : House - (House (Person p) (m-street c s))]] + (House (m-person p) (m-street c s))]] + +@chunk[ + [(m-person [p : String]) : Person + (Person p)]] Notice how we are calling directly the @tc[Person] constructor above. We also called it directly in the @tc[m-city] mapping. Since @tc[Person] does not @@ -122,8 +135,7 @@ boolean argument to @tc[m-street]. @chunk[ (make-graph-constructor () - - )] + )] @subsubsection{Creating a graph instance} @@ -134,7 +146,7 @@ boolean argument to @tc[m-street]. Let's take a second look at the root mapping: -@chunk[ +@chunk[ [(m-city [c : (Listof (Pairof String String))]) : City (City (remove-duplicates (map (curry m-street c) (cars c))) (remove-duplicates (map Person (cdrs c))))]] @@ -169,6 +181,27 @@ In particular, it does not handle recursive types described with @tc[Rec] yet. In this section, we will describe how the @tc[make-graph-constructor] macro is implemented. +@subsection{The macro's syntax} + +We use a simple syntax for @tc[make-graph-constructor], and make it more +flexible through wrapper macros. + +@chunk[ + (make-graph-constructor + (root-expr:expr ...) + ([node … ] …))] + +Where @tc[] is: + +@chunk[ + [field-name:id (~literal :) field-type:expr]] + +And @tc[] is: + +@chunk[ + ((mapping:id [param:id (~literal :) param-type:expr] …) + . mapping-body)] + @subsection{The different types of a node and mapping} A single node name can refer to several types: @@ -177,39 +210,44 @@ A single node name can refer to several types: @item{The @emph{ideal} type, expressed by the user, for example @racket[[City (Listof Street) (Listof Person)]], it is never used as-is in practice} + @item{The @emph{placeholder} type, type and constructor, which just store the + arguments for the mapping along with a tag indicating the node name} @item{The @emph{incomplete} type, in which references to other node types are allowed to be either actual (@racket[incomplete]) instances, or placeholders. For example, @racket[[City (Listof (U Street Street/placeholder-type)) (Listof (U Person Person/placeholder-type))]].} + @item{The @emph{with-indices} type, in which references to other node types + must be replaced by an index into the results list for the target node's + @racket[with-promises] type. For example, + @racket[[City (Listof (Pairof 'Street/with-indices-tag Index)) + (Listof (Pairof 'Person/with-indices-tag Index))]].} @item{The @emph{with-promises} type, in which references to other node types must be replaced by a @racket[Promise] for the target node's @racket[with-promises] type. For example, @racket[[City (Listof (Promise Street/with-promises-type)) - (Listof (Promise Person/with-promises-type))]].}] - -When the user code calls a mapping, a placeholder is instead returned. We -therefore will have one placeholder type per mapping. Mappings come in various -flavours too: - -@itemlist[ - @item{The \emph{placeholder} type and constructor, which just store the - arguments for the mapping along with its name} - @item{The mapping function's \emph{body}, which takes some parameters and + (Listof (Promise Person/with-promises-type))]].} + @item{The @emph{mapping function}, which takes some parameters and returns a node (this is the code directly provided by the user)}] -@subsection{The macro's syntax} +We derive identifiers for these based on the @tc[node] or @tc[mapping] name: -We use a simple syntax for @tc[make-graph-constructor], and make it more -flexible through wrapper macros. +@;;;; +@chunk[ + (define-temp-ids "~a/make-placeholder" (mapping …) #:first-base root) + (define-temp-ids "~a/placeholder-type" (mapping …)) + (define-temp-ids "~a/make-incomplete" (node …)) + (define-temp-ids "~a/incomplete-type" (node …)) + (define-temp-ids "~a/make-with-indices" (node …)) + (define-temp-ids "~a/with-indices-type" (node …)) + (define-temp-ids "~a/make-with-promises" (node …)) + (define-temp-ids "~a/with-promises-type" (node …)) + (define-temp-ids "~a/function" (mapping …))] -@chunk[ - (make-graph-constructor - ([node [field-name:id (~literal :) field-type:expr] ...] ...) - (root-expr:expr ...) - [(mapping:id [param:id (~literal :) param-type:expr] ...) - (~literal :) result-type:expr - . mapping-body] - ...)] +@chunk[ + (define/with-syntax (root/make-placeholder . _) + #'(mapping/make-placeholder …))] + +@subsection{Overview} The macro relies heavily on two sidekick modules: @tc[rewrite-type], and @tc[fold-queue]. The former will allow us to derive from the ideal type of a @@ -411,14 +449,13 @@ given @tc[node] name. The code above also needs some identifiers derived from @tc[node] and @tc[field-name]s: -@; TODO: format-ids doesn't accept arbitrary values. Should we change it? @chunk[ (define-temp-ids "~a/make-incomplete" (node …)) (define-temp-ids "~a/incomplete-type" (node …)) (define-temp-ids "~a/incomplete-tag" (node …)) (define-temp-ids "~a/incomplete-fields" (node …)) (define/with-syntax ((field/incomplete-type …) …) - (stx-map generate-temporaries #'((field-name …) …)))] + (stx-map-nested #'((field-name …) …)))] @subsection{Converting incomplete nodes to with-promises ones} @@ -515,15 +552,17 @@ to return an incomplete node type. @chunk[ (define-syntax/parse - - ((λ (x) (pretty-write (syntax->datum x)) x) - (template - (let () - (begin ) … - (begin ) … - (begin ) … - (begin ) … - ))))] + (let () + + + ((λ (x) (pretty-write (syntax->datum x)) x) + (template + (let () + (begin ) … + (begin ) … + (begin ) … + (begin ) … + )))))] @section{Conclusion} diff --git a/graph/lib/__DEBUG__.rkt b/graph/lib/__DEBUG__.rkt new file mode 100644 index 00000000..0d4c3f42 --- /dev/null +++ b/graph/lib/__DEBUG__.rkt @@ -0,0 +1,10 @@ +#lang racket +(require "low-untyped.rkt") + +(with-syntax ([(foo ...) #'(aa bb cc)]) + (define-temp-ids "___~a.truc" (foo ...) #:first-base fst) + (displayln (syntax->datum #'(___foo.truc ...))) + (displayln (syntax->datum #'(fst ___fst.truc)))) + +(define a 1) +(+ a a) \ No newline at end of file diff --git a/graph/lib/low.rkt b/graph/lib/low.rkt index e495fd6a..80584164 100644 --- a/graph/lib/low.rkt +++ b/graph/lib/low.rkt @@ -482,7 +482,8 @@ (only-in syntax/stx stx-map) (for-syntax racket/base racket/syntax - syntax/parse)) + syntax/parse + syntax/parse/experimental/template)) ;(require racket/sequence) ;; in-syntax (require "sequences.rkt" @@ -495,6 +496,8 @@ (Listof Identifier) (Syntaxof (Listof Identifier)))) + ; TODO: format-ids doesn't accept arbitrary values. Should we change it? + ; (: format-ids (→ (U Syntax (→ (U String Identifier) * Syntax)) String S-Id-List * @@ -539,6 +542,33 @@ ;; Introduce the binding in a fresh scope. (apply format-ids (λ _ ((make-syntax-introducer) #'())) format vs)) + ;; Also in ==== syntax.rkt ====, once we split into multiple files, require it + (begin-for-syntax + (define (syntax-cons-property stx key v) + (let ([orig (syntax-property stx key)]) + (syntax-property stx key (cons v (or orig '())))))) + + ;; Also in ==== syntax.rkt ====, once we split into multiple files, require it + (begin-for-syntax + (define (identifier-length id) (string-length (symbol->string + (syntax-e id))))) + + (begin-for-syntax + (define-syntax-class simple-format + (pattern format + #:when (string? (syntax-e #'format)) + #:when (regexp-match #rx"^[^~]*~a[^~]*$" (syntax-e #'format)) + #:attr pos (regexp-match-positions #rx"^([^~]*)~a([^~]*)$" + (syntax-e #'format)) + #:attr left-start 1 + #:attr left-end (+ 1 (cdr (cadr (attribute pos)))) + #:attr left-len (cdr (cadr (attribute pos))) + + #:attr right-start (+ 1 (car (caddr (attribute pos)))) + #:attr right-end (+ 1 (cdr (caddr (attribute pos)))) + #:attr right-len (- (attribute right-end) + (attribute right-start))))) + (define-syntax (define-temp-ids stx) (syntax-parse stx ;; TODO : factor this with the next case. @@ -548,6 +578,81 @@ #'(define/with-syntax ((pat (... ...)) (... ...)) (stx-map (curry format-temp-ids format) #'((base (... ...)) (... ...)))))] + + ;; New features (arrows and #:first) special-cased for now + ;; todo: make these features more general. + [(_ format:simple-format (base:id (~literal ...)) #:first-base first-base) + #:with first (format-id #'first-base (syntax-e #'format) #'first-base) + (let ([first-base-len (identifier-length #'first-base)]) + (syntax-cons-property #'(define-temp-ids format (base (... ...)) + #:first first) + 'sub-range-binders + (list + (if (> (attribute format.left-len) 0) + (vector (syntax-local-introduce #'first) + 0 + (attribute format.left-len) + + (syntax-local-introduce #'format) + (attribute format.left-start) + (attribute format.left-len)) + '()) + (vector (syntax-local-introduce #'first) + (attribute format.left-len) + first-base-len + + (syntax-local-introduce #'first-base) + 0 + first-base-len) + (if (> (attribute format.right-len) 0) + (vector (syntax-local-introduce #'first) + (+ (attribute format.left-len) + first-base-len) + (attribute format.right-len) + + (syntax-local-introduce #'format) + (attribute format.right-start) + (attribute format.right-len)) + '()))))] + + [(_ format:simple-format (base:id (~literal ...)) + (~optional (~seq #:first-base first-base)) + (~optional (~seq #:first first))) + (let* ([base-len (string-length (symbol->string (syntax-e #'base)))]) + (define/with-syntax pat (format-id #'base (syntax-e #'format) #'base)) + (syntax-cons-property + (template (begin (define/with-syntax (pat (... ...)) + (format-temp-ids format #'(base (... ...)))) + (?? (?@ (define/with-syntax (first . _) + #'(pat (... ...))))) + (?? (?@ (define/with-syntax (fst . _) + #'(pat (... ...))))))) + 'sub-range-binders + (list (if (> (attribute format.left-len) 0) + (vector (syntax-local-introduce #'pat) + 0 + (attribute format.left-len) + + (syntax-local-introduce #'format) + (attribute format.left-start) + (attribute format.left-len)) + '()) + (vector (syntax-local-introduce #'pat) + (attribute format.left-len) + base-len + + (syntax-local-get-shadower #'base) + 0 + base-len) + (if (> (attribute format.right-len) 0) + (vector (syntax-local-introduce #'pat) + (+ (attribute format.left-len) base-len) + (attribute format.right-len) + + (syntax-local-introduce #'format) + (attribute format.right-start) + (attribute format.right-len)) + '()))))] [(_ format (base:id (~literal ...))) #:when (string? (syntax-e #'format)) (with-syntax ([pat (format-id #'base (syntax-e #'format) #'base)]) @@ -615,7 +720,27 @@ ;; ==== syntax.rkt ==== -(provide stx-assoc cdr-stx-assoc) +(provide syntax-cons-property + stx-assoc + cdr-stx-assoc + stx-map-nested) + +(: syntax-cons-property (∀ (A) (→ (Syntaxof A) Symbol Any (Syntaxof A)))) +(define (syntax-cons-property stx key v) + (let ([orig (syntax-property stx key)]) + (syntax-property stx key (cons v (or orig '()))))) + + +(: identifier-length (→ Identifier Index)) +(define (identifier-length id) (string-length (symbol->string (syntax-e id)))) + +(: stx-map-nested (∀ (A B) (→ (→ A B) + (Syntaxof (Listof (Syntaxof (Listof A)))) + (Listof (Listof B))))) +(define (stx-map-nested f stx) + (map (λ ([x : (Syntaxof (Listof A))]) + (map f (syntax-e x))) + (syntax-e stx))) #| (require/typed syntax/stx [stx-car (∀ (A B) (→ (Syntaxof (Pairof A B)) A))]