diff --git a/lens-data/lens/private/syntax/srcloc.rkt b/lens-data/lens/private/syntax/srcloc.rkt new file mode 100644 index 0000000..75424a7 --- /dev/null +++ b/lens-data/lens/private/syntax/srcloc.rkt @@ -0,0 +1,146 @@ +#lang sweet-exp racket/base + +provide syntax-srcloc-lens + syntax-source-lens + syntax-line-lens + syntax-position-lens + syntax-column-lens + syntax-span-lens + +require fancy-app + lens/common + syntax/srcloc +module+ test + require rackunit + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Syntax + +;; syntax-srcloc : Syntax -> Srcloc +(define (syntax-srcloc stx) + (source-location->srcloc stx)) + +;; syntax-set-source-location : Syntax Source-Location -> Syntax +(define (syntax-set-source-location stx src) + (datum->syntax stx + (syntax-e stx) + (source-location->list src) + stx)) + +(define syntax-srcloc-lens + (make-lens + syntax-srcloc + syntax-set-source-location)) + +(define syntax-source-lens + (make-lens + syntax-source + (update-source-location _ #:source _))) + +(define syntax-line-lens + (make-lens + syntax-line + (update-source-location _ #:line _))) + +(define syntax-column-lens + (make-lens + syntax-column + (update-source-location _ #:column _))) + +(define syntax-position-lens + (make-lens + syntax-position + (update-source-location _ #:position _))) + +(define syntax-span-lens + (make-lens + syntax-span + (update-source-location _ #:span _))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Source Locations + +;; source-location->srcloc : Source-Location -> Srcloc +(define (source-location->srcloc src) + (build-source-location src)) + +;; source-location->list : Source-Location -> Source-Location-List +(define (source-location->list src) + (build-source-location-list src)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Tests + +(module+ test + (define-check (check-syntax actual-stx expected-datum expected-srcloc) + (check-pred syntax? actual-stx) + (check-equal? (syntax->datum actual-stx) expected-datum) + (check-equal? (syntax-srcloc actual-stx) expected-srcloc)) + + (define a-src (srcloc 'a 12 5 144 9)) + (define b-src (srcloc 'b 49 7 343 14)) + (define a (datum->syntax #f (list '+ 1 2 3) (source-location->list a-src))) + (define b (datum->syntax #f (list 'define 'x 987) (source-location->list b-src))) + + (test-case "syntax-srcloc-lens" + (check-equal? (lens-view syntax-srcloc-lens a) a-src) + (check-equal? (lens-view syntax-srcloc-lens b) b-src) + (check-syntax (lens-set syntax-srcloc-lens a a-src) (list '+ 1 2 3) a-src) + (check-syntax (lens-set syntax-srcloc-lens b b-src) (list 'define 'x 987) b-src) + (check-syntax (lens-set syntax-srcloc-lens a b-src) (list '+ 1 2 3) b-src) + (check-syntax (lens-set syntax-srcloc-lens b a-src) (list 'define 'x 987) a-src) + ) + (test-case "syntax-source-lens" + (check-equal? (lens-view syntax-source-lens a) 'a) + (check-equal? (lens-view syntax-source-lens b) 'b) + (check-syntax (lens-set syntax-source-lens a "bye.rkt") + (list '+ 1 2 3) + (srcloc "bye.rkt" 12 5 144 9)) + (check-syntax (lens-set syntax-source-lens b "hellooo.rkt") + (list 'define 'x 987) + (srcloc "hellooo.rkt" 49 7 343 14)) + ) + (test-case "syntax-line-lens" + (check-equal? (lens-view syntax-line-lens a) 12) + (check-equal? (lens-view syntax-line-lens b) 49) + (check-syntax (lens-set syntax-line-lens a 8) + (list '+ 1 2 3) + (srcloc 'a 8 5 144 9)) + (check-syntax (lens-set syntax-line-lens b 11) + (list 'define 'x 987) + (srcloc 'b 11 7 343 14)) + ) + (test-case "syntax-column-lens" + (check-equal? (lens-view syntax-column-lens a) 5) + (check-equal? (lens-view syntax-column-lens b) 7) + (check-syntax (lens-set syntax-column-lens a 8) + (list '+ 1 2 3) + (srcloc 'a 12 8 144 9)) + (check-syntax (lens-set syntax-column-lens b 11) + (list 'define 'x 987) + (srcloc 'b 49 11 343 14)) + ) + (test-case "syntax-position-lens" + (check-equal? (lens-view syntax-position-lens a) 144) + (check-equal? (lens-view syntax-position-lens b) 343) + (check-syntax (lens-set syntax-position-lens a 233) + (list '+ 1 2 3) + (srcloc 'a 12 5 233 9)) + (check-syntax (lens-set syntax-position-lens b 610) + (list 'define 'x 987) + (srcloc 'b 49 7 610 14)) + ) + (test-case "syntax-span-lens" + (check-equal? (lens-view syntax-span-lens a) 9) + (check-equal? (lens-view syntax-span-lens b) 14) + (check-syntax (lens-set syntax-span-lens a 10) + (list '+ 1 2 3) + (srcloc 'a 12 5 144 10)) + (check-syntax (lens-set syntax-span-lens b 15) + (list 'define 'x 987) + (srcloc 'b 49 7 343 15)) + ) + ) diff --git a/lens-doc/lens/private/syntax/srcloc.scrbl b/lens-doc/lens/private/syntax/srcloc.scrbl new file mode 100644 index 0000000..6cd7132 --- /dev/null +++ b/lens-doc/lens/private/syntax/srcloc.scrbl @@ -0,0 +1,62 @@ +#lang scribble/manual + +@(require lens/private/doc-util/main) + +@title{Syntax object source locations} + +@defthing[syntax-srcloc-lens (lens/c syntax? srcloc?)]{ +A lens that views the source location of a syntax object as a +@racket[srcloc] structure. + +@lens-unstable-examples[ + (lens-view syntax-srcloc-lens #'here) + (lens-set syntax-srcloc-lens #'here (srcloc "a.rkt" 5 8 55 13)) + (syntax-source (lens-set syntax-srcloc-lens #'here (srcloc "a.rkt" 5 8 55 13))) + (syntax-position (lens-set syntax-srcloc-lens #'here (srcloc "a.rkt" 5 8 55 13))) +]} + +@defthing[syntax-source-lens (lens/c syntax? any/c)]{ +A lens that views the source field of a syntax object. + +@lens-unstable-examples[ + (lens-view syntax-source-lens #'here) + (lens-set syntax-source-lens #'here "a.rkt") + (syntax-source (lens-set syntax-source-lens #'here "a.rkt")) +]} + +@defthing[syntax-line-lens (lens/c syntax? (or/c exact-positive-integer? #f))]{ +A lens that views the line number of a syntax object. + +@lens-unstable-examples[ + (lens-view syntax-line-lens #'here) + (lens-set syntax-line-lens #'here 8) + (syntax-line (lens-set syntax-line-lens #'here 8)) +]} + +@defthing[syntax-column-lens (lens/c syntax? (or/c exact-nonnegative-integer? #f))]{ +A lens that views the column number of a syntax object within its line. + +@lens-unstable-examples[ + (lens-view syntax-column-lens #'here) + (lens-set syntax-column-lens #'here 13) + (syntax-column (lens-set syntax-column-lens #'here 13)) +]} + +@defthing[syntax-position-lens (lens/c syntax? (or/c exact-positive-integer? #f))]{ +A lens that views the source position a syntax object. + +@lens-unstable-examples[ + (lens-view syntax-position-lens #'here) + (lens-set syntax-position-lens #'here 21) + (syntax-position (lens-set syntax-position-lens #'here 21)) +]} + +@defthing[syntax-span-lens (lens/c syntax? (or/c exact-nonnegative-integer? #f))]{ +A lens that views the source span a syntax object. + +@lens-unstable-examples[ + (lens-view syntax-span-lens #'here) + (lens-set syntax-span-lens #'here 34) + (syntax-span (lens-set syntax-span-lens #'here 34)) +]} + diff --git a/lens-doc/unstable/lens/main.scrbl b/lens-doc/unstable/lens/main.scrbl index 8f37126..ea8dc2f 100644 --- a/lens-doc/unstable/lens/main.scrbl +++ b/lens-doc/unstable/lens/main.scrbl @@ -34,6 +34,7 @@ this library being backwards-compatible. "substring.scrbl" "syntax.scrbl" (lib "lens/private/syntax/stx.scrbl") + (lib "lens/private/syntax/srcloc.scrbl") "set-all.scrbl" "zoom.scrbl" ) diff --git a/lens-unstable/unstable/lens/main.rkt b/lens-unstable/unstable/lens/main.rkt index 8382eb1..04ddfff 100644 --- a/lens-unstable/unstable/lens/main.rkt +++ b/lens-unstable/unstable/lens/main.rkt @@ -21,5 +21,6 @@ "substring.rkt" "syntax.rkt" "syntax/stx.rkt" +"syntax/srcloc.rkt" "set-all.rkt" "zoom.rkt" diff --git a/lens-unstable/unstable/lens/syntax/srcloc.rkt b/lens-unstable/unstable/lens/syntax/srcloc.rkt new file mode 100644 index 0000000..c1ef41a --- /dev/null +++ b/lens-unstable/unstable/lens/syntax/srcloc.rkt @@ -0,0 +1,2 @@ +#lang reprovide +lens/private/syntax/srcloc