From 6e5bc55402761981bb047a41816136370c4db9d5 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@gmail.com>
Date: Tue, 15 Dec 2015 18:53:44 +0100
Subject: [PATCH] =?UTF-8?q?Implemented=20(get=20v=20f=20=E2=80=A6)=20with?=
 =?UTF-8?q?=20support=20for=20c[ad]*r.=20Fixed=20naming=20of=20types=20ret?=
 =?UTF-8?q?urned=20by=20struct-get=20(by=20not=20defining=20types=20for=20?=
 =?UTF-8?q?fields,=20in=20case=20they're=20the=20same=20as=20a=20node=20ty?=
 =?UTF-8?q?pe=20or=20built-in=20type)?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 graph/graph/__DEBUG_graph__.rkt     |  10 +-
 graph/graph/graph3.lp2.rkt          |  42 ++++----
 graph/graph/graph4.lp2.rkt          | 135 +++++++++++++++++++++++++
 graph/graph/structure.lp2.rkt       | 146 +++++++++++++++++-----------
 graph/graph/variant.lp2.rkt         |  13 ++-
 graph/lib/doc/template.lp2.rkt      |  38 +++++---
 graph/lib/lib.rkt                   |   6 --
 graph/lib/low.rkt                   |  37 ++++++-
 graph/lib/low/multiassoc-syntax.rkt |  23 +++++
 9 files changed, 344 insertions(+), 106 deletions(-)
 create mode 100644 graph/graph/graph4.lp2.rkt
 create mode 100644 graph/lib/low/multiassoc-syntax.rkt

diff --git a/graph/graph/__DEBUG_graph__.rkt b/graph/graph/__DEBUG_graph__.rkt
index 79a8cb5..32b01bb 100644
--- a/graph/graph/__DEBUG_graph__.rkt
+++ b/graph/graph/__DEBUG_graph__.rkt
@@ -19,15 +19,23 @@
 |#
 
 (require (submod "graph3.lp2.rkt" test))
+(require "graph4.lp2.rkt")
 (require "structure.lp2.rkt")
+(require "variant.lp2.rkt")
 (require "../lib/low.rkt")
-(require racket/list)
 
+;(structure-get people)
+(structure-get (cadr g) people)
+(get g people)
+(get g streets cadr houses car owner name)
+
+#|
 (define #:∀ (A) (map-force [l : (Listof (Promise A))])
   (map (inst force A) l))
 
 (map-force (get g people))
 (map-force (get g streets))
+|#
 
 #|
 (let ()
diff --git a/graph/graph/graph3.lp2.rkt b/graph/graph/graph3.lp2.rkt
index 394ddbe..038166c 100644
--- a/graph/graph/graph3.lp2.rkt
+++ b/graph/graph/graph3.lp2.rkt
@@ -211,13 +211,11 @@ We derive identifiers for these based on the @tc[node] name:
        (define-temp-ids "~a/incomplete-type" (node …))
        (define-temp-ids "~a/make-incomplete" (node …))
        (define-temp-ids "~a/incomplete-tag" (node …))
-       (define-temp-ids "~a/incomplete-type" ((field …) …))
        
        (define-temp-ids "~a/with-indices-type" (node …))
        (define-temp-ids "~a/make-with-indices" (node …))
        (define-temp-ids "~a/with-indices-tag" (node …))
        (define-temp-ids "~a/with-indices-tag2" (node …))
-       (define-temp-ids "~a/with-indices-type" ((field …) …))
        (define-temp-ids "~a/index-type" (node …))
        (define-temp-ids "~a/with-indices→with-promises" (node …)
          #:first-base root)
@@ -225,7 +223,6 @@ We derive identifiers for these based on the @tc[node] name:
        (define-temp-ids "~a/with-promises-type" (node …) #:first-base root)
        (define-temp-ids "~a/make-with-promises" (node …))
        (define-temp-ids "~a/with-promises-tag" (node …))
-       (define-temp-ids "~a/with-promises-type" ((field …) …))
        
        (define-temp-ids "~a/mapping-function" (node …))
        
@@ -346,18 +343,17 @@ indicates at which index in the queue's results the successor can be found.
 @CHUNK[<define-with-indices>
        (define-type node/index-type (List 'node/with-indices-tag2 Index))
        
-       (define-type field/with-indices-type
-         (tmpl-replace-in-type field-type [node node/index-type] …))
-       …
-       
        (define-type node/with-indices-type
-         (List 'node/with-indices-tag field/with-indices-type …))
+         (List 'node/with-indices-tag <field/with-indices-type> …))
        
-       (: node/make-with-indices (→ field/with-indices-type …
+       (: node/make-with-indices (→ <field/with-indices-type> …
                                     node/with-indices-type))
        (define (node/make-with-indices field …)
          (list 'node/with-indices-tag field …))]
 
+@CHUNK[<field/with-indices-type>
+       (tmpl-replace-in-type field-type [node node/index-type] …)]
+
 @subsection{Making with-promises nodes}
 
 We derive the @tc[with-promises] type from each @emph{ideal} node type using
@@ -368,22 +364,22 @@ that node's @tc[with-promises] type.
 @; TODO: use a type-expander here, instead of a template metafunction.
 
 @CHUNK[<define-with-promises>
-       (define-type field/with-promises-type
-         (tmpl-replace-in-type field-type
-                               [node (Promise node/with-promises-type)] …))
-       …
        
        (define-type node/with-promises-type
          (tagged node/with-promises-tag
-                 [field : field/with-promises-type] …))
+                 [field : <field/with-promises-type>] …))
        
-       (: node/make-with-promises (→ field/with-promises-type …
+       (: node/make-with-promises (→ <field/with-promises-type> …
                                      node/with-promises-type))
        (define (node/make-with-promises field/value …)
          (tagged node/with-promises-tag
-                 [field : field/with-promises-type field/value]
+                 [field : <field/with-promises-type> field/value]
                  …))]
 
+@CHUNK[<field/with-promises-type>
+       (tmpl-replace-in-type field-type
+                             [node (Promise node/with-promises-type)] …)]
+
 @subsection{Making incomplete nodes}
 
 We derive the @tc[incomplete] type from each @emph{ideal} node type using
@@ -394,18 +390,18 @@ library. We replace all occurrences of a @tc[node] name with its
 @; TODO: use a type-expander here, instead of a template metafunction.
 
 @CHUNK[<define-incomplete>
-       (define-type field/incomplete-type
-         (tmpl-replace-in-type field-type
-                               [node node/placeholder-type] …))
-       …
-       
        (define-type node/incomplete-type
-         (List 'node/incomplete-tag field/incomplete-type …))
+         (List 'node/incomplete-tag <field/incomplete-type> …))
        
-       (: node/make-incomplete (→ field/incomplete-type … node/incomplete-type))
+       (: node/make-incomplete (→ <field/incomplete-type> …
+                                  node/incomplete-type))
        (define (node/make-incomplete field …)
          (list 'node/incomplete-tag field …))]
 
+@CHUNK[<field/incomplete-type>
+       (tmpl-replace-in-type field-type
+                             [node node/placeholder-type] …)]
+
 @subsection{Converting incomplete nodes to with-indices ones}
 
 @; TODO: we don't need that many annotations
diff --git a/graph/graph/graph4.lp2.rkt b/graph/graph/graph4.lp2.rkt
new file mode 100644
index 0000000..d5206a7
--- /dev/null
+++ b/graph/graph/graph4.lp2.rkt
@@ -0,0 +1,135 @@
+#lang scribble/lp2
+@(require "../lib/doc.rkt")
+@doc-lib-setup
+
+@title[#:style manual-doc-style]{Syntactic sugar for the @racket[graph] macro}
+
+@(table-of-contents)
+
+@section{Introduction}
+
+We allow not just identifiers having the @tc[c…r] syntax, but also those
+matching one of the predefined identifiers, so that @tc[(rename-in [car hd])]
+is correctly taken into account. Note that @tc[car] would still work, because we
+also match identifiers with the @tc[c…r] syntax, as a fallback or for chains of
+more than 4 letters.
+
+@CHUNK[<c*r-syntax-class>
+       (define-syntax-class c…r
+         ;(pattern (~literal car) #:with (expanded …) #'(car))
+         ;(pattern (~literal cdr) #:with (expanded …) #'(cdr))
+         (pattern (~literal caar) #:with (expanded …) #'(car car))
+         (pattern (~literal cdar) #:with (expanded …) #'(cdr car))
+         (pattern (~literal cadr) #:with (expanded …) #'(car cdr))
+         (pattern (~literal cddr) #:with (expanded …) #'(cdr cdr))
+         (pattern (~literal caaar) #:with (expanded …) #'(car car car))
+         (pattern (~literal cdaar) #:with (expanded …) #'(cdr car car))
+         (pattern (~literal cadar) #:with (expanded …) #'(car cdr car))
+         (pattern (~literal cddar) #:with (expanded …) #'(cdr cdr car))
+         (pattern (~literal caadr) #:with (expanded …) #'(car car cdr))
+         (pattern (~literal cdadr) #:with (expanded …) #'(cdr car cdr))
+         (pattern (~literal caddr) #:with (expanded …) #'(car cdr cdr))
+         (pattern (~literal cdddr) #:with (expanded …) #'(cdr cdr cdr))
+         (pattern (~literal caaaar) #:with (expanded …) #'(car car car car))
+         (pattern (~literal cdaaar) #:with (expanded …) #'(cdr car car car))
+         (pattern (~literal cadaar) #:with (expanded …) #'(car cdr car car))
+         (pattern (~literal cddaar) #:with (expanded …) #'(cdr cdr car car))
+         (pattern (~literal caadar) #:with (expanded …) #'(car car cdr car))
+         (pattern (~literal cdadar) #:with (expanded …) #'(cdr car cdr car))
+         (pattern (~literal caddar) #:with (expanded …) #'(car cdr cdr car))
+         (pattern (~literal cdddar) #:with (expanded …) #'(cdr cdr cdr car))
+         (pattern (~literal caaadr) #:with (expanded …) #'(car car car cdr))
+         (pattern (~literal cdaadr) #:with (expanded …) #'(cdr car car cdr))
+         (pattern (~literal cadadr) #:with (expanded …) #'(car cdr car cdr))
+         (pattern (~literal cddadr) #:with (expanded …) #'(cdr cdr car cdr))
+         (pattern (~literal caaddr) #:with (expanded …) #'(car car cdr cdr))
+         (pattern (~literal cdaddr) #:with (expanded …) #'(cdr car cdr cdr))
+         (pattern (~literal cadddr) #:with (expanded …) #'(car cdr cdr cdr))
+         (pattern (~literal cddddr) #:with (expanded …) #'(cdr cdr cdr cdr))
+         (pattern id:id
+                  #:when (regexp-match #rx"^c[ad][ad]*r$"
+                                       (identifier→string #'id))
+                  #:with (expanded …)
+                  (map (λ (c)
+                         (cond [(equal? c #\a) #'car]
+                               [(equal? c #\d) #'cdr]
+                               [<c*r-error>]))
+                       (string->list
+                        (cadr
+                         (regexp-match #rx"^c([ad][ad]*)r$"
+                                       (identifier→string #'id)))))))]
+
+Although this should not happen, by construction, we check for both cases
+(@tc[#\a] and @tc[#\d]) for each character of a @tc[c…r] identifier, and
+otherwise throw an error:
+
+@chunk[<c*r-error>
+       (raise-syntax-error 'c*r "expected a or d" #'id)]
+
+@chunk[<get>
+       (define-syntax (get stx)
+         (syntax-parse stx
+           [(_ v:expr)
+            #'v]
+           [(_ v:expr (~and c?r (~or (~lit car) (~lit cdr))) other-fields …)
+            #'(get (c?r v) other-fields …)]
+           [(_ v:expr c…r:c…r other-fields …)
+            #`(get v #,@(reverse (syntax->list #'(c…r.expanded …)))
+                   other-fields …)]
+           [(_ v:expr field other-fields:id …)
+            #'(let ([v-cache v])
+                (cond <get-tagged>
+                      <get-promise>
+                      <get-plain-struct>))]))]
+
+@chunk[<get-tagged>
+       [((make-predicate (List Symbol Any)) v-cache)
+        (get (structure-get (cadr v-cache) field) other-fields …)]]
+@chunk[<get-promise>
+       [(promise? v-cache)
+        (let ([f-cache (force v-cache)])
+          (if ((make-predicate (List Symbol Any)) f-cache)
+              (get (structure-get (cadr f-cache) field) other-fields …)
+              (get (structure-get f-cache field) other-fields …)))]]
+@chunk[<get-plain-struct>
+       [else
+        (get (structure-get v-cache field) other-fields …)]]
+
+@chunk[<test-get>
+       (check-equal? 'TODO 'TODO)]
+
+@section{Conclusion}
+
+@chunk[<module-main>
+       (module main typed/racket
+         (require (for-syntax syntax/parse
+                              racket/syntax
+                              "../lib/low-untyped.rkt")
+                  "../lib/low.rkt"
+                  "structure.lp2.rkt"
+                  "variant.lp2.rkt"
+                  "graph3.lp2.rkt")
+         (provide get)
+         
+         (begin-for-syntax
+           <c*r-syntax-class>)
+         
+         <get>)]
+
+@chunk[<module-test>
+       (module* test typed/racket
+         (require (submod "..")
+                  typed/rackunit)
+         
+         <test-get>
+         
+         (require (submod ".." doc)))]
+
+@chunk[<*>
+       (begin
+         <module-main>
+         
+         (require 'main)
+         (provide (all-from-out 'main))
+         
+         <module-test>)]
\ No newline at end of file
diff --git a/graph/graph/structure.lp2.rkt b/graph/graph/structure.lp2.rkt
index 58663f9..3152397 100644
--- a/graph/graph/structure.lp2.rkt
+++ b/graph/graph/structure.lp2.rkt
@@ -137,21 +137,23 @@ Test constructor:
 
 @chunk[<test-define-structure>
        (check-equal?: (empty-st) : empty-st (empty-st))
-       (check-equal?: (get (st 1 "b") b) : String "b")
-       (check-equal?: (get (st2 "a" 2) b) : String "a")]
+       (check-equal?: (structure-get (st 1 "b") b) : String "b")
+       (check-equal?: (structure-get (st2 "a" 2) b) : String "a")]
 
 Test constructor, as id:
 
 @chunk[<test-define-structure>
-       (check-equal?: (get (cadr (map st '(1 2 3) '("x" "y" "z"))) b) : String
+       (check-equal?: (structure-get (cadr (map st '(1 2 3) '("x" "y" "z"))) b)
+                      : String
                       "y")
-       (check-equal?: (get (cadr (map st2 '("d" "e" "f") '(1 2 3))) b) : String
+       (check-equal?: (structure-get (cadr (map st2 '("d" "e" "f") '(1 2 3))) b)
+                      : String
                       "e")]
 
 Test the type-expander:
 
 @chunk[<test-define-structure>
-       (check-equal? (get (ann (st2 "g" 123) st2) b) "g")]
+       (check-equal? (structure-get (ann (st2 "g" 123) st2) b) "g")]
 
 Test the match-expander:
 
@@ -298,47 +300,72 @@ The fields in @tc[fields→stx-name-alist] are already sorted.
          (cdr (assoc (syntax->datum (datum->syntax #f (sort-fields fields)))
                      fields→stx-name-alist)))]
 
+@subsection{Has-field}
+
+@chunk[<structure-supertype-match-expander>
+       (λ/syntax-parse (_ :match-field-or-field-pat ...)
+         (define/with-syntax ([(all-field …) . name] …)
+           (fields→supertypes #'(field …)))
+         (define/with-syntax ([sorted-field1 …] …)
+           (stx-map sort-fields #'((all-field …) …)))
+         (define/with-syntax ([[sorted-field sorted-pat …] …] …)
+           (stx-map (curry stx-map
+                           (λ (x) (multiassoc-syntax x #'([field pat …] …))))
+                    #'((sorted-field1 …) …)))
+         #'(or (name (and sorted-field sorted-pat …) …) …))]
+
+@chunk[<structure-supertype>
+       (define-multi-id structure-supertype
+         #:type-expander
+         (λ/syntax-parse (_ field:id …)
+           #`(U #,@(map cdr (fields→supertypes #'(field …)))))
+         #:match-expander <structure-supertype-match-expander>)]
+
+@chunk[<fields→supertypes>
+       (define-for-syntax (fields→supertypes stx-fields)
+         (with-syntax ([(field …) stx-fields])
+           (foldl (λ (f alist)
+                    (filter (λ (s) (member (syntax->datum f) (car s)))
+                            alist))
+                  fields→stx-name-alist
+                  (syntax->list #'(field …)))))]
+
 @subsection{Accessor}
 
-@CHUNK[<get-field2>
-       (define-syntax (get stx)
-         (syntax-parse stx
-           [(_ v field:id)
-            (define struct-names
-              (filter (λ (s)
-                        (member (syntax->datum #'field) (car s)))
-                      fields→stx-name-alist))
-            (define/with-syntax (name? ...)
-              (map (λ (s) <get-predicate>) struct-names))
-            (define/with-syntax (name-field ...)
-              (map (λ (s) <get-field-accessor>) struct-names))
-            #`(let ([v-cache v])
-                (cond
-                  [(name? v-cache)
-                   (let ([accessor name-field])
-                     (accessor v-cache))]; cover doesn't see the call otherwise?
-                  …
-                  ;; For variants:
-                  ;; If we hit the bug where refinements cause loss of precision
-                  ;; in later clauses, then just use separate functions, forming
-                  ;; a BTD:
-                  ;; (λ ([x : (U A1 A2 A3 B1 B2 B3)]) (if (A? x) (fa x) (fb x)))
-                  [(and (pair? v-cache)
-                        (symbol? (car v-cache))
-                        (null? (cddr v-cache))
-                        (name? (cadr v-cache)))
-                   (let ([accessor name-field])
-                     (accessor (cadr v-cache)))]
-                  …
-                  [else (typecheck-fail #,stx #:covered-id v-cache)]))]
-           [(_ field:id)
-            (define/with-syntax (struct-name …)
-              (filter (λ (s)
-                        (member (syntax->datum #'field) (car s)))
-                      fields→stx-name-alist))
-              #'(λ ([v : (U struct-name …
-                            (List Symbol struct-name) …)])
-                  (get v field))]))]
+@CHUNK[<get-field>
+       (define-syntax/parse (structure-get v field:id)
+         (define structs (fields→supertypes #'(field)))
+         (define/with-syntax (name? ...)
+           (map (λ (s) <get-predicate>) structs))
+         (define/with-syntax (name-field ...)
+           (map (λ (s) <get-field-accessor>) structs))
+         #`(let ([v-cache v])
+             (cond
+               ;; If we hit the bug where refinements cause loss of precision
+               ;; in later clauses, then just use separate functions, forming
+               ;; a BTD:
+               ;; (λ ([x : (U A1 A2 A3 B1 B2 B3)]) (if (A? x) (fa x) (fb x)))
+               [(name? v-cache)
+                (let ([accessor name-field])
+                  (accessor v-cache))]; cover doesn't see the call otherwise?
+               …
+               [else (typecheck-fail #,stx #:covered-id v-cache)])))]
+
+@CHUNK[<get-field>
+       (define-syntax/parse (λstructure-get field:id)
+         (define/with-syntax ([(all-field …) . name] …)
+           (fields→supertypes #'(field)))
+         (define-temp-ids "~a/T" field)
+         (define/syntax-parse ([all-field/T …] …)
+           (stx-map (curry stx-map
+                           (λ (f)
+                             (if (free-identifier=? f #'field)
+                                 #'field/T
+                                 #'Any)))
+                    #'([all-field …] …)))
+         #'(λ #:∀ (field/T)
+             ([v : (U [(structure [all-field : all-field/T]) …] …)])
+             (structure-get v field)))]
 
 @chunk[<get-predicate>
        (my-st-type-info-predicate (get-struct-info stx (cdr s)))]
@@ -349,9 +376,9 @@ The fields in @tc[fields→stx-name-alist] are already sorted.
 
 @chunk[<test-get-field>
        (check-equal?:
-        (get ((make-structure-constructor a b c d) 1 "b" 'value-c 4) c)
-        : 'value-c
-        'value-c)]
+        (structure-get ((make-structure-constructor a b c d) 1 "b" 'val-c 4) c)
+        : 'val-c
+        'val-c)]
 
 @subsection{Match-expander}
 
@@ -362,7 +389,6 @@ The fields in @tc[fields→stx-name-alist] are already sorted.
            (pattern field:id #:with (pat ...) #'())))]
 
 @chunk[<match-expander>
-       <syntax-class-for-match>
        (define-for-syntax (structure-match-expander stx)
          (syntax-parse stx
            [(_ :match-field-or-field-pat ...)
@@ -460,10 +486,11 @@ instead of needing an extra recompilation.
                 (remember-all-errors #'U stx #'(field ...)))]))]
 
 @chunk[<test-type-expander>
-       (check-equal? (get (ann ((make-structure-constructor a b c) 1 "b" #t)
-                               (structure [a Number] [c Boolean] [b String]))
-                          b)
-                     "b")]
+       (check-equal?
+        (structure-get (ann ((make-structure-constructor a b c) 1 "b" #t)
+                            (structure [a Number] [c Boolean] [b String]))
+                       b)
+        "b")]
 
 @section[#:tag "structure|remember"]{Closed-world assumption and global
  compilation}
@@ -546,14 +573,17 @@ chances that we could write a definition for that identifier.
                                 racket/sequence
                                 ;; in-syntax on older versions:
                                 ;;;unstable/sequence
-                                "../lib/low-untyped.rkt")
+                                "../lib/low-untyped.rkt"
+                                "../lib/low/multiassoc-syntax.rkt")
                     "../lib/low.rkt"
                     "../type-expander/type-expander.lp2.rkt"
                     "../type-expander/multi-id.lp2.rkt")
            (provide define-structure
                     make-structure-constructor
-                    get
-                    structure)
+                    structure-get
+                    λstructure-get
+                    structure
+                    structure-supertype)
            
            (begin-for-syntax
              (provide structure-args-stx-class))
@@ -572,9 +602,11 @@ chances that we could write a definition for that identifier.
            
            <my-st-type-info>
            <struct-info>
-           <get-field2>
-           ;<get-field>
+           <fields→supertypes>
+           <get-field>
            
+           <syntax-class-for-match>
+           <structure-supertype>
            <match-expander>
            <type-expander>
            
diff --git a/graph/graph/variant.lp2.rkt b/graph/graph/variant.lp2.rkt
index 2190282..568fb16 100644
--- a/graph/graph/variant.lp2.rkt
+++ b/graph/graph/variant.lp2.rkt
@@ -160,6 +160,16 @@ number of name collisions.
                #'(c sa.value …)
                #'c)))]
 
+@CHUNK[<tagged>
+       (define-multi-id any-tagged
+         #:type-expander
+         (λ/syntax-parse (_ . structure-type)
+           #'(List Symbol (structure . structure-type)))
+         #:match-expander
+         (λ/syntax-parse (_ tag-pat:id . structure-pat)
+           #`(list (? symbol? tag-pat:id) #,(syntax/loc #'structure-pat
+                                              (structure . structure-pat)))))]
+
 @chunk[<test-tagged>
        (check-equal? (match (ann (tagged foo [x "o"] [y 3] [z 'z])
                                  (tagged foo
@@ -279,7 +289,8 @@ number of name collisions.
            (provide constructor
                     define-variant
                     tagged
-                    define-tagged)
+                    define-tagged
+                    any-tagged)
            
            <constructor>
            <define-variant>
diff --git a/graph/lib/doc/template.lp2.rkt b/graph/lib/doc/template.lp2.rkt
index 1c09d07..b919af0 100644
--- a/graph/lib/doc/template.lp2.rkt
+++ b/graph/lib/doc/template.lp2.rkt
@@ -46,25 +46,31 @@ scribble, see
 
 @section{Conclusion}
 
+@chunk[<module-main>
+       (module main typed/racket
+         (require (for-syntax syntax/parse
+                              racket/syntax
+                              "../../lib/low-untyped.rkt")
+                  "../../lib/low-untyped.rkt")
+         (provide foo)
+         
+         <foo>
+         <scribble-macro-expansion>)]
+
+@chunk[<module-test>
+       (module* test typed/racket
+         (require (submod "..")
+                  typed/rackunit)
+         
+         <test-foo>
+         
+         (require (submod ".." doc)))]
+
 @chunk[<*>
        (begin
-         (module main typed/racket
-           (require (for-syntax syntax/parse
-                                racket/syntax
-                                "../../lib/low-untyped.rkt")
-                    "../../lib/low-untyped.rkt")
-           (provide foo)
-           
-           <foo>
-           <scribble-macro-expansion>)
+         <module-main>
          
          (require 'main)
          (provide (all-from-out 'main))
          
-         (module* test typed/racket
-           (require (submod "..")
-                    typed/rackunit)
-           
-           <test-foo>
-           
-           (require (submod ".." doc))))]
\ No newline at end of file
+         <module-test>)]
\ No newline at end of file
diff --git a/graph/lib/lib.rkt b/graph/lib/lib.rkt
index 9b177fb..c772202 100644
--- a/graph/lib/lib.rkt
+++ b/graph/lib/lib.rkt
@@ -17,12 +17,6 @@
 (require (for-syntax syntax/parse
                      racket/syntax))
 
-;; raco pkg install alexis-util
-(require alexis/util/threading)
-
-;; From alexis/util/threading
-(provide ~> ~>> _ (rename-out [_ ♦]))
-
 (define-syntax (comment stx)
   #'(values))
 
diff --git a/graph/lib/low.rkt b/graph/lib/low.rkt
index cdfb7e5..5fba8da 100644
--- a/graph/lib/low.rkt
+++ b/graph/lib/low.rkt
@@ -4,6 +4,17 @@
 (: degub (∀ (T) (→ T T)))
 (define (degub x) (display "degub:") (displayln x) x)
 
+;; ==== low/threading.rkt
+
+;; raco pkg install alexis-util
+;; or:
+;; raco pkg install threading
+(require alexis/util/threading)
+
+(define-syntax-rule (~>_ clause ... expr) (~> expr clause ...))
+
+(provide ~>_ ~> ~>> _ (rename-out [_ ♦]))
+
 ;; ==== low/typed-untyped-module.rkt ====
 
 (require typed/untyped-utils)
@@ -299,6 +310,7 @@
          *in-split
          my-in-syntax
          indexof
+         replace-first
          Syntax-Listof
          check-duplicate-identifiers
          generate-temporary)
@@ -535,6 +547,21 @@
             index
             (rec (cdr lst) (+ index 1))))))
 
+(: replace-first (∀ (A B C) (->* (B
+                                  C
+                                  (Listof (U A B)))
+                                 (#:equal? (→ (U A B) (U A B) Any : #:+ B))
+                                 (Rec R (U (Pairof (U A B) R)
+                                           Null
+                                           (Pairof C (Listof (U A B))))))))
+(define (replace-first from to l #:equal? [equal? eq?])
+  (if (null? l)
+      '()
+      (if (equal? from (car l))
+          (cons to (cdr l))
+          (cons (car l)
+                (replace-first from to (cdr l))))))
+
 ;; See also syntax-e, which does not flatten syntax pairs, and syntax->list,
 ;; which isn't correctly typed (won't take #'(a . (b c d e))).
 (define-type (Syntax-Listof T)
@@ -880,7 +907,10 @@
 (provide syntax-cons-property
          stx-assoc
          cdr-stx-assoc
-         stx-map-nested)
+         stx-map-nested
+         identifier-length
+         identifier->string
+         (rename-out [identifier->string identifier→string]))
 
 (: syntax-cons-property (∀ (A) (→ (Syntaxof A) Symbol Any (Syntaxof A))))
 (define (syntax-cons-property stx key v)
@@ -889,7 +919,10 @@
 
 
 (: identifier-length (→ Identifier Index))
-(define (identifier-length id) (string-length (symbol->string (syntax-e id))))
+(define (identifier-length id) (string-length (identifier->string id)))
+
+(: identifier->string (→ Identifier String))
+(define (identifier->string id) (symbol->string (syntax-e id)))
 
 (: stx-map-nested (∀ (A B) (→ (→ A B)
                               (Syntaxof (Listof (Syntaxof (Listof A))))
diff --git a/graph/lib/low/multiassoc-syntax.rkt b/graph/lib/low/multiassoc-syntax.rkt
new file mode 100644
index 0000000..91d1b50
--- /dev/null
+++ b/graph/lib/low/multiassoc-syntax.rkt
@@ -0,0 +1,23 @@
+#lang racket
+
+(require syntax/parse
+         syntax/parse/experimental/template
+         syntax/stx)
+
+(provide multiassoc-syntax
+         cdr-assoc-syntax
+         tmpl-cdr-assoc-syntax)
+
+(define (multiassoc-syntax query alist)
+  (map stx-cdr
+       (filter (λ (xy) (free-identifier=? query (stx-car xy)))
+               (syntax->list alist))))
+
+(define (cdr-assoc-syntax query alist)
+  (stx-cdr (findf (λ (xy) (free-identifier=? query (stx-car xy)))
+                  (syntax->list alist))))
+
+(define-template-metafunction (tmpl-cdr-assoc-syntax stx)
+  (syntax-parse stx
+    [(_ query [k . v] …)
+     (cdr-assoc-syntax #'query #'([k . v] …))]))