Propagating syntax for good errors

qi-lib/flow/extended/forms.rkt

@@ -30,61 +30,61 @@
 
 (define-for-qi none? ~none?)
 
-(define-qi-syntax-rule (one-of? v:expr ...)
+(define-core-qi-syntax-rule (one-of? v:expr ...)
   (~> (member (list v ...)) ->boolean))
 
-(define-qi-syntax-rule (none onex:clause)
+(define-core-qi-syntax-rule (none onex:clause)
   (not (any onex)))
 
-(define-qi-syntax-parser NOR
+(define-core-qi-syntax-parser NOR
   [_:id #'(~> OR NOT)])
 
-(define-qi-syntax-parser NAND
+(define-core-qi-syntax-parser NAND
   [_:id #'(~> AND NOT)])
 
-(define-qi-syntax-parser XNOR
+(define-core-qi-syntax-parser XNOR
   [_:id #'(~> XOR NOT)])
 
-(define-qi-syntax-rule (and% onex:conjux-clause ...)
+(define-core-qi-syntax-rule (and% onex:conjux-clause ...)
   (~> (== onex.parsed ...)
       all?))
 
-(define-qi-syntax-rule (or% onex:disjux-clause ...)
+(define-core-qi-syntax-rule (or% onex:disjux-clause ...)
   (~> (== onex.parsed ...)
       any?))
 
 ;;; Routing
 
 ;; Right-threading is just normal threading but with a syntax
 ;; property attached to the components indicating the chirality
-(define-qi-syntax-rule (thread-right onex:right-threading-clause ...)
+(define-core-qi-syntax-rule (thread-right onex:right-threading-clause ...)
   (~> onex.chiral ...))
 
-(define-qi-syntax-parser crossover
+(define-core-qi-syntax-parser crossover
   [_:id #'(~> ▽ reverse △)])
 
-(define-qi-syntax-parser relay*
+(define-core-qi-syntax-parser relay*
   [(_ onex:clause ... rest-onex:clause)
    #:with len #`#,(length (syntax->list #'(onex ...)))
    #'(group len (== onex ...) rest-onex)])
 
-(define-qi-syntax-rule (bundle (n:number ...)
-                               selection-onex:clause
-                               remainder-onex:clause)
+(define-core-qi-syntax-rule (bundle (n:number ...)
+                                    selection-onex:clause
+                                    remainder-onex:clause)
   (-< (~> (select n ...) selection-onex)
       (~> (block n ...) remainder-onex)))
 
 ;;; Conditionals
 
-(define-qi-syntax-rule (when condition:clause
-                         consequent:clause)
+(define-core-qi-syntax-rule (when condition:clause
+                              consequent:clause)
   (if condition consequent ⏚))
 
-(define-qi-syntax-rule (unless condition:clause
-                         alternative:clause)
+(define-core-qi-syntax-rule (unless condition:clause
+                              alternative:clause)
   (if condition ⏚ alternative))
 
-(define-qi-syntax-parser switch
+(define-core-qi-syntax-parser switch
   [(_) #'_]
   [(_ ((~or* (~datum divert) (~datum %))
        condition-gate:clause
@@ -146,7 +146,7 @@
            [condition consequent]
            ...))])
 
-(define-qi-syntax-rule (gate onex:clause)
+(define-core-qi-syntax-rule (gate onex:clause)
   (if onex _ ⏚))
 
 ;;; Common utilities
@@ -155,35 +155,35 @@
 
 (define-for-qi live? ~live?)
 
-(define-qi-syntax-rule (rectify v:expr ...)
+(define-core-qi-syntax-rule (rectify v:expr ...)
   (if live? _ (gen v ...)))
 
 ;;; High level circuit elements
 
 ;; aliases for inputs
-(define-qi-syntax-parser 1>
+(define-core-qi-syntax-parser 1>
   [_:id #'(select 1)])
-(define-qi-syntax-parser 2>
+(define-core-qi-syntax-parser 2>
   [_:id #'(select 2)])
-(define-qi-syntax-parser 3>
+(define-core-qi-syntax-parser 3>
   [_:id #'(select 3)])
-(define-qi-syntax-parser 4>
+(define-core-qi-syntax-parser 4>
   [_:id #'(select 4)])
-(define-qi-syntax-parser 5>
+(define-core-qi-syntax-parser 5>
   [_:id #'(select 5)])
-(define-qi-syntax-parser 6>
+(define-core-qi-syntax-parser 6>
   [_:id #'(select 6)])
-(define-qi-syntax-parser 7>
+(define-core-qi-syntax-parser 7>
   [_:id #'(select 7)])
-(define-qi-syntax-parser 8>
+(define-core-qi-syntax-parser 8>
   [_:id #'(select 8)])
-(define-qi-syntax-parser 9>
+(define-core-qi-syntax-parser 9>
   [_:id #'(select 9)])
 
-(define-qi-syntax-parser inverter
+(define-core-qi-syntax-parser inverter
   [_:id #'(>< NOT)])
 
-(define-qi-syntax-parser effect
+(define-core-qi-syntax-parser effect
   [(_ sidex:clause onex:clause)
    #'(-< (~> sidex ⏚)
          onex)]

qi-lib/macro.rkt

@@ -2,7 +2,9 @@
 
 (provide define-qi-syntax
          define-qi-syntax-rule
+         define-core-qi-syntax-rule
          define-qi-syntax-parser
+         define-core-qi-syntax-parser
          define-qi-foreign-syntaxes
          (for-syntax qi-macro))
 
@@ -95,6 +97,45 @@
           (syntax-parser
             [(_ . pat) #'template])))]))
 
+(define-syntax define-core-qi-syntax-rule
+  (syntax-parser
+    [(_ (name . pat) template)
+     #'(define-qi-syntax name
+         (qi-macro
+          (syntax-parser
+            [(_ . pat) (syntax/loc this-syntax
+                         template)])))]))
+
+(begin-for-syntax
+
+  (define (source-location-contained? inner outer)
+    (and (equal? (syntax-source inner)
+                 (syntax-source outer))
+         (>= (syntax-position inner)
+             (syntax-position outer))
+         (<= (+ (syntax-position inner)
+                (syntax-span inner))
+             (+ (syntax-position outer)
+                (syntax-span outer)))))
+
+  ;; Example: (and g) → g
+  ;; This would naively highlight (and g), but in this case
+  ;; we want to highlight g instead. So, we check whether
+  ;; one expression is contained in the other, and if so,
+  ;; keep the srcloc of the inner one, to handle this.
+  (define (propagate-syntax-loc f)
+    (λ (stx)
+      (let ([res (f stx)])
+        (datum->syntax res  ; lexical context
+          ;; datum
+          (syntax-e res)
+          ;; for srcloc
+          (if (source-location-contained? res stx)
+              res
+              stx)
+          ;; for properties
+          res)))))
+
 (define-syntax define-qi-syntax-parser
   (syntax-parser
     [(_ name clause ...)
@@ -103,6 +144,15 @@
           (syntax-parser
             clause ...)))]))
 
+(define-syntax define-core-qi-syntax-parser
+  (syntax-parser
+    [(_ name clause ...)
+     #'(define-qi-syntax name
+         (qi-macro
+          (propagate-syntax-loc
+           (syntax-parser
+             clause ...))))]))
+
 (define-syntax define-qi-foreign-syntaxes
   (syntax-parser
     [(_ form-name ...)