add lenses for generic syntax/srcloc source locations
This commit is contained in:
AlexKnauth
parent
1f6e77917a
commit
04667e02ac
|
|
@ -6,13 +6,29 @@ provide syntax-srcloc-lens
|
|||
syntax-position-lens
|
||||
syntax-column-lens
|
||||
syntax-span-lens
|
||||
source-location->srcloc-lens
|
||||
source-location->list-lens
|
||||
source-location->vector-lens
|
||||
source-location-source-lens
|
||||
source-location-line-lens
|
||||
source-location-column-lens
|
||||
source-location-position-lens
|
||||
source-location-span-lens
|
||||
|
||||
require fancy-app
|
||||
lens/common
|
||||
syntax/parse/define
|
||||
syntax/srcloc
|
||||
module+ test
|
||||
require rackunit
|
||||
|
||||
(define-simple-macro
|
||||
(define-source-location-lenses [lens-id:id getter:expr update-kw:keyword] ...)
|
||||
(begin
|
||||
(define lens-id
|
||||
(make-lens getter (update-source-location _ update-kw _)))
|
||||
...))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; Syntax
|
||||
|
|
@ -33,30 +49,12 @@ module+ test
|
|||
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 _)))
|
||||
(define-source-location-lenses
|
||||
[syntax-source-lens syntax-source #:source]
|
||||
[syntax-line-lens syntax-line #:line]
|
||||
[syntax-column-lens syntax-column #:column]
|
||||
[syntax-position-lens syntax-position #:position]
|
||||
[syntax-span-lens syntax-span #:span])
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
@ -70,6 +68,45 @@ module+ test
|
|||
(define (source-location->list src)
|
||||
(build-source-location-list src))
|
||||
|
||||
;; source-location->vector : Source-Location -> Source-Location-Vector
|
||||
(define (source-location->vector src)
|
||||
(build-source-location-vector src))
|
||||
|
||||
;; replace-source-location : Syntax Source-Location -> Syntax
|
||||
;; Srcloc Source-Location -> Srcloc
|
||||
;; Source-Location-List Source-Location -> Source-Location-List
|
||||
;; Source-Location-Vector Source-Location -> Source-Location-Vector
|
||||
;; Source-Location Source-Location -> Source-Location
|
||||
(define (replace-source-location old new)
|
||||
(update-source-location old
|
||||
#:source (source-location-source new)
|
||||
#:line (source-location-line new)
|
||||
#:column (source-location-column new)
|
||||
#:position (source-location-position new)
|
||||
#:span (source-location-span new)))
|
||||
|
||||
(define source-location->srcloc-lens
|
||||
(make-lens
|
||||
source-location->srcloc
|
||||
replace-source-location))
|
||||
|
||||
(define source-location->list-lens
|
||||
(make-lens
|
||||
source-location->list
|
||||
replace-source-location))
|
||||
|
||||
(define source-location->vector-lens
|
||||
(make-lens
|
||||
source-location->vector
|
||||
replace-source-location))
|
||||
|
||||
(define-source-location-lenses
|
||||
[source-location-source-lens source-location-source #:source]
|
||||
[source-location-line-lens source-location-line #:line]
|
||||
[source-location-column-lens source-location-column #:column]
|
||||
[source-location-position-lens source-location-position #:position]
|
||||
[source-location-span-lens source-location-span #:span])
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; Tests
|
||||
|
|
@ -82,8 +119,12 @@ module+ test
|
|||
|
||||
(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)))
|
||||
(define a-lst (list 'a 12 5 144 9))
|
||||
(define b-lst (list 'b 49 7 343 14))
|
||||
(define a-vec (vector-immutable 'a 12 5 144 9))
|
||||
(define b-vec (vector-immutable 'b 49 7 343 14))
|
||||
(define a (datum->syntax #f (list '+ 1 2 3) a-lst))
|
||||
(define b (datum->syntax #f (list 'define 'x 987) b-lst))
|
||||
|
||||
(test-case "syntax-srcloc-lens"
|
||||
(check-equal? (lens-view syntax-srcloc-lens a) a-src)
|
||||
|
|
@ -92,6 +133,40 @@ module+ test
|
|||
(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)
|
||||
;; same thing, but with source-location->srcloc-lens instead of syntax-srcloc-lens
|
||||
(check-equal? (lens-view source-location->srcloc-lens a) a-src)
|
||||
(check-equal? (lens-view source-location->srcloc-lens b) b-src)
|
||||
(check-syntax (lens-set source-location->srcloc-lens a a-src) (list '+ 1 2 3) a-src)
|
||||
(check-syntax (lens-set source-location->srcloc-lens b b-src) (list 'define 'x 987) b-src)
|
||||
(check-syntax (lens-set source-location->srcloc-lens a b-src) (list '+ 1 2 3) b-src)
|
||||
(check-syntax (lens-set source-location->srcloc-lens b a-src) (list 'define 'x 987) a-src)
|
||||
;; same thing, but with source-location->list-lens
|
||||
(check-equal? (lens-view source-location->list-lens a) a-lst)
|
||||
(check-equal? (lens-view source-location->list-lens b) b-lst)
|
||||
(check-syntax (lens-set source-location->list-lens a a-lst) (list '+ 1 2 3) a-src)
|
||||
(check-syntax (lens-set source-location->list-lens b b-lst) (list 'define 'x 987) b-src)
|
||||
(check-syntax (lens-set source-location->list-lens a b-lst) (list '+ 1 2 3) b-src)
|
||||
(check-syntax (lens-set source-location->list-lens b a-lst) (list 'define 'x 987) a-src)
|
||||
;; same thing, but with source-location->vector-lens
|
||||
(check-equal? (lens-view source-location->vector-lens a) a-vec)
|
||||
(check-equal? (lens-view source-location->vector-lens b) b-vec)
|
||||
(check-syntax (lens-set source-location->vector-lens a a-vec) (list '+ 1 2 3) a-src)
|
||||
(check-syntax (lens-set source-location->vector-lens b b-vec) (list 'define 'x 987) b-src)
|
||||
(check-syntax (lens-set source-location->vector-lens a b-vec) (list '+ 1 2 3) b-src)
|
||||
(check-syntax (lens-set source-location->vector-lens b a-vec) (list 'define 'x 987) a-src)
|
||||
;; source-location->srcloc-lens also works with other types of source-locations
|
||||
(check-equal? (lens-view source-location->srcloc-lens a-src) a-src)
|
||||
(check-equal? (lens-view source-location->srcloc-lens b-src) b-src)
|
||||
(check-equal? (lens-view source-location->srcloc-lens a-lst) a-src)
|
||||
(check-equal? (lens-view source-location->srcloc-lens b-lst) b-src)
|
||||
(check-equal? (lens-view source-location->srcloc-lens a-vec) a-src)
|
||||
(check-equal? (lens-view source-location->srcloc-lens b-vec) b-src)
|
||||
(check-equal? (lens-set source-location->srcloc-lens a-src b-src) b-src)
|
||||
(check-equal? (lens-set source-location->srcloc-lens a-lst b-src) b-lst)
|
||||
(check-equal? (lens-set source-location->srcloc-lens a-vec b-src) b-vec)
|
||||
(check-equal? (lens-set source-location->srcloc-lens b-src a-src) a-src)
|
||||
(check-equal? (lens-set source-location->srcloc-lens b-lst a-src) a-lst)
|
||||
(check-equal? (lens-set source-location->srcloc-lens b-vec a-src) a-vec)
|
||||
)
|
||||
(test-case "syntax-source-lens"
|
||||
(check-equal? (lens-view syntax-source-lens a) 'a)
|
||||
|
|
@ -102,6 +177,15 @@ module+ test
|
|||
(check-syntax (lens-set syntax-source-lens b "hellooo.rkt")
|
||||
(list 'define 'x 987)
|
||||
(srcloc "hellooo.rkt" 49 7 343 14))
|
||||
;; same thing, but with source-location-source-lens instead of syntax-source-lens
|
||||
(check-equal? (lens-view source-location-source-lens a) 'a)
|
||||
(check-equal? (lens-view source-location-source-lens b) 'b)
|
||||
(check-syntax (lens-set source-location-source-lens a "bye.rkt")
|
||||
(list '+ 1 2 3)
|
||||
(srcloc "bye.rkt" 12 5 144 9))
|
||||
(check-syntax (lens-set source-location-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)
|
||||
|
|
@ -112,6 +196,15 @@ module+ test
|
|||
(check-syntax (lens-set syntax-line-lens b 11)
|
||||
(list 'define 'x 987)
|
||||
(srcloc 'b 11 7 343 14))
|
||||
;; same thing, but with source-location-line-lens instead of syntax-line-lens
|
||||
(check-equal? (lens-view source-location-line-lens a) 12)
|
||||
(check-equal? (lens-view source-location-line-lens b) 49)
|
||||
(check-syntax (lens-set source-location-line-lens a 8)
|
||||
(list '+ 1 2 3)
|
||||
(srcloc 'a 8 5 144 9))
|
||||
(check-syntax (lens-set source-location-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)
|
||||
|
|
@ -122,6 +215,15 @@ module+ test
|
|||
(check-syntax (lens-set syntax-column-lens b 11)
|
||||
(list 'define 'x 987)
|
||||
(srcloc 'b 49 11 343 14))
|
||||
;; same thing, but with source-location-column-lens instead of syntax-column-lens
|
||||
(check-equal? (lens-view source-location-column-lens a) 5)
|
||||
(check-equal? (lens-view source-location-column-lens b) 7)
|
||||
(check-syntax (lens-set source-location-column-lens a 8)
|
||||
(list '+ 1 2 3)
|
||||
(srcloc 'a 12 8 144 9))
|
||||
(check-syntax (lens-set source-location-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)
|
||||
|
|
@ -132,6 +234,15 @@ module+ test
|
|||
(check-syntax (lens-set syntax-position-lens b 610)
|
||||
(list 'define 'x 987)
|
||||
(srcloc 'b 49 7 610 14))
|
||||
;; same thing, but with source-location-position-lens instead of syntax-position-lens
|
||||
(check-equal? (lens-view source-location-position-lens a) 144)
|
||||
(check-equal? (lens-view source-location-position-lens b) 343)
|
||||
(check-syntax (lens-set source-location-position-lens a 233)
|
||||
(list '+ 1 2 3)
|
||||
(srcloc 'a 12 5 233 9))
|
||||
(check-syntax (lens-set source-location-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)
|
||||
|
|
@ -142,5 +253,14 @@ module+ test
|
|||
(check-syntax (lens-set syntax-span-lens b 15)
|
||||
(list 'define 'x 987)
|
||||
(srcloc 'b 49 7 343 15))
|
||||
;; same thing, but with source-location-span-lens instead of syntax-span-lens
|
||||
(check-equal? (lens-view source-location-span-lens a) 9)
|
||||
(check-equal? (lens-view source-location-span-lens b) 14)
|
||||
(check-syntax (lens-set source-location-span-lens a 10)
|
||||
(list '+ 1 2 3)
|
||||
(srcloc 'a 12 5 144 10))
|
||||
(check-syntax (lens-set source-location-span-lens b 15)
|
||||
(list 'define 'x 987)
|
||||
(srcloc 'b 49 7 343 15))
|
||||
)
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@(require lens/private/doc-util/main)
|
||||
@(require lens/private/doc-util/main (for-label syntax/srcloc))
|
||||
|
||||
@title{Syntax object source locations}
|
||||
|
||||
|
|
@ -60,3 +60,23 @@ A lens that views the source span a syntax object.
|
|||
(syntax-span (lens-set syntax-span-lens #'here 34))
|
||||
]}
|
||||
|
||||
@deftogether[[
|
||||
@defthing[source-location->srcloc-lens (lens/c source-location? srcloc?)]
|
||||
@defthing[source-location->list-lens (lens/c source-location? source-location-list?)]
|
||||
@defthing[source-location->vector-lens (lens/c source-location? source-location-vector?)]
|
||||
]]{
|
||||
Lenses for converting from all the common types of source locations
|
||||
into @racket[srcloc] structures, lists, and vectors.
|
||||
}
|
||||
|
||||
@deftogether[[
|
||||
@defthing[source-location-source-lens (lens/c source-location? any/c)]
|
||||
@defthing[source-location-line-lens (lens/c source-location? (or/c exact-positive-integer? #f))]
|
||||
@defthing[source-location-column-lens (lens/c source-location? (or/c exact-nonnegative-integer? #f))]
|
||||
@defthing[source-location-position-lens (lens/c source-location? (or/c exact-positive-integer? #f))]
|
||||
@defthing[source-location-span-lens (lens/c source-location? (or/c exact-nonnegative-integer? #f))]
|
||||
]]{
|
||||
Like @racket[syntax-source-lens], @racket[syntax-line-lens], etc, but for all
|
||||
the common types of source locations.
|
||||
}
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user