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

WIP on FB case 86 (Graph: Multiple constructors), rollback point for implementing FB case 95 (Allow choosing the root in the graph constructor)

Browse Source
This commit is contained in:
Georges Dupéron 2016-02-01 18:03:47 +01:00
parent ba177ea972
commit a619b731df
8 changed files with 349 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

81
graph-lib/graph/__DEBUG_graph5.rkt Normal file
View File

@ -0,0 +1,81 @@
#lang typed/racket
#|(require
"graph.lp2.rkt"
"../type-expander/type-expander.lp2.rkt")
(define-graph g2
[a [v : Number] [w : b] ((ma) (a 1 (mb)))]
[b [v : String] ((mb) (frob) (b "b"))])
(define (frob)
: (g2 b)
(error "niy!"))|#
;#|
#|
(module mm typed/racket
(require ;(submod "graph.lp2.rkt" test)
"graph.lp2.rkt"
"../type-expander/type-expander.lp2.rkt")
(provide g2)
(define-graph g2
[a [v : Number] [w : b] ((ma) (a 1 (mb)))]
[b [v : String] ((mb) (frob) (b "b"))])
(define (frob)
: (g2 b)
(error "niy!")))
(require "graph.lp2.rkt"
"../type-expander/type-expander.lp2.rkt"
'mm)
(λ ([x : (g2 b)]) x)
(λ ([x : (g2 a)]) x)
|#
#|
(require "../type-expander/type-expander.lp2.rkt")
(require "graph.lp2.rkt")
(define-graph g2 [a [v : Number] ((ma) (a 1))])
|#
(require "graph-5-multi-ctors.lp2.rkt")
(require "../lib/low.rkt"
"graph.lp2.rkt"
"get.lp2.rkt"
"../type-expander/type-expander.lp2.rkt"
"../type-expander/multi-id.lp2.rkt")
(define-graph/multi-ctor gm ([a [b1 : b] [b2 : b] [v : Number]]
[b [a : a] [s : String] [v : Number]])
[(r [v : Number] [w : String])
: a
(a (bx (if (> 0 v) (sub1 v) (+ v (string-length w))))
(by (if (> 0 v) (sub1 v) (+ v (string-length w))) "xyz")
v)]
[(bx [v : Number])
: b
(b (r v) "x" v)]
[(by [v : Number] [w : String])
: b
(b (r v) "y" (+ v (string-length w)))])

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

@ -55,7 +55,7 @@
(define-for-syntax (replace-dots stx)
(syntax-parse stx
[x:id
#:when (regexp-match #px"^.*\\..*[^.]$"
#:when (regexp-match #px"^.*[.…].*[^.…]$"
(symbol->string (syntax-e #'x)))
(let* ([str (symbol->string (syntax-e #'x))]
[components (regexp-match* #px"([^.…]|\\.\\.+)+|…" str)]
@ -152,6 +152,9 @@
(check-equal?: 'aa…bb..cc.d (list 'get 'aa '… (slen 5 "bb.cc") 'd))
(check-equal?: 'aa.….bb..cc.d (list 'get 'aa '… (slen 5 "bb.cc") 'd))
(check-equal?: 'aa.….bb.cc.d (list 'get 'aa '… 'bb 'cc 'd))
(check-equal?: 'aa…bb (list 'get 'aa '… 'bb))
(check-equal?: 'aa… (slen 2 "a…"))
(check-equal?: '… (slen 1 "…"))

14
graph-lib/graph/fold-queues.lp2.rkt
View File

@ -1,4 +1,4 @@
#lang debug scribble/lp2
#lang scribble/lp2
@(require "../lib/doc.rkt")
@doc-lib-setup
@ -11,14 +11,16 @@
@section{Implementation}
@chunk[<fold-queues-signature>
(fold-queues root-value
(fold-queues (~maybe #:root root-spec)
root-value
[(name [element :colon Element-Type]
[Δ-queues :colon Δ-Queues-Type-Name]
enqueue)
:colon Result-Type
. body]
…
(~parse (root-name . _) #'(name …)))]
(~parse (root-name . _)
(template ((?? root-spec) name …))))]
@chunk[<enqueue-type>
(case→ (→ 'name
@ -46,9 +48,7 @@
@chunk[<fold-queue-multi-sets-immutable-tags>
(define-syntax/parse <fold-queues-signature>
;<define-queues-type>
<define-ids>
#|((λ (x) (pretty-write (syntax->datum x)) x)|#
#'(let ()
(begin
(: name/process-element <process-element-type>)
@ -276,8 +276,8 @@ added to the @tc[Δ-Hash] since its creation from a simple @tc[HashTable].
@chunk[<module-main>
(module main typed/racket
(require (for-syntax syntax/parse
syntax/parse/experimental/template
racket/syntax
racket/pretty; DEBUG
"../lib/low-untyped.rkt")
"../lib/low.rkt"
"../type-expander/type-expander.lp2.rkt")
@ -293,7 +293,7 @@ added to the @tc[Δ-Hash] since its creation from a simple @tc[HashTable].
(require (submod "..")
typed/rackunit)
#| TODO |#)]
#| TODO: tests |#)]
@chunk[<*>
(begin

12
graph-lib/graph/graph-4.5-types.rkt Normal file
View File

@ -0,0 +1,12 @@
#lang typed/racket
(require "graph.lp2.rkt")
(require "../type-expander/multi-id.lp2.rkt")
(require "../type-expander/type-expander.lp2.rkt")
(define-graph g2 [a [v : Number] ((ma) (a 1))])
(define-multi-id g3
#:type-expander (λ (stx) #'(List 'x))
#:else-id g2)
(λ ([x : g3]) x)

164
graph-lib/graph/graph-5-multi-ctors.lp2.rkt Normal file
View File

@ -0,0 +1,164 @@
#lang scribble/lp2
@(require "../lib/doc.rkt")
@doc-lib-setup
@title[#:style manual-doc-style]{Syntactic sugar for @racket[graph]: named
constructors}
@(table-of-contents)
@section{Introduction}
We define a wrapper around the @tc[graph] macro, which
@chunk[<signature>
(define-graph/multi-ctor name:id
((~commit [node:id <field-signature> …])
…)
(~commit <mapping-declaration>)
…)]
Where @tc[<field-signature>] is:
@chunk[<field-signature>
(~describe "[field : type]"
[field:id c:colon field-type:expr])]
And @tc[<mapping-declaration>] is:
@chunk[<mapping-declaration>
(~describe "[(mapping [param : type] …) : result . body]"
[(mapping:id [param:id :colon param-type:expr] …)
cm:colon result-node:id
. body])]
@chunk[<graph-multi-ctor>
(define-syntax/parse <signature>
(define-temp-ids "~a/wrapped" name)
(define-temp-ids "~a/mapping" (node …))
(define-temp-ids "~a/arg" (node …))
(define-temp-ids "~a/function" (mapping …))
(define-temp-ids "~a/hide" (node …))
(define-temp-ids "~a/hide" (result-node …))
(define/with-syntax ([(grouped-mapping
grouped-mapping/function
[(grouped-param . grouped-param-type) …]
grouped-result-node
grouped-body) …] …)
(stx-map (λ (n)
(multiassoc-syntax n #'((result-node
mapping
mapping/function
[(param . param-type) …]
result-node
body) …)))
#'(node …)))
(define/with-syntax (mapping/grouped …)
(stx-map (λ (mr) (cdr-assoc-syntax mr #'([node . node/mapping] …)))
#'(result-node …)))
(define/with-syntax all-nodes #'(node …))
; TODO: we should order the graph's nodes so that the root is
; the first one! (or add a #:root)
(define/with-syntax ((root-param …) . _) #'((param …) …))
(define/with-syntax ((root-param-type …) . _) #'((param-type …) …))
#`(debug
(begin
(define-graph name/wrapped
#:definitions
((define-multi-id name
#:type-expander
(λ (stx)
(syntax-case stx ()
[(_ . rest) #'(name/wrapped . rest)]))
#:else-id name/constructor)
(define (name/constructor [root-param : root-param-type] …)
(list name/wrapped root-param …))
<define-mappings>)
[node [field c field-type] …
((node/mapping [node/arg : <node-arg-type>])
<mapping-body>)]
…))))]
Where the type for the merged mapping is:
@chunk[<node-arg-type>
(U (List 'grouped-mapping grouped-param-type …) …)]
@chunk[<define-mappings>
(define (mapping/function node/hide … ; nodes
result-node/hide ; self
[param : param-type] …)
: (name result-node)
(let ([node node/hide] …)
(let ([result-node result-node/hide])
(? '<bdy>))))
…]
@chunk[<bdy>
(let ([node-names… node_]
;[mapping mapping/grouped] …
[node-name_ node_])
body)]
We then select in the grouped mapping which one to call.
@chunk[<mapping-body>
(let ((a node/arg))
(cond
[(eq? (car a) 'grouped-mapping)
(apply grouped-mapping/function
#,@#'(node …)
grouped-result-node
(cdr a))]
…))]
TODO: At the call site, use a macro and annotate the function (given by its
name) with the right type, so that the user doesn't see all the types in the
(U …).
@chunk[<test-graph-multi-ctor>
(check-equal? 42 42)]
@section{Conclusion}
@chunk[<module-main>
(module main typed/racket
(require (for-syntax syntax/parse
racket/syntax
syntax/stx
"../lib/low-untyped.rkt"
"../lib/low/multiassoc-syntax.rkt")
"../lib/low.rkt"
"graph.lp2.rkt"
"get.lp2.rkt"
"../type-expander/type-expander.lp2.rkt"
"../type-expander/multi-id.lp2.rkt")
(provide define-graph/multi-ctor)
(require (for-syntax racket/pretty))
(define-syntax (debug stx)
(syntax-case stx ()
[(_ body)
;; syntax->string
(pretty-print (syntax->datum #'body))
#'body]))
<graph-multi-ctor>)]
@chunk[<module-test>
(module* test typed/racket
(require (submod "..")
typed/rackunit)
<test-graph-multi-ctor>)]
@chunk[<*>
(begin
<module-main>
(require 'main)
(provide (all-from-out 'main))
<module-test>)]

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

@ -1,4 +1,4 @@
#lang debug scribble/lp2
#lang scribble/lp2
@(require "../lib/doc.rkt")
@doc-lib-setup
@ -111,9 +111,9 @@ that it first takes the node types and mappings, and produces a lambda taking
the root arguments as parameters.
@chunk[<use-example>
(define-graph make-g <example-variants>)
#;(define g (make-g <example-root>))
(define g1 (make-g <example-root>))
(define-graph gr <example-variants>)
#;(define g (gr <example-root>))
(define g1 (gr <example-root>))
(define g g1)]
@subsection{More details on the semantics}
@ -157,6 +157,8 @@ wrapper macros.
@chunk[<signature>
(define-graph name
(~optional (~and debug #:debug))
(~maybe #:definitions (extra-definition:expr …))
[node <field-signature> … <mapping-declaration>]
…)]
@ -205,6 +207,7 @@ We derive identifiers for these based on the @tc[node] name:
(define/with-syntax ((root-param …) . _) #'((param …) …))
(define/with-syntax ((root-param-type …) . _) #'((param-type …) …))
(define-temp-ids "~a/constructor" name)
(define-temp-ids "~a/make-placeholder" (node …) #:first-base root)
(define-temp-ids "~a/placeholder-type" (node …))
(define-temp-ids "~a/placeholder-tag" (node …))
@ -578,29 +581,66 @@ are replaced by tagged indices:
(error (~a "Not implemented yet " x)))]
|#]
@section{Referencing the type of nodes}
The identifier defined by @tc[define-graph] will both act as a constuctor for
graph instances, and as a type-expander, that we will use to reference the node
types. We will thus be able to refer to the type of Street nodes in our example
via @tc[(g Street)].
@chunk[<graph-type-expander>
(λ (stx)
(syntax-parse stx
[(_ (~datum node)) #'node/with-promises-type]
…
[(_ #:incomplete (~datum node)) #'node/incomplete-type]
…))]
We will be able to use this type expander in function types, for example:
@chunk[<type-example>
(λ ([x : (gr Street)])
x)]
@section{Putting it all together}
@chunk[<define-graph>
(define-syntax/parse <signature>
<define-ids>
#|((λ (x) (pretty-write (syntax->datum x)) x)|#
(template
;(let ()
(begin
(begin <define-placeholder-type>) …
(begin <define-make-placeholder>) …
(begin <define-with-indices>) …
(begin <define-with-promises>) …
(begin <define-incomplete>) …
(begin <define-mapping-function>) …
(: name (→ root-param-type … (Promise root/with-promises-type)))
(define (name root-param …)
(match-let ([(list node/database …) <fold-queues>])
(begin <define-with-indices→with-promises>) …
(let ([root/with-promises (root/with-indices→with-promises
(vector-ref root/database 0))])
(delay root/with-promises)))))))]
((λ (x)
(when (attribute debug)
(pretty-write (syntax->datum x)))
x)
(template
;(let ()
(begin
(begin <define-placeholder-type>) …
(begin <define-make-placeholder>) …
(begin <define-with-indices>) …
(begin <define-with-promises>) …
(begin <define-incomplete>) …
(begin <define-mapping-function>) …
(define-multi-id name
#:type-expander <graph-type-expander>
#:else-id name/constructor)
(?? (splicing-let ([mapping node/make-placeholder]
…
[node node/make-incomplete]
…)
extra-definition
…))
(: name/constructor (→ root-param-type …
(Promise root/with-promises-type)))
(define (name/constructor root-param …)
(match-let ([(list node/database …) <fold-queues>])
(begin <define-with-indices→with-promises>) …
(let ([root/with-promises (root/with-indices→with-promises
(vector-ref root/database 0))])
(delay root/with-promises))))))))]
@chunk[<module-main>
(module main typed/racket
@ -609,14 +649,17 @@ are replaced by tagged indices:
syntax/stx
syntax/parse/experimental/template
racket/sequence
racket/pretty
"rewrite-type.lp2.rkt"
"../lib/low-untyped.rkt")
racket/splicing
"fold-queues.lp2.rkt"
"rewrite-type.lp2.rkt"
"../lib/low.rkt"
"structure.lp2.rkt"
"variant.lp2.rkt"
"../type-expander/type-expander.lp2.rkt")
"../type-expander/type-expander.lp2.rkt"
"../type-expander/multi-id.lp2.rkt")
;(begin-for-syntax
;<multiassoc-syntax>)
@ -632,16 +675,13 @@ not match the one from @tc[typed/racket]
@chunk[<module-test>
(module* test typed/racket
(require (submod "..")
"fold-queues.lp2.rkt"; DEBUG
"rewrite-type.lp2.rkt"; DEBUG
"../lib/low.rkt"; DEBUG
"structure.lp2.rkt"; DEBUG
"variant.lp2.rkt"; DEBUG
(only-in "../lib/low.rkt" cars cdrs)
"../type-expander/type-expander.lp2.rkt"
typed/rackunit)
(provide g)
<use-example>)]
<use-example>
<type-example>)]
The whole file, finally:

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

@ -69,3 +69,12 @@
(structure sname)
(structure sname)
(structure st)
(structure v)
(structure v)
(structure b1 b2 v)
(structure a s v)
(structure b1 b2 v)
(structure b1 b2 v)
(structure v w)
(structure v w)
(structure v w)

4
graph-lib/lib/low.rkt
View File

@ -1423,6 +1423,8 @@
;; ==== low/typed-not-implemented-yet.rkt ====
(define-syntax-rule (? t) ((λ () : t (error "Not implemented yet"))))
(provide ?)
(define-syntax-rule (? t . rest) ((λ () : t (error "Not implemented yet")
. rest)))
;; ==== end ====