Change make-*-req/prov-tr to take id-(un)manglers to lift out repeate…

…d code
lexi-lambda · Jun 4, 2018 · 21aaffb · 21aaffb
1 parent 5a83945
commit 21aaffb
Show file tree

Hide file tree

Showing 3 changed files with 33 additions and 34 deletions.
diff --git a/hackett-lib/hackett/private/mangle/mangle-identifier.rkt b/hackett-lib/hackett/private/mangle/mangle-identifier.rkt
@@ -3,9 +3,12 @@
 (provide make-id-mangler
          or/unmangler
          prefix/unmangler
-         id-mangler)
+         no-introduce/unmangler
+         id-mangler
+         no-introduce/mangler)
 
-(require racket/syntax
+(require racket/match
+         racket/syntax
          "mangle-string.rkt")
 
 ;; An IdMangler is an (id-mangler StxIntroducer StringMangler)
@@ -49,6 +52,16 @@
        (format-id unmangled "~a~a" pre unmangled
                   #:source unmangled #:props unmangled)))
 
+;; IdUnmangler -> IdUnmangler
+(define ((no-introduce/unmangler id-un) x)
+  (define unmangled (id-un x))
+  (and unmangled
+       (datum->syntax x (syntax-e unmangled) x x)))
+
+;; IdUnmangler -> IdUnmangler
+(define (no-introduce/mangler id-mangler*)
+  (match-define (id-mangler _ string-mangler) id-mangler*)
+  (id-mangler values string-mangler))
 
 ;; ---------------------------------------------------------
 
@@ -65,4 +78,3 @@
      #false]))
 
 ;; ---------------------------------------------------------
-
diff --git a/hackett-lib/hackett/private/mangle/mangle-reqprov.rkt b/hackett-lib/hackett/private/mangle/mangle-reqprov.rkt
@@ -20,14 +20,7 @@
 ;; #:introducer StxIntroducer
 ;; ->
 ;; RequireTransformer
-(define (make-unmangling-require-transformer #:mangle-prefix mangle-prefix
-                                             #:introducer intro)
-
-  (define-values [id-mangler id-unmangler]
-    (make-id-mangler #:prefix mangle-prefix #:introducer intro))
-  (define-values [id-mangler/no-intro id-unmangler/no-intro]
-    (make-id-mangler #:prefix mangle-prefix #:introducer identity))
-
+(define (make-unmangling-require-transformer id-unmangler)
   (make-require-transformer
    (syntax-parser
      [(_ {~alt {~optional {~or {~and #:no-introduce no-introduce?}
@@ -36,19 +29,20 @@
          ...
          require-spec ...)
       #:do [(define id-unmangler*
-              (if (or (@ no-introduce?) (@ prefix))
-                  id-unmangler/no-intro
-                  id-unmangler))
-            (define id-unmangler**
-              (if (@ prefix)
-                  (prefix/unmangler (syntax-e (@ prefix)) id-unmangler*)
-                  id-unmangler*))
+              (let* ([unm id-unmangler]
+                     [unm (if (or (@ no-introduce?) (@ prefix))
+                            (no-introduce/unmangler unm)
+                            unm)]
+                     [unm (if (@ prefix)
+                            (prefix/unmangler (syntax-e (@ prefix)) unm)
+                            unm)])
+                unm))
 
             (define-values [imports sources]
               (expand-import #'(combine-in require-spec ...)))]
 
       (values (for*/list ([i (in-list imports)]
-                          [i* (in-value (unmangle-import i id-unmangler**))]
+                          [i* (in-value (unmangle-import i id-unmangler*))]
                           #:when (if (@ only?) i* #t))
                 (or i* i))
               sources)])))
@@ -57,21 +51,14 @@
 ;; #:introducer StxIntroducer
 ;; ->
 ;; ProvideTransformer
-(define (make-mangling-provide-transformer #:mangle-prefix mangle-prefix
-                                           #:introducer intro)
-
-  (define-values [id-mangler id-unmangler]
-    (make-id-mangler #:prefix mangle-prefix #:introducer intro))
-  (define-values [id-mangler/no-intro id-unmangler/no-intro]
-    (make-id-mangler #:prefix mangle-prefix #:introducer identity))
-
+(define (make-mangling-provide-transformer id-mangler)
   (make-provide-transformer
    (λ (stx modes)
      (syntax-parse stx
        [(_ {~optional {~and #:no-introduce no-introduce?}} provide-spec ...)
         #:do [(define id-mangler*
                 (if (@ no-introduce?)
-                    id-mangler/no-intro
+                    (no-introduce/mangler id-mangler)
                     id-mangler))
 
               (define exports
@@ -88,4 +75,3 @@
 (define (unzip xs/ys)
   (values (map first xs/ys)
           (map second xs/ys)))
-
diff --git a/hackett-lib/hackett/private/type-reqprov.rkt b/hackett-lib/hackett/private/type-reqprov.rkt
@@ -30,17 +30,18 @@
          syntax/parse/define
 
          (for-syntax hackett/private/typecheck
+                     "mangle/mangle-identifier.rkt"
                      "mangle/mangle-reqprov.rkt"))
 
 (provide for-type unmangle-types-in)
 
 (begin-for-syntax
-  (define type-prefix "#%hackett-type:"))
+  (define-values [type-id-mangler type-id-unmangler]
+    (make-id-mangler #:prefix "#%hackett-type:"
+                     #:introducer type-namespace-introduce)))
 
 (define-syntax for-type
-  (make-mangling-provide-transformer #:mangle-prefix type-prefix
-                                     #:introducer type-namespace-introduce))
+  (make-mangling-provide-transformer type-id-mangler))
 
 (define-syntax unmangle-types-in
-  (make-unmangling-require-transformer #:mangle-prefix type-prefix
-                                       #:introducer type-namespace-introduce))
+  (make-unmangling-require-transformer type-id-unmangler))