Removed dependency on phc-toolkit by moving the fold-syntax implementation here.

This commit is contained in:
Georges Dupéron 2017-04-09 16:59:55 +02:00
parent 3c4811fff6
commit 224c76e76a
5 changed files with 91 additions and 9 deletions

View File

@ -8,10 +8,6 @@ env:
- PATH="$RACKET_DIR/bin:$PATH"
matrix:
# 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.4
- RACKET_VERSION=6.5

View File

@ -6,8 +6,7 @@
(require typed/racket)
(require (submod phc-toolkit untyped)
racket/stxparam
(require racket/stxparam
(for-syntax racket/string
racket/list
syntax/parse
@ -16,7 +15,7 @@
racket/struct
racket/function
syntax/srcloc
phc-toolkit/stx/fold
"private/fold.rkt"
(only-in racket/base [... ])))
(define-for-syntax identifier→string (compose symbol->string syntax-e))

View 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)]))

View File

@ -1,6 +1,6 @@
#lang typed/dotlambda
(require phc-toolkit/typed-rackunit
(require (rename-in typed/rackunit [check-equal? check-equal?:])
;"get.lp2.rkt"
;"graph-test.rkt"
typed-map

View File

@ -2,7 +2,6 @@
(define collection 'multi)
(define deps '("base"
"rackunit-lib"
"phc-toolkit"
"typed-map-lib"
"typed-racket-lib"
"typed-racket-more"))