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

General cleanup and API cleanup for graph-6-rich-returns.lp2.rkt

Browse Source
This commit is contained in:
Georges Dupéron 2016-04-04 18:49:18 +02:00
parent cd150cf2b3
commit 30a78bdaa3
7 changed files with 354 additions and 350 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

145
graph-lib/graph/__DEBUG_graph6.rkt
View File

@ -1,78 +1,38 @@
#lang typed/racket #lang typed/racket
(require "graph-6-rich-returns.lp2.rkt" (module test-~>-bound typed/racket
"../lib/low.rkt" (require "graph-6-rich-returns.lp2.rkt"
"graph.lp2.rkt" "../lib/low.rkt"
"get.lp2.rkt" ;"graph.lp2.rkt"
"../type-expander/type-expander.lp2.rkt" "get.lp2.rkt"
"../type-expander/multi-id.lp2.rkt" "../type-expander/type-expander.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))
(define-type blob String)
(define-type-expander (bubble stx) #'String)
#| (define-graph
(require "__DEBUG_graph6B.rkt") 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)])
(frozen (~>)) (check-equal?: (% (x y) = (grr3 '(("a" "b" "c") ("d")))
|# in
(list (get x streets … sname)
(get y streets … sname)))
'(("a" "b" "c") ("d")))
(define-type blob String) ;; Check that there are no collisions:
(define-type-expander (bubble stx) #'String) ;; Same as above with just the graph name changed
(define-graph
(require (for-syntax syntax/strip-context)) grr4
(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)))]))
(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)])
(% (x y) = ((car DBG) '(("a" "b" "c") ("d")))
in
(list (get x streets … sname)
(get y streets … sname)))
#;(super-define-graph/rich-return
grr4
([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)])
#|
(define-syntax-rule (dg grr)
(define-graph/rich-return grr ~>
([City [streets : (~> m-streets)]] ([City [streets : (~> m-streets)]]
[Street [sname : String]]) [Street [sname : String]])
[(m-cities [cnames : (Listof (Listof bubble))]) [(m-cities [cnames : (Listof (Listof bubble))])
@ -84,7 +44,48 @@
: (Listof Street) : (Listof Street)
(map Street snames)])) (map Street snames)]))
(dg grr) (module test-~>-unbound typed/racket
(dg grra) (require "graph-6-rich-returns.lp2.rkt"
|# "get.lp2.rkt"
typed/rackunit
"../type-expander/type-expander.lp2.rkt")
(define-type blob String)
(define-type-expander (bubble stx) #'String)
(define-graph
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)])
(check-equal? (let ([l (grr3 '(("a" "b" "c") ("d")))])
(list (get (car l) streets … sname)
(get (cadr l) streets … sname)))
'(("a" "b" "c") ("d")))
;; Check that there are no collisions:
;; Same as above with just the graph name changed
(define-graph
grr4
([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)]))
(module test typed/racket
(require (submod ".." test-~>-bound))
(require (submod ".." test-~>-unbound)))

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

@ -56,7 +56,7 @@ mapping declarations from the node definitions:
@chunk[<signature> @chunk[<signature>
(define-graph/rich-return name:id id-~> (define-graph/rich-return name:id id-~>
(~optional (~and #:debug debug)) (~optkw #:debug)
((~commit [node:id <field-signature> …]) ((~commit [node:id <field-signature> …])
…) …)
(~commit <mapping-declaration>) (~commit <mapping-declaration>)
@ -110,9 +110,12 @@ plain list.
(define-syntax/parse <signature> (define-syntax/parse <signature>
(define/with-syntax (node* …) #'(node …)) (define/with-syntax (node* …) #'(node …))
(define-temp-ids "~a/first-step" name) (define-temp-ids "~a/first-step" name)
(define/with-syntax name/second-step ((make-syntax-introducer) #'name))
(define/with-syntax (root-mapping/result-type . _) #'(result-type …))
(define-temp-ids "first-step-expander2" name) (define-temp-ids "first-step-expander2" name)
(define-temp-ids "top1-accumulator-type" name) (define-temp-ids "top1-accumulator-type" name)
(define-temp-ids "~a/constructor-top2" (mapping …)) (define-temp-ids "~a/constructor-top2" (mapping …)
#:first-base root-mapping)
(define-temp-ids "~a/accumulator" (node …)) (define-temp-ids "~a/accumulator" (node …))
(define-temp-ids "~a/top2-roots" (node …)) (define-temp-ids "~a/top2-roots" (node …))
(define-temp-ids "~a/next-idx" (node …)) (define-temp-ids "~a/next-idx" (node …))
@ -133,22 +136,18 @@ plain list.
;(define/with-syntax introduced-~> (datum->syntax #'name '~>)) ;(define/with-syntax introduced-~> (datum->syntax #'name '~>))
(quasitemplate/debug debug (quasitemplate/debug debug
(begin (begin
#,(dbg (define-graph name/first-step
("first-pass" stx) #:definitions [<first-pass-type-expander>]
(quasitemplate [node [field c (Let [id-~> first-step-expander2] field-type)] …
(define-graph name/first-step [(node/simple-mapping [field c field-type] …)
#:definitions [<first-pass-type-expander>] ;<first-pass-field-type>] …)
[node [field c (Let [id-~> first-step-expander2] field-type)] (node field …)]] …
#| |#… [mapping/node [returned cm result-type]
[(node/simple-mapping [field c field-type] …) [(mapping [param cp param-type] …)
;<first-pass-field-type>] …) (mapping/node
(node field …)]] … (let ([node node/simple-mapping] …)
[mapping/node [returned cm result-type] . body))]]
[(mapping [param cp param-type] …) …)
(mapping/node
(let ([node node/simple-mapping] …)
. body))]]
…)))
;; TODO: how to return something else than a node?? ;; TODO: how to return something else than a node??
;; Possibility 1: add a #:main function to define-graph, which can ;; Possibility 1: add a #:main function to define-graph, which can
;; call (make-root). ;; call (make-root).
@ -199,7 +198,7 @@ produced by the first step.
(define-type mapping/node-marker (define-type mapping/node-marker
(tmpl-replace-in-type result-type (tmpl-replace-in-type result-type
[mapping/node mapping/node-marker] ;;;;;;;TODO: test: I'm unsure here [mapping/node mapping/node-marker] ;;;;;;;TODO: test: I'm unsure here
[node (name #:placeholder node)]) [node (name/second-step #:placeholder node)])
#;(U (name/first-step mapping/node) #;(U (name/first-step mapping/node)
(tmpl-replace-in-type result-type (tmpl-replace-in-type result-type
[mapping/node (name/first-step mapping/node)] [mapping/node (name/first-step mapping/node)]
@ -235,13 +234,7 @@ produced by the first step.
[(_ (~datum mapping)) [(_ (~datum mapping))
(syntax-local-introduce (syntax-local-introduce
#'(U second-step-mapping/node-of-first #'(U second-step-mapping/node-of-first
result-type result-type))]
; <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<THIS WORKED
#;(tmpl-replace-in-type result-type
[mapping/node (name/first-step mapping/node)]
[node (name/first-step node)])))]
… …
;; TODO: should fall-back to outer definition of ~>, if any? ;; TODO: should fall-back to outer definition of ~>, if any?
))] ))]
@ -281,23 +274,22 @@ identifier, so that it can be matched against by
@CHUNK[<step2> @CHUNK[<step2>
#,(quasitemplate/debug name (define-graph name/second-step
(define-graph name #:definitions [<second-step-~>-expander>
#:definitions [<second-step-~>-expander> <second-step-marker-expander>
<second-step-marker-expander> <inline-type>
<inline-type> <inline-instance>]
<inline-instance>] [node [field c (Let [id-~> ~>-to-result-type] field-type)] …
[node [field c (Let [id-~> ~>-to-result-type] field-type)] … [(node/extract/mapping [from : (name/first-step node)])
[(node/extract/mapping [from : (name/first-step node)]) <inlined-node>]]
<inlined-node>]] …)
…))
<inline-type-top1> <inline-type-top1>
<inline-instance-top1-types> <inline-instance-top1-types>
<inline-instance-top1> <inline-instance-top1>
<outer-inline> <inline-instance-top3>
<inline-instance-top2> <inline-instance-top2>
<inline-instance-top3>] <define-multi-id>]
We create the inlined-node by inlining the temporary nodes We create the inlined-node by inlining the temporary nodes
in all of its fields: in all of its fields:
@ -314,27 +306,22 @@ recursively:
@CHUNK[<inline-instance> @CHUNK[<inline-instance>
(define-syntax (inline-instance* stx) (define-syntax (inline-instance* stx)
(dbg (syntax-parse stx
("inline-instance*" stx) [(_ i-ty seen)
(syntax-parse stx (define/with-syntax replt
[(_ i-ty seen) (replace-in-type #'(Let (id-~> second-step-marker2-expander)
(define/with-syntax replt i-ty)
(replace-in-type #'(Let (id-~> second-step-marker2-expander) #'([node second-step-node-of-first]
i-ty) …)))
#'([node second-step-node-of-first] #'(inline-instance replt seen)]))
…)))
(displayln (list "replt=" #'replt))
#'(inline-instance replt seen)])))
(define-syntax (inline-instance stx) (define-syntax (inline-instance stx)
(dbg (syntax-parse stx
("inline-instance" stx) [(_ i-t (~and seen (:id (… …))))
(syntax-parse stx <inline-check-seen>
[(_ i-t (~and seen (:id (… …)))) (replace-in-instance #'i-t
<inline-check-seen> #'(<inline-instance-replacement>
(replace-in-instance #'i-t <inline-instance-nodes>))]))]
#'(<inline-instance-replacement>
<inline-instance-nodes>))])))]
@chunk[<inline-instance-replacement> @chunk[<inline-instance-replacement>
[second-step-mapping/node-of-first ;; from [second-step-mapping/node-of-first ;; from
@ -347,7 +334,7 @@ recursively:
@chunk[<inline-instance-nodes> @chunk[<inline-instance-nodes>
[second-step-node-of-first ;; node of first step ;; from [second-step-node-of-first ;; node of first step ;; from
(name #:placeholder node) ;; new type ;; to (name/second-step #:placeholder node) ;; new type ;; to
(name/first-step #:? node) ;; pred? (name/first-step #:? node) ;; pred?
node/extract/mapping] ;; call mapping ;; fun node/extract/mapping] ;; call mapping ;; fun
…] …]
@ -368,11 +355,6 @@ layer of actual nodes. We do this in three steps:
@item{Finally, we replace the placeholders with the @item{Finally, we replace the placeholders with the
second-pass nodes returned by the graph.}] second-pass nodes returned by the graph.}]
@CHUNK[<outer-inline>
(inline-instance-top1* result-type ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
())
…]
@CHUNK[<inline-instance-top1-types> @CHUNK[<inline-instance-top1-types>
(define-constructor mapping/node-index (define-constructor mapping/node-index
#:private #:private
@ -399,29 +381,24 @@ layer of actual nodes. We do this in three steps:
@CHUNK[<inline-instance-top1> @CHUNK[<inline-instance-top1>
(define-syntax (inline-instance-top1* stx) (define-syntax (inline-instance-top1* stx)
(dbg (syntax-parse stx
("inline-instance-top1*" stx) [(_ i-ty seen)
(syntax-parse stx (define/with-syntax replt
[(_ i-ty seen) (replace-in-type #'(Let (id-~> second-step-marker2-top-expander)
(define/with-syntax replt i-ty)
(replace-in-type #'(Let (id-~> second-step-marker2-top-expander) #'([node second-step-node-of-first]
i-ty) …)))
#'([node second-step-node-of-first] #'(inline-instance-top1 replt seen)]))
…)))
(displayln (list "replt-top=" #'replt))
#'(inline-instance-top1 replt seen)])))
(define-syntax (inline-instance-top1 stx) (define-syntax (inline-instance-top1 stx)
(dbg (syntax-parse stx
("inline-instance-top1" stx) [(_ i-t (~and seen (:id (… …))))
(syntax-parse stx <inline-check-seen>
[(_ i-t (~and seen (:id (… …)))) ;(replace-in-instance #'i-t
<inline-check-seen> (fold-instance #'i-t
;(replace-in-instance #'i-t #'top1-accumulator-type
(fold-instance #'i-t #'(<inline-instance-top1-replacement>
#'top1-accumulator-type <inline-instance-top1-nodes>))]))]
#'(<inline-instance-top1-replacement>
<inline-instance-top1-nodes>))])))]
@chunk[<inline-instance-top1-replacement> @chunk[<inline-instance-top1-replacement>
[second-step-mapping/node-of-first ;; from [second-step-mapping/node-of-first ;; from
@ -457,14 +434,12 @@ layer of actual nodes. We do this in three steps:
@chunk[<inline-type-top1> @chunk[<inline-type-top1>
(define-type-expander (inline-type-top1 stx) (define-type-expander (inline-type-top1 stx)
(dbg (syntax-parse stx
("inline-type-top1" stx) [(_ i-t (~and seen (:id (… …))))
(syntax-parse stx <inline-check-seen>
[(_ i-t (~and seen (:id (… …)))) (replace-in-type #'(Let ([id-~> second-step-marker-expander]) i-t)
<inline-check-seen> #'(<inline-type-top1-replacement>
(replace-in-type #'(Let ([id-~> second-step-marker-expander]) i-t) <inline-type-top1-nodes>))]))]
#'(<inline-type-top1-replacement>
<inline-type-top1-nodes>))])))]
@chunk[<inline-type-top1-replacement> @chunk[<inline-type-top1-replacement>
@ -480,10 +455,7 @@ layer of actual nodes. We do this in three steps:
@chunk[<inline-instance-top2> @chunk[<inline-instance-top2>
(define (mapping/constructor-top2 [param cp param-type] …) (define (mapping/constructor-top2 [param cp param-type] …)
(% <constructor-top2-body>)) (% <constructor-top2-body>))
… …]
(define #,(datum->syntax #'name 'DBG)
(list mapping/constructor-top2 …))]
@chunk[<constructor-top2-body> @chunk[<constructor-top2-body>
first-graph = (name/first-step #:root mapping/node param …) first-graph = (name/first-step #:root mapping/node param …)
@ -496,56 +468,74 @@ layer of actual nodes. We do this in three steps:
(assert (= (length node/accumulator) node/next-idx)) (assert (= (length node/accumulator) node/next-idx))
;; Call the second step graph constructor: ;; Call the second step graph constructor:
(% (node/top2-roots …) (% (node/top2-roots …)
= (name #:roots [node (reverse (lists (cdrs node/accumulator)))] …) = (name/second-step
#:roots [node (reverse (lists (cdrs node/accumulator)))] …)
in in
((replace-markers-top3 result-type ((replace-markers-top3 result-type
node/top2-roots …) node/top2-roots …)
with-indices-top1))] with-indices-top1))]
@chunk[<inline-instance-top3> @chunk[<inline-instance-top3>
(define-syntax (replace-markers-top3 stx) (define-type-expander (inline-type-top3 stx)
(dbg (syntax-parse stx
("inline-instance-top3*" stx) [(_ i-ty)
(syntax-parse stx (replace-in-type #'(inline-type-top1 i-ty ())
[(_ i-ty node/top2-roots …) #'([mapping/node-index-marker ;; from
(displayln (replace-in-type #'(inline-type-top1 i-ty ()) (name/second-step node)] ;; to
#'[])) …))]))
(replace-in-instance #'(inline-type-top1 i-ty ())
#'([mapping/node-index-marker ;; from
(name node) ;; to
mapping/node-index? ;; pred?
(λ ([idx : mapping/node-index]) ;; fun
(vector-ref node/top2-roots
(constructor-values idx)))]
…))])))
#;(define-syntax (inline-instance-top3* stx)
(dbg
("inline-instance-top3*" stx)
(syntax-parse stx
[(_ i-ty seen node/top2-roots …)
(define/with-syntax replt
(replace-in-type #'(Let (id-~> second-step-marker2-top-expander)
i-ty)
#'([node second-step-node-of-first]
…)))
(displayln (list "replt-top=" #'replt))
#'(inline-instance-top3 replt seen node/top2-roots …)])))
#;(define-syntax (inline-instance-top3 stx) (define-syntax (replace-markers-top3 stx)
(dbg (syntax-parse stx
("inline-instance-top3" stx) [(_ i-ty node/top2-roots …)
(syntax-parse stx (replace-in-instance #'(inline-type-top1 i-ty ())
[(_ i-t (~and seen (:id (… …))) node/top2-roots …) #'([mapping/node-index-marker ;; from
<inline-check-seen> (name/second-step node) ;; to
;(replace-in-instance #'i-t mapping/node-index? ;; pred?
(replace-in-instance #'i-t (λ ([idx : mapping/node-index]) ;; fun
#'([mapping/node-index-marker ;; from (vector-ref node/top2-roots
(name node) ;; to (constructor-values idx)))]
mapping/node-index? ;; pred? …))]))]
(λ ([idx : mapping/node-index]) ;; fun
(vector-ref node/top2-roots @subsection{The main graph macro}
(constructor-values idx)))]
…))])))] @; TODO: move this to a separate file:
@chunk[<define-multi-id>
(define-multi-id name
#:type-expander <graph-type-expander>
#:call (λ (stx)
(syntax-parse stx
;; TODO: move this to a dot expander, so that writing
;; g.a gives a constructor for the a node of g, and
;; (g.a foo bar) or (let ((c .g.a)) (c foo bar)) both
;; call it
[(_ #:λroot (~datum mapping))
#'root-mapping/constructor-top2]
…
[(_ #:root (~datum mapping) . rest)
(syntax/loc stx (mapping/constructor-top2 . rest))]
…
#;[(_ #:roots [(~datum node) node/multi-rest] …)
(syntax/loc stx
(name/multi-constructor node/multi-rest …))]
;; TODO: TR has issues with occurrence typing and promises,
;; so we should wrap the nodes in a tag, which contains a
;; promise, instead of the opposite (tag inside promise).
[(_ #:? (~datum node))
;; TODO: implement node? properly here! FB case 107
(syntax/loc stx (name/second-step #:? node))]
…
[(_ . rest)
(syntax/loc stx (root-mapping/constructor-top2 . rest))]))
#:id (λ (stx) #'root-mapping/constructor-top2))]
@chunk[<graph-type-expander>
(λ (stx)
(syntax-parse stx
[:id #'(inline-type-top3 root-mapping/result-type)]
[(_ (~datum mapping)) #'(inline-type-top3 result-type)]
…
[(_ . rest) #'(name/second-step . rest)]))]
@subsection{Inlining types} @subsection{Inlining types}
@ -660,24 +650,22 @@ which does not allow variants of (~> …).
@chunk[<inline-type> @chunk[<inline-type>
(define-type-expander (inline-type stx) (define-type-expander (inline-type stx)
(dbg (syntax-parse stx
("inline-type" stx) [(_ i-t (~and seen (:id (… …))))
(syntax-parse stx <inline-check-seen>
[(_ i-t (~and seen (:id (… …)))) (replace-in-type #'(Let ([id-~> second-step-marker-expander]) i-t)
<inline-check-seen> #'(<inline-type-replacement>
(replace-in-type #'(Let ([id-~> second-step-marker-expander]) i-t) <inline-type-nodes>))]))]
#'(<inline-type-replacement>
<inline-type-nodes>))])))]
@chunk[<inline-type-replacement> @chunk[<inline-type-replacement>
[second-step-mapping/node-of-first ;; from [second-step-mapping/node-of-first ;; from
(inline-type result-type (mapping/node . seen))] ;; to (inline-type result-type (mapping/node . seen))] ;; to
…] …]
@chunk[<inline-type-nodes> @chunk[<inline-type-nodes>
[node ;second-step-node-of-first ;; generated by the first pass [node ;second-step-node-of-first ;; generated by the first pass
(name #:placeholder node)] ;; new type (name/second-step #:placeholder node)] ;; new type
…] …]
We detect the possibility of unbounded recursion when We detect the possibility of unbounded recursion when
@ -733,45 +721,49 @@ encapsulating the result types of mappings.
@section{Conclusion} @section{Conclusion}
@CHUNK[<super-graph-rich-return>
(define-syntax (super-define-graph/rich-return stx)
(syntax-case stx ()
[(_ name . rest)
(with-syntax ([(b (d (dgi n) . r) (dgi2 n2))
#`(begin
(define-syntax-rule (dg1 name)
(define-graph/rich-return name
#,(replace-context stx #'~>)
. rest))
(dg1 name))])
#'(b (d (dgX n) . r) (dgX n2)))]))]
@chunk[<module-main> @chunk[<module-main>
(module main typed/racket (module main typed/racket
(provide define-graph/rich-return)
(require (for-syntax syntax/parse (require (for-syntax syntax/parse
syntax/parse/experimental/template syntax/parse/experimental/template
racket/syntax racket/syntax
(submod "../lib/low.rkt" untyped) (submod "../lib/low.rkt" untyped)
"rewrite-type.lp2.rkt" #|debug|# "rewrite-type.lp2.rkt"
syntax/id-set racket/format)
racket/format "../lib/low.rkt"
mischief/transform)
(rename-in "../lib/low.rkt" [~> threading:~>])
"graph.lp2.rkt" "graph.lp2.rkt"
"get.lp2.rkt" "get.lp2.rkt"
"../type-expander/type-expander.lp2.rkt" "../type-expander/type-expander.lp2.rkt"
"../type-expander/multi-id.lp2.rkt" "../type-expander/multi-id.lp2.rkt"
"adt.lp2.rkt" ; debug "adt.lp2.rkt"
"fold-queues.lp2.rkt"; debug "rewrite-type.lp2.rkt")
"rewrite-type.lp2.rkt"; debug
"meta-struct.rkt"; debug
racket/stxparam
racket/splicing)
(provide define-graph/rich-return
(for-syntax dbg) ;; DEBUG
)
(require (for-syntax racket/pretty))
(begin-for-syntax
(define-syntax-rule (dbg log . body)
(begin
(display ">>> ")(displayln (list . log))
(let ((res (let () . body)))
(display "<<< ")(displayln (list . log))
(display "<<<= ")(display (car (list . log)))
(display res)(displayln ".")
res))))
<graph-rich-return>)] <graph-rich-return>)]
@chunk[<module-test> @chunk[<module-wrapper>
(module wrapper typed/racket
(provide (rename-out [super-define-graph/rich-return define-graph]))
(require (submod ".." main)
(for-syntax syntax/strip-context))
<super-graph-rich-return>)]
@chunk[<module-test-syntax>
(module test-syntax racket (module test-syntax racket
(provide tests) (provide tests)
(define tests (define tests
@ -782,8 +774,9 @@ encapsulating the result types of mappings.
@chunk[<*> @chunk[<*>
(begin (begin
<module-main> <module-main>
<module-wrapper>
(require 'main) (require 'wrapper)
(provide (all-from-out 'main)) (provide (all-from-out 'wrapper))
<module-test>)] <module-test-syntax>)]

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

@ -320,11 +320,9 @@ The graph name will be used in several ways:
[(_ #:roots [(~datum node) node/multi-rest] …) [(_ #:roots [(~datum node) node/multi-rest] …)
(syntax/loc stx (syntax/loc stx
(name/multi-constructor node/multi-rest …))] (name/multi-constructor node/multi-rest …))]
;; TODO: TR has issues with occurrence typing and promises,
;; so we should wrap the nodes in a tag, which contains a
;; promise, instead of the opposite (tag inside promise).
[(_ #:? (~datum node)) [(_ #:? (~datum node))
(syntax/loc stx node?)] ;;;;;;;;;;;;;;;TODO: implement node? properly here! FB case 107 ;; TODO: implement node? properly here! FB case 107
(syntax/loc stx node?)]
… …
[(_ . rest) [(_ . rest)
(syntax/loc stx (root/constructor . rest))])) (syntax/loc stx (root/constructor . rest))]))

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

@ -40,7 +40,7 @@ relies on the lower-level utilities provided by this module, namely
(: name (→ type #,(replace-in-type #'type #'([from to] ...)))) (: name (→ type #,(replace-in-type #'type #'([from to] ...))))
(define (name v) (define (name v)
(#,(replace-in-instance #'type (#,(replace-in-instance #'type
#'([from to pred? fun] ...)) #'([from to pred? fun] ...))
v)))]))] v)))]))]
@subsection{A bigger example} @subsection{A bigger example}
@ -146,10 +146,10 @@ offloaded to a separate subroutine.
(define (replace-in-instance val t r) (define (replace-in-instance val t r)
(parameterize-push-stx ([current-replacement (parameterize-push-stx ([current-replacement
`(replace-in-instance ,val ,t ,r)]) `(replace-in-instance ,val ,t ,r)])
(define/with-syntax ([from to fun] ...) r) (define/with-syntax ([from to fun] ...) r)
<recursive-replace-in-instance> <recursive-replace-in-instance>
<replace-in-union> <replace-in-union>
(recursive-replace val t)))] (recursive-replace val t)))]
The @tc[recursive-replace] internal function defined below takes a type The @tc[recursive-replace] internal function defined below takes a type
@tc[type] and produces an expression that transforms instances of that type @tc[type] and produces an expression that transforms instances of that type
@ -174,55 +174,55 @@ The other cases are similarly defined:
(define (recursive-replace stx-val type) (define (recursive-replace stx-val type)
(parameterize-push-stx ([current-replacement (parameterize-push-stx ([current-replacement
`(recursive-replace ,stx-val ,type)]) `(recursive-replace ,stx-val ,type)])
(define/with-syntax val stx-val) (define/with-syntax val stx-val)
(define/with-syntax (v-cache) (generate-temporaries #'(val-cache))) (define/with-syntax (v-cache) (generate-temporaries #'(val-cache)))
(syntax-parse type (syntax-parse type
#:context `(recursive-replace-2 ,(current-replacement)) #:context `(recursive-replace-2 ,(current-replacement))
[x:id [x:id
#:attr assoc-from-to (cdr-stx-assoc #'x #:attr assoc-from-to (cdr-stx-assoc #'x
#'((from . (to . fun)) ...)) #'((from . (to . fun)) ...))
#:when (attribute assoc-from-to) #:when (attribute assoc-from-to)
#:with (to-type . to-fun) #'assoc-from-to #:with (to-type . to-fun) #'assoc-from-to
(define/with-syntax (tmp) (generate-temporaries #'(x))) (define/with-syntax (tmp) (generate-temporaries #'(x)))
;; TODO: Add predicate for to-type in the pattern. ;; TODO: Add predicate for to-type in the pattern.
#`(to-fun val)] #`(to-fun val)]
[((~literal List) a ...) [((~literal List) a ...)
(define/with-syntax (tmp ...) (generate-temporaries #'(a ...))) (define/with-syntax (tmp ...) (generate-temporaries #'(a ...)))
#`(let-values ([(tmp ...) (apply values val)]) #`(let-values ([(tmp ...) (apply values val)])
(list #,@(stx-map recursive-replace #'(tmp ...) #'(a ...))))] (list #,@(stx-map recursive-replace #'(tmp ...) #'(a ...))))]
<replace-in-instance-case-pairof> <replace-in-instance-case-pairof>
[((~literal Listof) a) [((~literal Listof) a)
(define/with-syntax (tmp) (generate-temporaries #'(a))) (define/with-syntax (tmp) (generate-temporaries #'(a)))
#`(map (λ ([tmp : a]) #,(recursive-replace #'tmp #'a)) #`(map (λ ([tmp : a]) #,(recursive-replace #'tmp #'a))
val)] val)]
[((~literal Vector) a ...) [((~literal Vector) a ...)
(define/with-syntax (tmp ...) (generate-temporaries #'(a ...))) (define/with-syntax (tmp ...) (generate-temporaries #'(a ...)))
(define/with-syntax (idx ...) (generate-indices #'(a ...))) (define/with-syntax (idx ...) (generate-indices #'(a ...)))
#`(let ([v-cache val]) #`(let ([v-cache val])
(let ([tmp (vector-ref v-cache idx)] (let ([tmp (vector-ref v-cache idx)]
...) ...)
(vector-immutable #,@(stx-map recursive-replace (vector-immutable #,@(stx-map recursive-replace
#'(tmp ...) #'(tmp ...)
#'(a ...)))))] #'(a ...)))))]
[((~literal Vectorof) a) [((~literal Vectorof) a)
(define/with-syntax (tmp) (generate-temporaries #'(a))) (define/with-syntax (tmp) (generate-temporaries #'(a)))
;; Inst because otherwise it won't widen the inferred mutable ;; Inst because otherwise it won't widen the inferred mutable
;; vector elements' type. ;; vector elements' type.
#`((inst vector->immutable-vector #`((inst vector->immutable-vector
#,(replace-in-type #'a #'([from to] ...))) #,(replace-in-type #'a #'([from to] ...)))
(list->vector (list->vector
(map (λ ([tmp : a]) #,(recursive-replace #'tmp #'a)) (map (λ ([tmp : a]) #,(recursive-replace #'tmp #'a))
(vector->list val))))] (vector->list val))))]
[(~and whole ((~literal U) a ...)) [(~and whole ((~literal U) a ...))
#`(let ([v-cache val]) #`(let ([v-cache val])
(cond (cond
#,@(stx-map (λ (ta) #,@(stx-map (λ (ta)
(replace-in-union #'v-cache ta r #'whole)) (replace-in-union #'v-cache ta r #'whole))
#'(a ...))))] #'(a ...))))]
[((~literal quote) a) [((~literal quote) a)
#'val] #'val]
[x:id [x:id
#'val])))] #'val])))]
For unions, we currently support only tagged unions, that is unions where each For unions, we currently support only tagged unions, that is unions where each
possible type is a @tc[List] with a distinct @tc[tag] in its first element. possible type is a @tc[List] with a distinct @tc[tag] in its first element.
@ -289,12 +289,13 @@ functions is undefined.
@CHUNK[<fold-instance> @CHUNK[<fold-instance>
(define (fold-instance whole-type stx-acc-type r) (define (fold-instance whole-type stx-acc-type r)
(parameterize-push-stx ([current-replacement (parameterize-push-stx
`(fold-instance ,whole-type ,stx-acc-type ,r)]) ([current-replacement
(define/with-syntax acc-type stx-acc-type) `(fold-instance ,whole-type ,stx-acc-type ,r)])
(define/with-syntax ([from to pred? fun] ...) r) (define/with-syntax acc-type stx-acc-type)
<recursive-replace-fold-instance> (define/with-syntax ([from to pred? fun] ...) r)
(recursive-replace whole-type)))] <recursive-replace-fold-instance>
(recursive-replace whole-type)))]
@CHUNK[<recursive-replace-fold-instance> @CHUNK[<recursive-replace-fold-instance>
(define (new-type-for stx) (replace-in-type stx #'([from to] ...))) (define (new-type-for stx) (replace-in-type stx #'([from to] ...)))
@ -503,38 +504,38 @@ one for @tc[replace-in-type]:
@CHUNK[<template-metafunctions> @CHUNK[<template-metafunctions>
(define-template-metafunction (tmpl-replace-in-type stx) (define-template-metafunction (tmpl-replace-in-type stx)
(parameterize-push-stx ([current-replacement stx]) (parameterize-push-stx ([current-replacement stx])
(syntax-parse stx (syntax-parse stx
#:context `(tmpl-replace-in-type-6 ,(current-replacement)) #:context `(tmpl-replace-in-type-6 ,(current-replacement))
[(_ (~optkw #:debug) type:expr [from to] …) [(_ (~optkw #:debug) type:expr [from to] …)
(when (attribute debug) (when (attribute debug)
(displayln (format "~a" stx))) (displayln (format "~a" stx)))
(let ([res #`#,(replace-in-type #'type (let ([res #`#,(replace-in-type #'type
#'([from to] …))]) #'([from to] …))])
(when (attribute debug) (when (attribute debug)
(displayln (format "=> ~a" res))) (displayln (format "=> ~a" res)))
res)])))] res)])))]
And one each for @tc[fold-instance] and @tc[replace-in-instance2]: And one each for @tc[fold-instance] and @tc[replace-in-instance2]:
@CHUNK[<template-metafunctions> @CHUNK[<template-metafunctions>
(define-template-metafunction (tmpl-fold-instance stx) (define-template-metafunction (tmpl-fold-instance stx)
(parameterize-push-stx ([current-replacement stx]) (parameterize-push-stx ([current-replacement stx])
(syntax-parse stx (syntax-parse stx
#:context `(tmpl-fold-instance-7 ,(current-replacement)) #:context `(tmpl-fold-instance-7 ,(current-replacement))
[(_ type:expr acc-type:expr [from to pred? fun] …) [(_ type:expr acc-type:expr [from to pred? fun] …)
#`(begin #`(begin
"fold-instance expanded code below. Initially called with:" "fold-instance expanded code below. Initially called with:"
'(fold-instance type acc-type [from to pred? λ…] …) '(fold-instance type acc-type [from to pred? λ…] …)
#,(fold-instance #'type #,(fold-instance #'type
#'acc-type #'acc-type
#'([from to pred? fun] …)))]))) #'([from to pred? fun] …)))])))
(define-template-metafunction (tmpl-replace-in-instance stx) (define-template-metafunction (tmpl-replace-in-instance stx)
(parameterize-push-stx ([current-replacement stx]) (parameterize-push-stx ([current-replacement stx])
(syntax-parse stx (syntax-parse stx
#:context `(tmpl-replace-in-instance-8 ,(current-replacement)) #:context `(tmpl-replace-in-instance-8 ,(current-replacement))
[(_ type:expr [from to pred? fun] …) [(_ type:expr [from to pred? fun] …)
#`#,(replace-in-instance2 #'type #'([from to pred? fun] …))])))] #`#,(replace-in-instance2 #'type #'([from to pred? fun] …))])))]
These metafunctions just extract the arguments for @tc[replace-in-type] and These metafunctions just extract the arguments for @tc[replace-in-type] and
@tc[replace-in-instance2], and pass them to these functions. @tc[replace-in-instance2], and pass them to these functions.

22
graph-lib/lib/doc/unicode-chars.sty.rkt
View File

@ -3,12 +3,15 @@
(define unicode-chars (define unicode-chars
@string-append|<<<{ @string-append|<<<{
\makeatletter \makeatletter
% Must be loaded after MnSymbol!!! MnSymbol improperly defines × and ¬ in such a way that they don't work in math mode. % Must be loaded after MnSymbol!!! MnSymbol improperly defines × and ¬ in such a
% way that they don't work in math mode.
% definition of some characters, for use with % definition of some characters, for use with
% \usepackage[utf8]{inputenc} % \usepackage[utf8]{inputenc}
% \usepackage[T1]{fontenc} % \usepackage[T1]{fontenc}
% Author: Christoph Lange <math.semantic.web@gmail.com> % Author: Christoph Lange <math.semantic.web@gmail.com>
% Some math characters taken from John Wickerson's MathUnicode.sty (http://tex.stackexchange.com/questions/110042/entering-unicode-math-symbols-into-latex-direct-from-keyboard-on-a-mac) % Some math characters taken from John Wickerson's MathUnicode.sty
% (http://tex.stackexchange.com/questions/110042/
% entering-unicode-math-symbols-into-latex-direct-from-keyboard-on-a-mac)
% https://github.com/clange/latex % https://github.com/clange/latex
\NeedsTeXFormat{LaTeX2e}[1999/12/01] \NeedsTeXFormat{LaTeX2e}[1999/12/01]
\ProvidesPackage{unicode-chars}[2013/10/08] \ProvidesPackage{unicode-chars}[2013/10/08]
@ -24,7 +27,8 @@
\catcode`\^^a0=13\relax\def {~}% " " (nbsp) \catcode`\^^a0=13\relax\def {~}% " " (nbsp)
\catcode`\^^a3=13\relax\def£{\pounds}% £ \catcode`\^^a3=13\relax\def£{\pounds}% £
\catcode`\^^ae=13\relax\def®{\textsuperscript{\textregistered}}% ® \catcode`\^^ae=13\relax\def®{\textsuperscript{\textregistered}}% ®
\catcode`\^^af=13\relax\def¯{\ensuremath{^-}}% ¯ % macron (overline, overbar) % macron: overline, overbar
\catcode`\^^af=13\relax\def¯{\ensuremath{^-}}% ¯ % macron
% \catcode`\^^f1=13\relax\defñ{\~{n}}% ñ % \catcode`\^^f1=13\relax\defñ{\~{n}}% ñ
% Declared by MnSymbol: % Declared by MnSymbol:
% \catcode`\^^d7=13\relax\def×{\ensuremath{\times}}% × % \catcode`\^^d7=13\relax\def×{\ensuremath{\times}}% ×
@ -51,13 +55,15 @@
\DeclareUnicodeCharacter{03A1}{\ensuremath{\Rho}}% Ρ \DeclareUnicodeCharacter{03A1}{\ensuremath{\Rho}}% Ρ
\DeclareUnicodeCharacter{2190}{\ensuremath{\leftarrow}}% ← \DeclareUnicodeCharacter{2190}{\ensuremath{\leftarrow}}% ←
\DeclareUnicodeCharacter{2192}{\ensuremath{\rightarrow}}% → \DeclareUnicodeCharacter{2192}{\ensuremath{\rightarrow}}% →
% 2192: \textrightarrow is not available in all fonts, and we need the right arrow in math mode % 2192: \textrightarrow is not available in all fonts,
% and we need the right arrow in math mode
\DeclareUnicodeCharacter{2193}{\ensuremath{\downarrow}}% ↓ \DeclareUnicodeCharacter{2193}{\ensuremath{\downarrow}}% ↓
\DeclareUnicodeCharacter{2194}{\ensuremath{\leftrightarrow}}% ↔ \DeclareUnicodeCharacter{2194}{\ensuremath{\leftrightarrow}}% ↔
\DeclareUnicodeCharacter{21A6}{\ensuremath{\mapsto}}% ↦ \DeclareUnicodeCharacter{21A6}{\ensuremath{\mapsto}}% ↦
\DeclareUnicodeCharacter{21C0}{\ensuremath{\rightharpoonup}}% ⇀ \DeclareUnicodeCharacter{21C0}{\ensuremath{\rightharpoonup}}% ⇀
\DeclareUnicodeCharacter{21D2}{\ensuremath{\Rightarrow}}% ⇒ \DeclareUnicodeCharacter{21D2}{\ensuremath{\Rightarrow}}% ⇒
\DeclareUnicodeCharacter{2200}{\ensuremath{\operatorname{\forall}}}% ∀ % Georges — added \operatorname{} % Georges — added \operatorname{} in ∀ .
\DeclareUnicodeCharacter{2200}{\ensuremath{\operatorname{\forall}}}% ∀
\DeclareUnicodeCharacter{2203}{\ensuremath{\exists}}% ∃ \DeclareUnicodeCharacter{2203}{\ensuremath{\exists}}% ∃
\DeclareUnicodeCharacter{2208}{\ensuremath{\in}}% ∈ \DeclareUnicodeCharacter{2208}{\ensuremath{\in}}% ∈
\DeclareUnicodeCharacter{2209}{\ensuremath{\not\in}}% ∉ \DeclareUnicodeCharacter{2209}{\ensuremath{\not\in}}% ∉
@ -161,7 +167,11 @@
% \DeclareUnicodeCharacter{2026}{\ensuremath{\dots}}% … % \DeclareUnicodeCharacter{2026}{\ensuremath{\dots}}% …
% Generated from ~/.XCompose using: % Generated from ~/.XCompose using:
% cat /tmp/cal.txt | cut -d '"' -f 2- | tr '"' ' ' | cut -d ' ' -f 1,6 | while IFS=' ' read a b; do echo "\\DeclareUnicodeCharacter{$(printf "%X" "'$a")}{\\\\ensuremath{\\mathcal{$b}}}% $a"; done % cat /tmp/cal.txt | cut -d '"' -f 2- | tr '"' ' ' | cut -d ' ' -f 1,6 \
% | while IFS=' ' read a b; do
% echo -n "\\DeclareUnicodeCharacter{$(printf "%X" "'$a")}"
% echo "{\\\\ensuremath{\\mathcal{$b}}}% $a";
% done
\DeclareUnicodeCharacter{1D49C}{\ensuremath{\mathcal{A}}}% 𝒜 \DeclareUnicodeCharacter{1D49C}{\ensuremath{\mathcal{A}}}% 𝒜
\DeclareUnicodeCharacter{212C}{\ensuremath{\mathcal{B}}}% ℬ \DeclareUnicodeCharacter{212C}{\ensuremath{\mathcal{B}}}% ℬ

3
graph-lib/lib/low/percent.rkt
View File

@ -29,7 +29,8 @@
(define-splicing-syntax-class %assignment (define-splicing-syntax-class %assignment
#:attributes ([pat.expanded 1] [expr 0]) #:attributes ([pat.expanded 1] [expr 0])
#:literals (= in) #:literals (= in)
(pattern (~seq (~and maybe-pat (~not (~or = in))) ... (~datum =) expr:expr) (pattern (~seq (~and maybe-pat (~not (~or = in))) ...
(~datum =) expr:expr)
#:with [pat:%pat ...] #'(maybe-pat ...)))) #:with [pat:%pat ...] #'(maybe-pat ...))))
(define-syntax (% stx) (define-syntax (% stx)

2
graph-lib/make/make.rkt
View File

@ -18,7 +18,7 @@
"-exec" "cp" "-af" "{}" "./build/" ";")) "-exec" "cp" "-af" "{}" "./build/" ";"))
(current-directory "build")) (current-directory "build"))
#;(run! (list (find-executable-path-or-fail "sh") (run! (list (find-executable-path-or-fail "sh")
"-c" "-c"
@string-append{ @string-append{
found_long_lines=0 found_long_lines=0