refactor name mangling

hackett-doc/scribble/manual/hackett.rkt

@@ -3,7 +3,7 @@
 (require hackett/private/type-reqprov
 
          (for-label hackett
-                    (only-in (unmangle-types-in #:no-introduce (only-types-in hackett)) =>))
+                    (only-in (unmangle-types-in #:no-introduce #:only hackett) =>))
 
          (for-syntax racket/base
                      racket/contract

hackett-lib/hackett/private/adt.rkt

@@ -19,7 +19,7 @@
          (except-in hackett/private/base @%app)
          (only-in hackett/private/class class-id derive-instance)
          (only-in hackett/private/kernel [λ plain-λ])
-         (only-in (unmangle-types-in #:no-introduce (only-types-in hackett/private/kernel))
+         (only-in (unmangle-types-in #:no-introduce #:only hackett/private/kernel)
                   forall [#%app @%app]))
 
 (provide (for-syntax type-constructor-spec data-constructor-spec

hackett-lib/hackett/private/class.rkt

@@ -12,7 +12,7 @@
 
          (for-syntax hackett/private/infix)
          (except-in hackett/private/base @%app)
-         (only-in (unmangle-types-in #:no-introduce (only-types-in hackett/private/kernel))
+         (only-in (unmangle-types-in #:no-introduce #:only hackett/private/kernel)
                   ∀ => [#%app @%app]))
 
 (provide (for-syntax class-id)

hackett-lib/hackett/private/kernel.rkt

@@ -54,8 +54,7 @@
 
 (define-syntax-parser #%require/only-types
   [(_ require-spec ...)
-   (type-namespace-introduce
-    #'(@%require (only-types-in require-spec ...)))])
+   #'(require (unmangle-types-in #:only require-spec ...))])
 
 (define-syntax-parser λ
   [(_ [x:id] e:expr)

hackett-lib/hackett/private/mangle/mangle-identifier.rkt

@@ -0,0 +1,80 @@
+#lang racket/base
+
+(provide make-id-mangler
+         or/unmangler
+         prefix/unmangler
+         no-introduce/unmangler
+         id-mangler
+         no-introduce/mangler)
+
+(require racket/match
+         racket/syntax
+         "mangle-string.rkt")
+
+;; An IdMangler is an (id-mangler StxIntroducer StringMangler)
+(struct id-mangler [introducer string-mangler])
+
+;; An IdUnmangler is a function:
+;;   Identifier -> [Maybe Identifier]
+
+;; ---
+
+;; A StringMangler is a function:
+;;   String -> String
+
+;; A StringUnmangler is a function:
+;;   String -> [Maybe String]
+
+;; A StxIntroducer is a function:
+;;   Syntax -> Syntax
+;; Which adds or removes scopes from the input without
+;; changing the datum, source-location, or other properties.
+
+;; ---
+
+;; #:prefix String #:introducer StxIntroducer ->
+;; (values IdMangler IdUnmangler)
+(define (make-id-mangler #:prefix mangle-prefix #:introducer intro)
+  (define-values [str-mangler str-unmangler]
+    (make-string-mangler #:prefix mangle-prefix))
+  (values (id-mangler intro str-mangler)
+          (string-unmangler->id-unmangler str-unmangler intro)))
+
+;; IdUnmangler ... -> IdUnmangler
+(define ((or/unmangler . id-un*) x)
+  (for/or ([id-un (in-list id-un*)])
+    (id-un x)))
+
+;; Symbol IdUnmangler -> IdUnmangler
+(define ((prefix/unmangler pre id-un) x)
+  (define unmangled (id-un x))
+  (and unmangled
+       (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))
+
+;; ---------------------------------------------------------
+
+;; StringUnmangler StxIntroducer -> IdUnmangler
+(define ((string-unmangler->id-unmangler str-unmangle intro) x)
+  (define name (symbol->string (syntax-e x)))
+  (cond
+    [(str-unmangle name)
+     =>
+     (λ (unmangled-name)
+       (intro
+        (datum->syntax x (string->symbol unmangled-name) x x)))]
+    [else
+     #false]))
+
+;; ---------------------------------------------------------

hackett-lib/hackett/private/mangle/mangle-import-export.rkt

@@ -0,0 +1,34 @@
+#lang racket/base
+
+(provide mangle-export
+         unmangle-import)
+
+(require racket/match
+         racket/provide-transform
+         racket/require-transform
+         threading
+         "mangle-identifier.rkt")
+
+;; ---------------------------------------------------------
+
+;; Export StringMangler -> Export
+(define (mangle-export e id-mangler*)
+  (match-define (id-mangler intro mangle-str) id-mangler*)
+  (struct-copy export e
+    [local-id (intro (export-local-id e))]
+    [out-sym (~>> (export-out-sym e)
+                  symbol->string
+                  mangle-str
+                  string->symbol)]))
+
+;; Import IdUnmangler -> [Maybe Import]
+(define (unmangle-import i id-unmangler)
+  (match i
+    [(import local-id src-sym src-mod-path mode req-mode orig-mode orig-stx)
+     (define unmangled (id-unmangler local-id))
+     (and unmangled
+          (import unmangled
+                  src-sym src-mod-path mode req-mode orig-mode orig-stx))]))
+
+;; ---------------------------------------------------------
+

hackett-lib/hackett/private/mangle/mangle-reqprov.rkt

@@ -0,0 +1,70 @@
+#lang racket/base
+
+(provide make-unmangling-require-transformer
+         make-mangling-provide-transformer)
+
+(require racket/function
+         racket/list
+         racket/provide-transform
+         racket/require-transform
+         syntax/parse
+         (only-in syntax/parse [attribute @])
+         threading
+         (for-template racket/base)
+         "mangle-identifier.rkt"
+         "mangle-import-export.rkt")
+
+;; ---------------------------------------------------------
+
+;; #:mangle-prefix String
+;; #:introducer StxIntroducer
+;; ->
+;; RequireTransformer
+(define (make-unmangling-require-transformer id-unmangler)
+  (make-require-transformer
+   (syntax-parser
+     [(_ {~alt {~optional {~or {~and #:no-introduce no-introduce?}
+                               {~seq #:prefix prefix:id}}}
+               {~optional {~and #:only only?}}}
+         ...
+         require-spec ...)
+      #:do [(define 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*))]
+                          #:when (if (@ only?) i* #t))
+                (or i* i))
+              sources)])))
+
+;; #:mangle-prefix String
+;; #:introducer StxIntroducer
+;; ->
+;; ProvideTransformer
+(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?)
+                    (no-introduce/mangler id-mangler)
+                    id-mangler))
+
+              (define exports
+                (expand-export (syntax/loc this-syntax
+                                 (combine-out provide-spec ...))
+                               modes))]
+
+        (for/list ([e (in-list exports)])
+          (mangle-export e id-mangler*))]))))

hackett-lib/hackett/private/mangle/mangle-string.rkt

@@ -0,0 +1,44 @@
+#lang racket/base
+
+(provide make-string-mangler)
+
+(require threading
+         racket/list)
+(module+ test
+  (require rackunit))
+
+;; A StringMangler is a function:
+;;   String -> String
+
+;; A StringUnmangler is a function:
+;;   String -> [Maybe String]
+
+;; #:prefix String -> (values StringMangler StringUnmangler)
+(define (make-string-mangler #:prefix mangle-prefix)
+  (define mangled-regexp
+    (regexp (string-append "^"
+                           (regexp-quote mangle-prefix)
+                           "(.*)$")))
+
+  ;; String -> String
+  (define (mangle-string name)
+    (string-append mangle-prefix name))
+
+  ;; String -> [Maybe String]
+  (define (unmangle-string name)
+    (and~> (regexp-match mangled-regexp name) second))
+
+  (values mangle-string unmangle-string))
+
+;; ---------------------------------------------------------
+
+(module+ test
+  (define pre "#%hackett-test:")
+  (define-values [mangle unmangle]
+    (make-string-mangler #:prefix pre))
+
+  (check-equal? (unmangle (mangle "ahotenus")) "ahotenus")
+  (check-equal? (unmangle (mangle "jatkae")) "jatkae")
+  (check-equal? (unmangle "ahotenus") #false)
+  )
+

hackett-lib/hackett/private/prim/op.rkt

@@ -10,8 +10,8 @@
                                    racket/string))
 
          hackett/private/base
-         (only-in (unmangle-types-in #:no-introduce (only-types-in hackett/private/kernel)) forall)
-         (unmangle-types-in #:no-introduce (only-types-in hackett/private/prim/type))
+         (only-in (unmangle-types-in #:no-introduce #:only hackett/private/kernel) forall)
+         (unmangle-types-in #:no-introduce #:only hackett/private/prim/type)
          (only-in hackett/private/prim/type
                   True False :: Nil
                   [Unit MkUnit] [Tuple MkTuple] [IO MkIO])

hackett-lib/hackett/private/prim/type-provide.rkt

@@ -8,7 +8,7 @@
          (postfix-in - racket/base)
          (only-in hackett/private/base define-primop type)
          (only-in hackett/private/kernel :)
-         (only-in (unmangle-types-in #:no-introduce (only-types-in hackett/private/kernel))
+         (only-in (unmangle-types-in #:no-introduce #:only hackett/private/kernel)
                   [#%app @%app]))
 
 (provide typed-out)

hackett-lib/hackett/private/type-reqprov.rkt

@@ -16,8 +16,8 @@
 ; using ‘for-type’, and Hackett’s ‘require’ implicitly surrounds its subforms with
 ; ‘unmangle-types-in’, so types are automatically injected into the proper namespace. This gets a bit
 ; trickier, however, when interoperating with Racket modules, which obviously do not have a notion of
-; a type namespace. In this case, users must explicitly use ‘only-types-in’ or ‘unmangle-types-in’
-; with the ‘#:no-introduce’ or ‘#:prefix’ options in order to flatten the two Hackett namespaces into
+; a type namespace. In this case, users must explicitly use ‘unmangle-types-in’, possibly with the
+; ‘#:only’, ‘#:no-introduce’, or ‘#:prefix’ options in order to flatten the two Hackett namespaces into
 ; Racket’s single one.
 
 (require (for-syntax racket/base
@@ -29,77 +29,19 @@
          racket/require
          syntax/parse/define
 
-         (for-syntax hackett/private/typecheck))
+         (for-syntax hackett/private/typecheck
+                     "mangle/mangle-identifier.rkt"
+                     "mangle/mangle-reqprov.rkt"))
 
-(provide for-type only-types-in unmangle-types-in)
+(provide for-type unmangle-types-in)
 
 (begin-for-syntax
-  (define mangled-type-regexp #rx"^#%hackett-type:(.+)$")
-  (define (unmangle-type-name name)
-    (and~> (regexp-match mangled-type-regexp name) second))
+  (define-values [type-id-mangler type-id-unmangler]
+    (make-id-mangler #:prefix "#%hackett-type:"
+                     #:introducer type-namespace-introduce)))
 
-  (struct for-type-transformer ()
-    #:property prop:require-transformer
-    (λ (self)
-      (syntax-parser
-        [(_ require-spec ...)
-         #:do [(define-values [imports sources] (expand-import (syntax/loc this-syntax
-                                                                 (combine-in require-spec ...))))]
-         (values (for/list ([i (in-list imports)])
-                   (struct-copy import i [local-id (type-namespace-introduce (import-local-id i))]))
-                 sources)]))
-    #:property prop:provide-transformer
-    (λ (self)
-      (λ (stx modes)
-        (syntax-parse stx
-          [(_ {~optional {~and #:no-introduce no-introduce?}} provide-spec ...)
-           (for/list ([e (in-list (expand-export (syntax/loc this-syntax
-                                                   (combine-out provide-spec ...))
-                                                 modes))])
-             (struct-copy export e
-                          [local-id (if (attribute no-introduce?)
-                                        (export-local-id e)
-                                        (type-namespace-introduce (export-local-id e)))]
-                          [out-sym (~>> (export-out-sym e)
-                                        symbol->string
-                                        (string-append "#%hackett-type:")
-                                        string->symbol)]))])))))
-
-(define-syntax for-type (for-type-transformer))
-
-(define-syntax only-types-in
-  (make-require-transformer
-   (syntax-parser
-     [(_ require-spec ...)
-      (expand-import
-       #`(matching-identifiers-in #,mangled-type-regexp (combine-in require-spec ...)))])))
+(define-syntax for-type
+  (make-mangling-provide-transformer type-id-mangler))
 
 (define-syntax unmangle-types-in
-  (make-require-transformer
-   (syntax-parser
-     [(_ {~or {~optional {~or {~and #:no-introduce no-introduce?}
-                              {~seq #:prefix prefix:id}}}}
-         require-spec ...)
-      #:do [(define-values [imports sources] (expand-import #'(combine-in require-spec ...)))]
-      (values (map (match-lambda
-                     [(and i (import local-id src-sym src-mod-path mode req-mode orig-mode orig-stx))
-                      (let* ([local-name (symbol->string (syntax-e local-id))]
-                             [unmangled-type-name (unmangle-type-name local-name)])
-                        (if unmangled-type-name
-                            (let* ([prefixed-type-name
-                                    (if (attribute prefix)
-                                        (string-append (symbol->string (syntax-e #'prefix))
-                                                       unmangled-type-name)
-                                        unmangled-type-name)]
-                                   [unmangled-id (datum->syntax local-id
-                                                                (string->symbol prefixed-type-name)
-                                                                local-id
-                                                                local-id)])
-                              (import (if (or (attribute no-introduce?)
-                                              (attribute prefix))
-                                          unmangled-id
-                                          (type-namespace-introduce unmangled-id))
-                                      src-sym src-mod-path mode req-mode orig-mode orig-stx))
-                            i))])
-                   imports)
-              sources)])))
+  (make-unmangling-require-transformer type-id-unmangler))

hackett-lib/info.rkt

@@ -9,4 +9,4 @@
     "syntax-classes-lib"
     "threading-lib"))
 (define build-deps
-  '())
+  '("rackunit-lib"))

hackett-test/hackett/private/test.rkt

@@ -13,7 +13,7 @@
            syntax/parse/define
 
            hackett/private/type-reqprov
-           (prefix-in t: (unmangle-types-in #:no-introduce (only-types-in hackett)))
+           (prefix-in t: (unmangle-types-in #:no-introduce #:only hackett))
            (only-in hackett [#%app @%app] module+ : Unit Tuple)
            (only-in hackett/private/prim IO unsafe-run-io!)
            hackett/private/prim/type-provide