Use syntax paths instead of srclocs during analysis (#484)

Author: jackfirth

info.rkt

@@ -12,7 +12,8 @@
 
 
 (define deps
-  (list "compatibility-lib"
+  (list "data-lib"
+        "compatibility-lib"
         "base"
         "br-parser-tools-lib"
         "brag-lib"

private/matching-comparator.rkt

@@ -0,0 +1,158 @@
+#lang racket/base
+
+
+(provide matching-comparator)
+
+
+(require (for-syntax racket/base
+                     racket/list
+                     racket/match
+                     racket/syntax)
+         racket/match
+         rebellion/base/comparator
+         syntax/parse/define)
+
+
+;@----------------------------------------------------------------------------------------------------
+
+
+(begin-for-syntax
+  (define-splicing-syntax-class compare-directive
+    #:attributes (comparable-expr comparator-expr comparator-expr-lexical-context)
+
+    (pattern (~seq #:compare comparable-expr:expr comparator-expr:expr)
+      #:with comparator-expr-lexical-context (syntax-local-introduce (attribute comparator-expr)))
+
+    (pattern (~seq #:compare comparable-expr:expr)
+      #:with comparator-expr #'real<=>
+      #:with comparator-expr-lexical-context (attribute comparator-expr)))
+    
+  (define-syntax-class matching-comparator-clause
+    #:attributes (match-pattern
+                  [comparable-expr 1]
+                  [comparator-expr 1]
+                  [comparator-expr-lexical-context 1])
+    (pattern [match-pattern :compare-directive ...])))
+
+
+(define (return-comparison-unless-equivalent comparison)
+  (and (not (equal? comparison equivalent)) comparison))
+
+
+(begin-for-syntax
+  (define (build-static-comparison-chain comparisons)
+    (define/with-syntax (comparison ... last-comparison) comparisons)
+    #'(or (return-comparison-unless-equivalent comparison) ... last-comparison)))
+
+
+(define-syntax-parse-rule (matching-comparator clause:matching-comparator-clause ...+)
+  
+  #:with ((comparator-id ...) ...)
+  (let ([counts (make-hash '())])
+    (for/list ([pattern-comparator-exprs (in-list (attribute clause.comparator-expr))]
+               [pattern-comparator-contexts
+                (in-list (attribute clause.comparator-expr-lexical-context))]
+               [pattern-index (in-naturals)])
+      (for/list ([expr (in-list pattern-comparator-exprs)]
+                 [context (in-list pattern-comparator-contexts)]
+                 [i (in-naturals)])
+        (cond
+          [(identifier? expr)
+           (define occurrence-index (hash-ref! counts (syntax-e expr) 0))
+           (hash-update! counts (syntax-e expr) add1)
+           (format-id context "~a-id~a" expr occurrence-index #:subs? #false)]
+          [else (format-id context "pattern~a-comparator~a" pattern-index i)]))))
+
+  #:with (([left-comparable-thunk-id right-comparable-thunk-id] ...) ...)
+  (for/list ([pattern-comparable-exprs (in-list (attribute clause.comparable-expr))]
+             [pattern-index (in-naturals)])
+    (define counts (make-hash))
+    (for/list ([expr (in-list pattern-comparable-exprs)]
+               [i (in-naturals)])
+      (define (make-id side)
+        (define context (syntax-local-introduce expr))
+        (cond
+          [(identifier? expr)
+           (define occurrence-index (hash-ref! counts (syntax-e expr) 0))
+           (hash-update! counts (syntax-e expr) add1)
+           (format-id context "~a-~a~a" side expr (if (zero? occurrence-index) "" occurrence-index)
+                      #:subs? #false)]
+          [else
+           (format-id context "~a-pattern~a-comparable~a" side pattern-index i)]))
+      (list (make-id 'left) (make-id 'right))))
+
+  #:with (pattern-index ...)
+  (for/list ([i (in-range 0 (length (attribute clause.match-pattern)))])
+    i)
+
+  #:with (comparable-values-expr ...)
+  (for/list ([pattern-comaprable-exprs (in-list (attribute clause.comparable-expr))]
+             [pattern-index (in-naturals)])
+    (build-comparable-values-expression pattern-index pattern-comaprable-exprs))
+
+  #:with left-comparables-id #'left-comparables
+  #:with right-comparables-id #'right-comparables
+
+  #:with (comparable-values-comparison ...)
+  (for/list ([pattern-comparator-ids (in-list (attribute comparator-id))]
+             [pattern-comparable-exprs (in-list (attribute clause.comparable-expr))]
+             [pattern-left-comparable-ids (in-list (attribute left-comparable-thunk-id))]
+             [pattern-right-comparable-ids (in-list (attribute right-comparable-thunk-id))])
+    (build-comparable-values-comparison (attribute left-comparables-id)
+                                        (attribute right-comparables-id)
+                                        pattern-comparator-ids
+                                        pattern-comparable-exprs
+                                        pattern-left-comparable-ids
+                                        pattern-right-comparable-ids))
+  
+  (let ([comparator-id clause.comparator-expr] ... ...)
+    (define (pattern-selector v)
+      (match v
+        [clause.match-pattern comparable-values-expr]
+        ...))
+    (make-comparator
+     (λ (left right)
+       (define-values (left-index left-comparables-id) (pattern-selector left))
+       (define-values (right-index right-comparables-id) (pattern-selector right))
+       (cond
+         [(< left-index right-index) lesser]
+         [(> left-index right-index) greater]
+         [(equal? left-index 'pattern-index) comparable-values-comparison]
+         ...)))))
+
+
+(begin-for-syntax
+  (define (build-comparable-values-expression index comparable-exprs)
+    (define wrapped-comparable-exprs
+      (for/list ([e (in-list comparable-exprs)])
+        (if (identifier? e) e #`(λ () #,e))))
+    (define wrapped-comparables
+      (match (length comparable-exprs)
+        [0 #'#false]
+        [1 (first wrapped-comparable-exprs)]
+        [_ #`(λ () (values #,@wrapped-comparable-exprs))]))
+    #`(values '#,index #,wrapped-comparables)))
+
+
+(begin-for-syntax
+  (define (build-comparable-values-comparison left-values-id
+                                              right-values-id
+                                              comparator-ids
+                                              comparable-exprs
+                                              left-comparable-ids
+                                              right-comparable-ids)
+    (define comparisons
+      (for/list ([e (in-list comparable-exprs)]
+                 [comparator-id (in-list comparator-ids)]
+                 [left (in-list left-comparable-ids)]
+                 [right (in-list right-comparable-ids)])
+        (if (identifier? e)
+            #`(compare #,comparator-id #,left #,right)
+            #`(compare #,comparator-id (#,left) (#,right)))))
+    (match (length comparator-ids)
+      [0 #'equivalent]
+      [1 #`(compare #,(first comparator-ids) #,left-values-id #,right-values-id)]
+      [_
+       #`(let-values ([(#,@left-comparable-ids) (#,left-values-id)]
+                      [(#,@right-comparable-ids) (#,right-values-id)])
+           #,(build-static-comparison-chain comparisons))])))

private/source.rkt

@@ -29,7 +29,6 @@
   [source-code-analysis-visited-forms (-> source-code-analysis? (listof syntax?))]
   [source-code-analysis-expansion-time-output (-> source-code-analysis? immutable-string?)]
   [source-code-analysis-namespace (-> source-code-analysis? namespace?)]
-  [syntax-source-location (-> syntax? source-location?)]
   [with-input-from-source (-> source? (-> any) any)]))
 
 
@@ -52,6 +51,7 @@
          resyntax/private/linemap
          resyntax/private/logger
          resyntax/private/syntax-neighbors
+         resyntax/private/syntax-path
          syntax/id-table
          syntax/modread
          syntax/parse)
@@ -82,7 +82,6 @@
 
 
 (define-record-type source-code-analysis (code visited-forms expansion-time-output namespace))
-(define-record-type source-location (source line column position span))
 
 
 (define (with-input-from-source code proc)
@@ -138,11 +137,11 @@
     (define program-source-name (syntax-source program-stx))
     (define current-expand-observe (dynamic-require ''#%expobs 'current-expand-observe))
     (define original-visits (make-vector-builder))
-    (define expanded-originals-by-location (make-hash))
+    (define expanded-originals-by-path (make-hash))
 
     (define (add-all-original-subforms! stx)
       (when (resyntax-should-analyze-syntax? stx #:as-visit? #false)
-        (hash-set! expanded-originals-by-location (syntax-source-location stx) stx))
+        (hash-set! expanded-originals-by-path (syntax-original-path stx) stx))
       (syntax-parse stx
         [(subform ...) (for-each add-all-original-subforms! (attribute subform))]
         [(subform ...+ . tail-form)
@@ -197,25 +196,25 @@
 
     (define output (get-output-string output-port))
     (define binding-table (fully-expanded-syntax-binding-table expanded))
-    (define original-binding-table-by-position
+    (define original-binding-table-by-path
       (for*/fold ([table (hash)])
                  ([phase-table (in-hash-values binding-table)]
                   [(id uses) (in-free-id-table phase-table)]
                   #:when (syntax-original-and-from-source? id)
                   [use (in-list uses)])
-        (hash-update table (syntax-source-location id) (λ (previous) (cons use previous)) '())))
+        (hash-update table (syntax-original-path id) (λ (previous) (cons use previous)) '())))
 
     (add-all-original-subforms! expanded)
 
     (define/guard (add-usages stx)
       (guard (identifier? stx) #:else stx)
-      (define usages (hash-ref original-binding-table-by-position (syntax-source-location stx) '()))
+      (define usages (hash-ref original-binding-table-by-path (syntax-original-path stx) '()))
       (syntax-property stx 'identifier-usages usages))
 
     (define (enrich stx)
       (define new-context
         (add-usages
-         (or (hash-ref expanded-originals-by-location (syntax-source-location stx) #false) stx)))
+         (or (hash-ref expanded-originals-by-path (syntax-original-path stx) #false) stx)))
       (syntax-parse stx
         [(subform ...)
          (datum->syntax new-context
@@ -232,9 +231,9 @@
 
     (define visited
       (transduce (build-vector original-visits)
-                 (deduplicating #:key syntax-source-location)
+                 (deduplicating #:key syntax-original-path)
                  (mapping enrich)
-                 (sorting syntax-source-location<=> #:key syntax-source-location)
+                 (sorting syntax-path<=> #:key syntax-original-path)
                  #:into into-list))
 
     (for ([visit (in-list visited)])
@@ -253,20 +252,6 @@
                           #:namespace ns)))
 
 
-(define (syntax-source-location stx)
-  (source-location
-   #:source (syntax-source stx)
-   #:line (syntax-line stx)
-   #:column (syntax-column stx)
-   #:position (syntax-position stx)
-   #:span (syntax-span stx)))
-
-
-(define syntax-source-location<=>
-  (comparator-chain (comparator-map real<=> source-location-position)
-                    (comparator-map (comparator-reverse real<=>) source-location-span)))
-
-
 (define (extract-module-require-spec mod-stx)
   (syntax-parse mod-stx
     [(_ name _ . _) `',(syntax-e #'name)]))

private/syntax-path.rkt

@@ -11,6 +11,7 @@
  (struct-out tail-syntax)
  (contract-out
   [syntax-path? (-> any/c boolean?)]
+  [syntax-path<=> (comparator/c syntax-path?)]
   [nonempty-syntax-path? (-> any/c boolean?)]
   [empty-syntax-path syntax-path?]
   [syntax-path (-> (sequence/c syntax-path-element?) syntax-path?)]
@@ -25,12 +26,22 @@
   [box-element-syntax syntax-path-element?]))
 
 
-(require racket/sequence
+(require (for-syntax racket/base
+                     racket/list
+                     racket/match
+                     racket/sequence
+                     racket/syntax)
+         data/order
+         guard
+         racket/sequence
          racket/struct
          racket/treelist
          racket/list
          racket/match
-         rebellion/type/singleton)
+         rebellion/base/comparator
+         rebellion/type/singleton
+         resyntax/private/matching-comparator
+         syntax/parse/define)
 
 
 (module+ test
@@ -229,3 +240,55 @@
   (unless (prefab-struct? s)
     (raise-argument-error 'prefab-struct-ref "prefab-struct?" s))
   (list-ref (struct->list s) i))
+
+
+
+(define datum<=>
+  (make-comparator
+   (λ (left right)
+     (match (datum-order left right)
+       ['= equivalent]
+       ['> greater]
+       ['< lesser]))))
+
+
+(define syntax-path-element<=>
+  (matching-comparator
+   [(? exact-nonnegative-integer? i) #:compare i]
+   [(tail-syntax i) #:compare i]
+   [(vector-element-syntax i) #:compare i]
+   [(hash-value-syntax key) #:compare key datum<=>]
+   [(== box-element-syntax)]
+   [(prefab-field-syntax i) #:compare i]))
+
+
+(module+ test
+  (test-case "syntax-path-element<=>"
+    (define unsorted
+      (list 2
+            (tail-syntax 1)
+            box-element-syntax
+            1
+            3
+            (hash-value-syntax 'foo)
+            (tail-syntax 4)
+            (vector-element-syntax 5)))
+
+    (define sorted
+      (sort unsorted (λ (a b) (compare-infix syntax-path-element<=>  a < b))))
+
+    (define expected
+      (list 1
+            2
+            3
+            (tail-syntax 1)
+            (tail-syntax 4)
+            (vector-element-syntax 5)
+            (hash-value-syntax 'foo)
+            box-element-syntax))
+    (check-equal? sorted expected)))
+
+
+(define syntax-path<=>
+  (comparator-map (lexicographic-comparator syntax-path-element<=>) syntax-path-elements
+                  #:name 'syntax-path<=>))