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

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

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

221
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,13 +136,9 @@ 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
("first-pass" stx)
(quasitemplate
(define-graph name/first-step (define-graph name/first-step
#:definitions [<first-pass-type-expander>] #:definitions [<first-pass-type-expander>]
[node [field c (Let [id-~> first-step-expander2] field-type)] [node [field c (Let [id-~> first-step-expander2] field-type)] …
#| |#…
[(node/simple-mapping [field c field-type] …) [(node/simple-mapping [field c field-type] …)
;<first-pass-field-type>] …) ;<first-pass-field-type>] …)
(node field …)]] … (node field …)]] …
@ -148,7 +147,7 @@ plain list.
(mapping/node (mapping/node
(let ([node node/simple-mapping] …) (let ([node node/simple-mapping] …)
. body))]] . 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,8 +274,7 @@ 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>
@ -290,14 +282,14 @@ identifier, so that it can be matched against by
[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,8 +306,6 @@ recursively:
@CHUNK[<inline-instance> @CHUNK[<inline-instance>
(define-syntax (inline-instance* stx) (define-syntax (inline-instance* stx)
(dbg
("inline-instance*" stx)
(syntax-parse stx (syntax-parse stx
[(_ i-ty seen) [(_ i-ty seen)
(define/with-syntax replt (define/with-syntax replt
@ -323,18 +313,15 @@ recursively:
i-ty) i-ty)
#'([node second-step-node-of-first] #'([node second-step-node-of-first]
…))) …)))
(displayln (list "replt=" #'replt)) #'(inline-instance replt seen)]))
#'(inline-instance replt seen)])))
(define-syntax (inline-instance stx) (define-syntax (inline-instance stx)
(dbg
("inline-instance" stx)
(syntax-parse stx (syntax-parse stx
[(_ i-t (~and seen (:id (… …)))) [(_ i-t (~and seen (:id (… …))))
<inline-check-seen> <inline-check-seen>
(replace-in-instance #'i-t (replace-in-instance #'i-t
#'(<inline-instance-replacement> #'(<inline-instance-replacement>
<inline-instance-nodes>))])))] <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,8 +381,6 @@ 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
("inline-instance-top1*" stx)
(syntax-parse stx (syntax-parse stx
[(_ i-ty seen) [(_ i-ty seen)
(define/with-syntax replt (define/with-syntax replt
@ -408,12 +388,9 @@ layer of actual nodes. We do this in three steps:
i-ty) i-ty)
#'([node second-step-node-of-first] #'([node second-step-node-of-first]
…))) …)))
(displayln (list "replt-top=" #'replt)) #'(inline-instance-top1 replt seen)]))
#'(inline-instance-top1 replt seen)])))
(define-syntax (inline-instance-top1 stx) (define-syntax (inline-instance-top1 stx)
(dbg
("inline-instance-top1" stx)
(syntax-parse stx (syntax-parse stx
[(_ i-t (~and seen (:id (… …)))) [(_ i-t (~and seen (:id (… …))))
<inline-check-seen> <inline-check-seen>
@ -421,7 +398,7 @@ layer of actual nodes. We do this in three steps:
(fold-instance #'i-t (fold-instance #'i-t
#'top1-accumulator-type #'top1-accumulator-type
#'(<inline-instance-top1-replacement> #'(<inline-instance-top1-replacement>
<inline-instance-top1-nodes>))])))] <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
("inline-type-top1" stx)
(syntax-parse stx (syntax-parse stx
[(_ i-t (~and seen (:id (… …)))) [(_ i-t (~and seen (:id (… …))))
<inline-check-seen> <inline-check-seen>
(replace-in-type #'(Let ([id-~> second-step-marker-expander]) i-t) (replace-in-type #'(Let ([id-~> second-step-marker-expander]) i-t)
#'(<inline-type-top1-replacement> #'(<inline-type-top1-replacement>
<inline-type-top1-nodes>))])))] <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-type-expander (inline-type-top3 stx)
(syntax-parse stx
[(_ i-ty)
(replace-in-type #'(inline-type-top1 i-ty ())
#'([mapping/node-index-marker ;; from
(name/second-step node)] ;; to
…))]))
(define-syntax (replace-markers-top3 stx) (define-syntax (replace-markers-top3 stx)
(dbg
("inline-instance-top3*" stx)
(syntax-parse stx (syntax-parse stx
[(_ i-ty node/top2-roots …) [(_ i-ty node/top2-roots …)
(displayln (replace-in-type #'(inline-type-top1 i-ty ())
#'[]))
(replace-in-instance #'(inline-type-top1 i-ty ()) (replace-in-instance #'(inline-type-top1 i-ty ())
#'([mapping/node-index-marker ;; from #'([mapping/node-index-marker ;; from
(name node) ;; to (name/second-step node) ;; to
mapping/node-index? ;; pred? mapping/node-index? ;; pred?
(λ ([idx : mapping/node-index]) ;; fun (λ ([idx : mapping/node-index]) ;; fun
(vector-ref node/top2-roots (vector-ref node/top2-roots
(constructor-values idx)))] (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) @subsection{The main graph macro}
(dbg
("inline-instance-top3" stx) @; 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 (syntax-parse stx
[(_ i-t (~and seen (:id (… …))) node/top2-roots …) ;; TODO: move this to a dot expander, so that writing
<inline-check-seen> ;; g.a gives a constructor for the a node of g, and
;(replace-in-instance #'i-t ;; (g.a foo bar) or (let ((c .g.a)) (c foo bar)) both
(replace-in-instance #'i-t ;; call it
#'([mapping/node-index-marker ;; from [(_ #:λroot (~datum mapping))
(name node) ;; to #'root-mapping/constructor-top2]
mapping/node-index? ;; pred? …
(λ ([idx : mapping/node-index]) ;; fun [(_ #:root (~datum mapping) . rest)
(vector-ref node/top2-roots (syntax/loc stx (mapping/constructor-top2 . rest))]
(constructor-values idx)))] …
…))])))]
#;[(_ #: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,14 +650,12 @@ 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
("inline-type" stx)
(syntax-parse stx (syntax-parse stx
[(_ i-t (~and seen (:id (… …)))) [(_ i-t (~and seen (:id (… …))))
<inline-check-seen> <inline-check-seen>
(replace-in-type #'(Let ([id-~> second-step-marker-expander]) i-t) (replace-in-type #'(Let ([id-~> second-step-marker-expander]) i-t)
#'(<inline-type-replacement> #'(<inline-type-replacement>
<inline-type-nodes>))])))] <inline-type-nodes>))]))]
@chunk[<inline-type-replacement> @chunk[<inline-type-replacement>
@ -677,7 +665,7 @@ which does not allow variants of (~> …).
@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))]))

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

@ -289,7 +289,8 @@ 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
([current-replacement
`(fold-instance ,whole-type ,stx-acc-type ,r)]) `(fold-instance ,whole-type ,stx-acc-type ,r)])
(define/with-syntax acc-type stx-acc-type) (define/with-syntax acc-type stx-acc-type)
(define/with-syntax ([from to pred? fun] ...) r) (define/with-syntax ([from to pred? fun] ...) r)

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