www

commit 224c76e76a215ad70a3ce7896212be6f55bf9b03
parent 3c4811fff6abad9c09b83b35729427362276712a
Author: Georges Dupéron <georges.duperon@gmail.com>
Date:   Sun,  9 Apr 2017 16:59:55 +0200

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

Diffstat:
M
.travis.yml
 | 
4
----
M
dotlambda/implementation.rkt
 | 
5
++---
A
dotlambda/private/fold.rkt
 | 
89
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
M
dotlambda/test/test-typed-dotlambda.rkt
 | 
2
+-
M
info.rkt
 | 
1
-

5 files changed, 92 insertions(+), 9 deletions(-)
diff --git a/.travis.yml b/.travis.yml
@@ -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
diff --git a/dotlambda/implementation.rkt b/dotlambda/implementation.rkt
@@ -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))
diff --git a/dotlambda/private/fold.rkt b/dotlambda/private/fold.rkt
@@ -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)]))
+\ No newline at end of file
diff --git a/dotlambda/test/test-typed-dotlambda.rkt b/dotlambda/test/test-typed-dotlambda.rkt
@@ -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
diff --git a/info.rkt b/info.rkt
@@ -2,7 +2,6 @@
 (define collection 'multi)
 (define deps '("base"
                "rackunit-lib"
-               "phc-toolkit"
                "typed-map-lib"
                "typed-racket-lib"
                "typed-racket-more"))