672910f27b
I started from tabs that are not on the beginning of lines, and in several places I did further cleanings. If you're worried about knowing who wrote some code, for example, if you get to this commit in "git blame", then note that you can use the "-w" flag in many git commands to ignore whitespaces. For example, to see per-line authors, use "git blame -w <file>". Another example: to see the (*much* smaller) non-whitespace changes in this (or any other) commit, use "git log -p -w -1 <sha1>".
183 lines
6.3 KiB
Racket
183 lines
6.3 KiB
Racket
#lang racket
|
|
|
|
(require "test-util.rkt"
|
|
drracket/check-syntax
|
|
redex/pict
|
|
redex/reduction-semantics
|
|
(for-syntax setup/path-to-relative)
|
|
setup/path-to-relative)
|
|
|
|
(reset-count)
|
|
|
|
(define-syntax (identifier stx)
|
|
(syntax-case stx ()
|
|
[(_ x)
|
|
(identifier? #'x)
|
|
#`(let ([p (open-input-string (format "~s" 'x))])
|
|
(port-count-lines! p)
|
|
(set-port-next-location!
|
|
p
|
|
#,(syntax-line #'x)
|
|
#,(syntax-column #'x)
|
|
#,(syntax-position #'x))
|
|
(read-syntax '#,(and (path? (syntax-source #'x))
|
|
(path->relative-string/library (syntax-source #'x)))
|
|
p))]))
|
|
|
|
(define (source stx)
|
|
(list (and (path? (syntax-source stx))
|
|
(path->relative-string/library (syntax-source stx)))
|
|
(syntax-line stx)
|
|
(syntax-column stx)))
|
|
|
|
(define (expected-arrows bindings)
|
|
(for/fold ([arrs (set)]) ([binding bindings])
|
|
(for/fold ([arrs arrs]) ([bound (cdr binding)])
|
|
(set-add arrs
|
|
(list (source (car binding))
|
|
(source bound))))))
|
|
|
|
(define (expected-rename-class binding)
|
|
(apply set (map source binding)))
|
|
|
|
(define collector%
|
|
(class (annotations-mixin object%)
|
|
(super-new)
|
|
(define/override (syncheck:find-source-object stx)
|
|
stx)
|
|
(define/override (syncheck:add-rename-menu id
|
|
all-ids
|
|
new-name-interferes?)
|
|
(match all-ids
|
|
[(list (list ids _ _) ...)
|
|
(set! renames (cons ids renames))]))
|
|
(define renames '())
|
|
(define/public (collected-rename-class stx)
|
|
(for/fold ([class (set)]) ([ids renames])
|
|
(if (for/or ([id ids])
|
|
(equal? (source stx) (source id)))
|
|
(set-union class (apply set (map source ids)))
|
|
class)))
|
|
(define/override (syncheck:add-arrow start-source-obj
|
|
start-left
|
|
start-right
|
|
end-source-obj
|
|
end-left
|
|
end-right
|
|
actual?
|
|
phase-level)
|
|
(set! arrows
|
|
(set-add arrows
|
|
(list (source start-source-obj)
|
|
(source end-source-obj)))))
|
|
(define arrows (set))
|
|
(define/public (collected-arrows) arrows)))
|
|
|
|
(define-namespace-anchor module-anchor)
|
|
(define module-namespace
|
|
(namespace-anchor->namespace module-anchor))
|
|
|
|
;; judgment forms
|
|
(let ([annotations (new collector%)])
|
|
(define-values (add-syntax done)
|
|
(make-traversal module-namespace #f))
|
|
|
|
(define language-def-name (identifier L))
|
|
(define language-use-name (identifier L))
|
|
|
|
(define mode-name (identifier J))
|
|
(define contract-name (identifier J))
|
|
(define conclusion-name (identifier J))
|
|
(define premise-name (identifier J))
|
|
(define render-name (identifier J))
|
|
(define holds-name (identifier J))
|
|
|
|
(define language-binding
|
|
(list language-def-name language-use-name))
|
|
(define judgment-form-binding
|
|
(list mode-name contract-name conclusion-name premise-name render-name holds-name))
|
|
|
|
(parameterize ([current-annotations annotations]
|
|
[current-namespace module-namespace])
|
|
(add-syntax
|
|
(expand #`(let ()
|
|
(define-language #,language-def-name)
|
|
(define-judgment-form #,language-use-name
|
|
#:mode (#,mode-name)
|
|
#:contract (#,contract-name)
|
|
[(#,conclusion-name)
|
|
(#,premise-name)])
|
|
(render-judgment-form #,render-name)
|
|
(judgment-holds (#,holds-name)))))
|
|
(done))
|
|
|
|
(test (send annotations collected-arrows)
|
|
(expected-arrows
|
|
(list language-binding judgment-form-binding)))
|
|
(test (send annotations collected-rename-class language-def-name)
|
|
(expected-rename-class language-binding))
|
|
(test (send annotations collected-rename-class mode-name)
|
|
(expected-rename-class judgment-form-binding)))
|
|
|
|
;; metafunctions
|
|
(let ([annotations (new collector%)])
|
|
(define-values (add-syntax done)
|
|
(make-traversal module-namespace #f))
|
|
|
|
(define language-def-name (identifier L))
|
|
(define language-use-name (identifier L))
|
|
|
|
(define contract-name (identifier f))
|
|
(define lhs-name (identifier f))
|
|
(define rhs-name (identifier f))
|
|
(define render-name (identifier f))
|
|
(define term-name (identifier f))
|
|
|
|
(define language-binding
|
|
(list language-def-name language-use-name))
|
|
(define metafunction-binding
|
|
(list contract-name lhs-name rhs-name render-name term-name))
|
|
|
|
(parameterize ([current-annotations annotations]
|
|
[current-namespace module-namespace])
|
|
(add-syntax
|
|
(expand #`(let ()
|
|
(define-language #,language-def-name)
|
|
(define-metafunction #,language-use-name
|
|
#,contract-name : () -> ()
|
|
[(#,lhs-name) (#,rhs-name)])
|
|
(render-metafunction #,render-name)
|
|
(term (#,term-name)))))
|
|
(done))
|
|
|
|
(test (send annotations collected-arrows)
|
|
(expected-arrows
|
|
(list language-binding metafunction-binding)))
|
|
(test (send annotations collected-rename-class language-def-name)
|
|
(expected-rename-class language-binding))
|
|
(test (send annotations collected-rename-class contract-name)
|
|
(expected-rename-class metafunction-binding)))
|
|
|
|
;; define-term
|
|
(let ([annotations (new collector%)])
|
|
(define-values (add-syntax done)
|
|
(make-traversal module-namespace #f))
|
|
|
|
(define def-name (identifier x))
|
|
(define use-name (identifier x))
|
|
|
|
(parameterize ([current-annotations annotations]
|
|
[current-namespace module-namespace])
|
|
(add-syntax
|
|
(expand #`(let ()
|
|
(define-term #,def-name a)
|
|
(term (#,use-name b)))))
|
|
(done))
|
|
|
|
(test (send annotations collected-rename-class def-name)
|
|
(expected-rename-class (list def-name use-name)))
|
|
(test (send annotations collected-rename-class use-name)
|
|
(expected-rename-class (list def-name use-name))))
|
|
|
|
(print-tests-passed 'check-syntax-test.rkt)
|