From fb6bdfc04677d9ace67656c69cd89fdadcf7c7b9 Mon Sep 17 00:00:00 2001 From: Siddhartha Date: Fri, 29 Mar 2024 12:41:09 -0700 Subject: [PATCH] Define internal macros so that they propagate user source location This is WIP from today's meeting, and is intended to be used together with an upcoming utility in Syntax Spec to help implicate the appropriate user syntax when an error happens during compilation. --- qi-lib/flow/extended/forms.rkt | 62 +++++++++++++++++----------------- qi-lib/macro.rkt | 50 +++++++++++++++++++++++++++ 2 files changed, 81 insertions(+), 31 deletions(-) diff --git a/qi-lib/flow/extended/forms.rkt b/qi-lib/flow/extended/forms.rkt index a1080b8fb..f6822d4c8 100644 --- a/qi-lib/flow/extended/forms.rkt +++ b/qi-lib/flow/extended/forms.rkt @@ -30,26 +30,26 @@ (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?)) @@ -57,34 +57,34 @@ ;; 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)] diff --git a/qi-lib/macro.rkt b/qi-lib/macro.rkt index 7a0e84040..77d5b314d 100644 --- a/qi-lib/macro.rkt +++ b/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 ...)