Removed dependency on phc-toolkit by moving the fold-syntax implementation here.
This commit is contained in:
parent
3c4811fff6
commit
224c76e76a
|
@ -8,10 +8,6 @@ env:
|
||||||
- PATH="$RACKET_DIR/bin:$PATH"
|
- PATH="$RACKET_DIR/bin:$PATH"
|
||||||
matrix:
|
matrix:
|
||||||
# RACKET_VERSION is an argument to install-racket.sh
|
# RACKET_VERSION is an argument to install-racket.sh
|
||||||
- RACKET_VERSION=6.0
|
|
||||||
- RACKET_VERSION=6.1
|
|
||||||
- RACKET_VERSION=6.1.1
|
|
||||||
- RACKET_VERSION=6.2
|
|
||||||
- RACKET_VERSION=6.3
|
- RACKET_VERSION=6.3
|
||||||
- RACKET_VERSION=6.4
|
- RACKET_VERSION=6.4
|
||||||
- RACKET_VERSION=6.5
|
- RACKET_VERSION=6.5
|
||||||
|
|
|
@ -6,8 +6,7 @@
|
||||||
|
|
||||||
(require typed/racket)
|
(require typed/racket)
|
||||||
|
|
||||||
(require (submod phc-toolkit untyped)
|
(require racket/stxparam
|
||||||
racket/stxparam
|
|
||||||
(for-syntax racket/string
|
(for-syntax racket/string
|
||||||
racket/list
|
racket/list
|
||||||
syntax/parse
|
syntax/parse
|
||||||
|
@ -16,7 +15,7 @@
|
||||||
racket/struct
|
racket/struct
|
||||||
racket/function
|
racket/function
|
||||||
syntax/srcloc
|
syntax/srcloc
|
||||||
phc-toolkit/stx/fold
|
"private/fold.rkt"
|
||||||
(only-in racket/base [... …])))
|
(only-in racket/base [... …])))
|
||||||
|
|
||||||
(define-for-syntax identifier→string (compose symbol->string syntax-e))
|
(define-for-syntax identifier→string (compose symbol->string syntax-e))
|
||||||
|
|
88
dotlambda/private/fold.rkt
Normal file
88
dotlambda/private/fold.rkt
Normal file
|
@ -0,0 +1,88 @@
|
||||||
|
#lang racket
|
||||||
|
;; Copied verbatim from my phc-toolkit, to avoid dependency on it. phc-toolkit
|
||||||
|
;; should probably re-export these instead of having a copy.
|
||||||
|
|
||||||
|
(provide fold-syntax
|
||||||
|
replace-top-loc
|
||||||
|
syntax/top-loc
|
||||||
|
quasisyntax/top-loc
|
||||||
|
syntax/whole-loc
|
||||||
|
quasisyntax/whole-loc)
|
||||||
|
|
||||||
|
(define (fold-syntax f stx)
|
||||||
|
(let process ([stx stx])
|
||||||
|
(cond
|
||||||
|
[(syntax? stx)
|
||||||
|
(f stx (λ (x) (datum->syntax stx (process (syntax-e x)) stx stx)))]
|
||||||
|
[(pair? stx)
|
||||||
|
(cons (process (car stx))
|
||||||
|
(process (cdr stx)))]
|
||||||
|
[(null? stx)
|
||||||
|
stx]
|
||||||
|
[(vector? stx)
|
||||||
|
(list->vector (map process (vector->list stx)))]
|
||||||
|
[(box? stx)
|
||||||
|
(box (process (unbox stx)))]
|
||||||
|
[(hash? stx)
|
||||||
|
(define processed (process (hash->list stx)))
|
||||||
|
(cond
|
||||||
|
[(hash-equal? stx) (hash processed)]
|
||||||
|
[(hash-eqv? stx) (hasheqv processed)]
|
||||||
|
[(hash-eq? stx) (hasheq processed)])]
|
||||||
|
[(prefab-struct-key stx)
|
||||||
|
(apply make-prefab-struct
|
||||||
|
(prefab-struct-key stx)
|
||||||
|
(map process (vector->list (struct->vector stx))))]
|
||||||
|
[else
|
||||||
|
stx])))
|
||||||
|
|
||||||
|
;; Replaces the syntax/loc for the top of the syntax object, until
|
||||||
|
;; a part which doesn't belong to old-source is reached.
|
||||||
|
;; e.g. (with-syntax ([d user-provided-syntax])
|
||||||
|
;; (replace-top-loc
|
||||||
|
;; #'(a b (c d e))
|
||||||
|
;; (syntax-source #'here)
|
||||||
|
;; new-loc))
|
||||||
|
;; will produce a syntax object #'(a b (c (x (y) z) e))
|
||||||
|
;; where a, b, c, z, e and their surrounding forms have their srcloc set to
|
||||||
|
;; new-loc, but (x (y) z) will be left intact, if the user-provided-syntax
|
||||||
|
;; appears in another file.
|
||||||
|
|
||||||
|
(define (replace-top-loc stx old-source new-loc)
|
||||||
|
(fold-syntax
|
||||||
|
(λ (stx rec)
|
||||||
|
(if (equal? (syntax-source stx) old-source)
|
||||||
|
(datum->syntax stx (rec stx) new-loc stx)
|
||||||
|
stx))
|
||||||
|
stx))
|
||||||
|
|
||||||
|
;; Use the following function to replace the loc throughout stx
|
||||||
|
;; instead of stopping the depth-first-search when the syntax-source
|
||||||
|
;; is not old-source anymore
|
||||||
|
(define (replace-whole-loc stx old-source new-loc)
|
||||||
|
(fold-syntax
|
||||||
|
(λ (stx rec)
|
||||||
|
(if (equal? (syntax-source stx) old-source)
|
||||||
|
(datum->syntax stx (rec stx) new-loc stx)
|
||||||
|
(rec stx)))
|
||||||
|
stx))
|
||||||
|
|
||||||
|
(define-syntax (syntax/top-loc stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(self loc template)
|
||||||
|
#'(replace-top-loc #'template (syntax-source #'self) loc)]))
|
||||||
|
|
||||||
|
(define-syntax (quasisyntax/top-loc stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(self loc template)
|
||||||
|
#'(replace-top-loc #`template (syntax-source #'self) loc)]))
|
||||||
|
|
||||||
|
(define-syntax (syntax/whole-loc stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(self loc template)
|
||||||
|
#'(replace-whole-loc #'template (syntax-source #'self) loc)]))
|
||||||
|
|
||||||
|
(define-syntax (quasisyntax/whole-loc stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(self loc template)
|
||||||
|
#'(replace-whole-loc #`template (syntax-source #'self) loc)]))
|
|
@ -1,6 +1,6 @@
|
||||||
#lang typed/dotlambda
|
#lang typed/dotlambda
|
||||||
|
|
||||||
(require phc-toolkit/typed-rackunit
|
(require (rename-in typed/rackunit [check-equal? check-equal?:])
|
||||||
;"get.lp2.rkt"
|
;"get.lp2.rkt"
|
||||||
;"graph-test.rkt"
|
;"graph-test.rkt"
|
||||||
typed-map
|
typed-map
|
||||||
|
|
Loading…
Reference in New Issue
Block a user