Skip to content

Commit 5a83945

Browse files
AlexKnauthAlexKnauth
committed
refactor name mangling
to make way for other namespaces
1 parent 9be5c6f commit 5a83945

File tree

13 files changed

+257
-80
lines changed

13 files changed

+257
-80
lines changed

‎hackett-doc/scribble/manual/hackett.rkt

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,7 @@
33
(require hackett/private/type-reqprov
44

55
(for-label hackett
6-
(only-in (unmangle-types-in #:no-introduce (only-types-in hackett)) =>))
6+
(only-in (unmangle-types-in #:no-introduce #:only hackett) =>))
77

88
(for-syntax racket/base
99
racket/contract

‎hackett-lib/hackett/private/adt.rkt

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -19,7 +19,7 @@
1919
(except-in hackett/private/base @%app)
2020
(only-in hackett/private/class class-id derive-instance)
2121
(only-in hackett/private/kernel [λ plain-λ])
22-
(only-in (unmangle-types-in #:no-introduce (only-types-in hackett/private/kernel))
22+
(only-in (unmangle-types-in #:no-introduce #:only hackett/private/kernel)
2323
forall [#%app @%app]))
2424

2525
(provide (for-syntax type-constructor-spec data-constructor-spec

‎hackett-lib/hackett/private/class.rkt

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -12,7 +12,7 @@
1212

1313
(for-syntax hackett/private/infix)
1414
(except-in hackett/private/base @%app)
15-
(only-in (unmangle-types-in #:no-introduce (only-types-in hackett/private/kernel))
15+
(only-in (unmangle-types-in #:no-introduce #:only hackett/private/kernel)
1616
∀ => [#%app @%app]))
1717

1818
(provide (for-syntax class-id)

‎hackett-lib/hackett/private/kernel.rkt

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -54,8 +54,7 @@
5454

5555
(define-syntax-parser #%require/only-types
5656
[(_ require-spec ...)
57-
(type-namespace-introduce
58-
#'(@%require (only-types-in require-spec ...)))])
57+
#'(require (unmangle-types-in #:only require-spec ...))])
5958

6059
(define-syntax-parser λ
6160
[(_ [x:id] e:expr)

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

Lines changed: 68 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,68 @@
1+
#lang racket/base
2+
3+
(provide make-id-mangler
4+
or/unmangler
5+
prefix/unmangler
6+
id-mangler)
7+
8+
(require racket/syntax
9+
"mangle-string.rkt")
10+
11+
;; An IdMangler is an (id-mangler StxIntroducer StringMangler)
12+
(struct id-mangler [introducer string-mangler])
13+
14+
;; An IdUnmangler is a function:
15+
;; Identifier -> [Maybe Identifier]
16+
17+
;; ---
18+
19+
;; A StringMangler is a function:
20+
;; String -> String
21+
22+
;; A StringUnmangler is a function:
23+
;; String -> [Maybe String]
24+
25+
;; A StxIntroducer is a function:
26+
;; Syntax -> Syntax
27+
;; Which adds or removes scopes from the input without
28+
;; changing the datum, source-location, or other properties.
29+
30+
;; ---
31+
32+
;; #:prefix String #:introducer StxIntroducer ->
33+
;; (values IdMangler IdUnmangler)
34+
(define (make-id-mangler #:prefix mangle-prefix #:introducer intro)
35+
(define-values [str-mangler str-unmangler]
36+
(make-string-mangler #:prefix mangle-prefix))
37+
(values (id-mangler intro str-mangler)
38+
(string-unmangler->id-unmangler str-unmangler intro)))
39+
40+
;; IdUnmangler ... -> IdUnmangler
41+
(define ((or/unmangler . id-un*) x)
42+
(for/or ([id-un (in-list id-un*)])
43+
(id-un x)))
44+
45+
;; Symbol IdUnmangler -> IdUnmangler
46+
(define ((prefix/unmangler pre id-un) x)
47+
(define unmangled (id-un x))
48+
(and unmangled
49+
(format-id unmangled "~a~a" pre unmangled
50+
#:source unmangled #:props unmangled)))
51+
52+
53+
;; ---------------------------------------------------------
54+
55+
;; StringUnmangler StxIntroducer -> IdUnmangler
56+
(define ((string-unmangler->id-unmangler str-unmangle intro) x)
57+
(define name (symbol->string (syntax-e x)))
58+
(cond
59+
[(str-unmangle name)
60+
=>
61+
(λ (unmangled-name)
62+
(intro
63+
(datum->syntax x (string->symbol unmangled-name) x x)))]
64+
[else
65+
#false]))
66+
67+
;; ---------------------------------------------------------
68+

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

Lines changed: 34 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,34 @@
1+
#lang racket/base
2+
3+
(provide mangle-export
4+
unmangle-import)
5+
6+
(require racket/match
7+
racket/provide-transform
8+
racket/require-transform
9+
threading
10+
"mangle-identifier.rkt")
11+
12+
;; ---------------------------------------------------------
13+
14+
;; Export StringMangler -> Export
15+
(define (mangle-export e id-mangler*)
16+
(match-define (id-mangler intro mangle-str) id-mangler*)
17+
(struct-copy export e
18+
[local-id (intro (export-local-id e))]
19+
[out-sym (~>> (export-out-sym e)
20+
symbol->string
21+
mangle-str
22+
string->symbol)]))
23+
24+
;; Import IdUnmangler -> [Maybe Import]
25+
(define (unmangle-import i id-unmangler)
26+
(match i
27+
[(import local-id src-sym src-mod-path mode req-mode orig-mode orig-stx)
28+
(define unmangled (id-unmangler local-id))
29+
(and unmangled
30+
(import unmangled
31+
src-sym src-mod-path mode req-mode orig-mode orig-stx))]))
32+
33+
;; ---------------------------------------------------------
34+

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

Lines changed: 91 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,91 @@
1+
#lang racket/base
2+
3+
(provide make-unmangling-require-transformer
4+
make-mangling-provide-transformer)
5+
6+
(require racket/function
7+
racket/list
8+
racket/provide-transform
9+
racket/require-transform
10+
syntax/parse
11+
(only-in syntax/parse [attribute @])
12+
threading
13+
(for-template racket/base)
14+
"mangle-identifier.rkt"
15+
"mangle-import-export.rkt")
16+
17+
;; ---------------------------------------------------------
18+
19+
;; #:mangle-prefix String
20+
;; #:introducer StxIntroducer
21+
;; ->
22+
;; RequireTransformer
23+
(define (make-unmangling-require-transformer #:mangle-prefix mangle-prefix
24+
#:introducer intro)
25+
26+
(define-values [id-mangler id-unmangler]
27+
(make-id-mangler #:prefix mangle-prefix #:introducer intro))
28+
(define-values [id-mangler/no-intro id-unmangler/no-intro]
29+
(make-id-mangler #:prefix mangle-prefix #:introducer identity))
30+
31+
(make-require-transformer
32+
(syntax-parser
33+
[(_ {~alt {~optional {~or {~and #:no-introduce no-introduce?}
34+
{~seq #:prefix prefix:id}}}
35+
{~optional {~and #:only only?}}}
36+
...
37+
require-spec ...)
38+
#:do [(define id-unmangler*
39+
(if (or (@ no-introduce?) (@ prefix))
40+
id-unmangler/no-intro
41+
id-unmangler))
42+
(define id-unmangler**
43+
(if (@ prefix)
44+
(prefix/unmangler (syntax-e (@ prefix)) id-unmangler*)
45+
id-unmangler*))
46+
47+
(define-values [imports sources]
48+
(expand-import #'(combine-in require-spec ...)))]
49+
50+
(values (for*/list ([i (in-list imports)]
51+
[i* (in-value (unmangle-import i id-unmangler**))]
52+
#:when (if (@ only?) i* #t))
53+
(or i* i))
54+
sources)])))
55+
56+
;; #:mangle-prefix String
57+
;; #:introducer StxIntroducer
58+
;; ->
59+
;; ProvideTransformer
60+
(define (make-mangling-provide-transformer #:mangle-prefix mangle-prefix
61+
#:introducer intro)
62+
63+
(define-values [id-mangler id-unmangler]
64+
(make-id-mangler #:prefix mangle-prefix #:introducer intro))
65+
(define-values [id-mangler/no-intro id-unmangler/no-intro]
66+
(make-id-mangler #:prefix mangle-prefix #:introducer identity))
67+
68+
(make-provide-transformer
69+
(λ (stx modes)
70+
(syntax-parse stx
71+
[(_ {~optional {~and #:no-introduce no-introduce?}} provide-spec ...)
72+
#:do [(define id-mangler*
73+
(if (@ no-introduce?)
74+
id-mangler/no-intro
75+
id-mangler))
76+
77+
(define exports
78+
(expand-export (syntax/loc this-syntax
79+
(combine-out provide-spec ...))
80+
modes))]
81+
82+
(for/list ([e (in-list exports)])
83+
(mangle-export e id-mangler*))]))))
84+
85+
;; ---------------------------------------------------------
86+
87+
;; unzip : [Listof [List X Y]] -> (values [Listof X] [Listof Y])
88+
(define (unzip xs/ys)
89+
(values (map first xs/ys)
90+
(map second xs/ys)))
91+

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

Lines changed: 44 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,44 @@
1+
#lang racket/base
2+
3+
(provide make-string-mangler)
4+
5+
(require threading
6+
racket/list)
7+
(module+ test
8+
(require rackunit))
9+
10+
;; A StringMangler is a function:
11+
;; String -> String
12+
13+
;; A StringUnmangler is a function:
14+
;; String -> [Maybe String]
15+
16+
;; #:prefix String -> (values StringMangler StringUnmangler)
17+
(define (make-string-mangler #:prefix mangle-prefix)
18+
(define mangled-regexp
19+
(regexp (string-append "^"
20+
(regexp-quote mangle-prefix)
21+
"(.*)$")))
22+
23+
;; String -> String
24+
(define (mangle-string name)
25+
(string-append mangle-prefix name))
26+
27+
;; String -> [Maybe String]
28+
(define (unmangle-string name)
29+
(and~> (regexp-match mangled-regexp name) second))
30+
31+
(values mangle-string unmangle-string))
32+
33+
;; ---------------------------------------------------------
34+
35+
(module+ test
36+
(define pre "#%hackett-test:")
37+
(define-values [mangle unmangle]
38+
(make-string-mangler #:prefix pre))
39+
40+
(check-equal? (unmangle (mangle "ahotenus")) "ahotenus")
41+
(check-equal? (unmangle (mangle "jatkae")) "jatkae")
42+
(check-equal? (unmangle "ahotenus") #false)
43+
)
44+

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -10,8 +10,8 @@
1010
racket/string))
1111

1212
hackett/private/base
13-
(only-in (unmangle-types-in #:no-introduce (only-types-in hackett/private/kernel)) forall)
14-
(unmangle-types-in #:no-introduce (only-types-in hackett/private/prim/type))
13+
(only-in (unmangle-types-in #:no-introduce #:only hackett/private/kernel) forall)
14+
(unmangle-types-in #:no-introduce #:only hackett/private/prim/type)
1515
(only-in hackett/private/prim/type
1616
True False :: Nil
1717
[Unit MkUnit] [Tuple MkTuple] [IO MkIO])

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -8,7 +8,7 @@
88
(postfix-in - racket/base)
99
(only-in hackett/private/base define-primop type)
1010
(only-in hackett/private/kernel :)
11-
(only-in (unmangle-types-in #:no-introduce (only-types-in hackett/private/kernel))
11+
(only-in (unmangle-types-in #:no-introduce #:only hackett/private/kernel)
1212
[#%app @%app]))
1313

1414
(provide typed-out)

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

Lines changed: 11 additions & 70 deletions
Original file line numberDiff line numberDiff line change
@@ -16,8 +16,8 @@
1616
; using ‘for-type’, and Hackett’s ‘require’ implicitly surrounds its subforms with
1717
; ‘unmangle-types-in’, so types are automatically injected into the proper namespace. This gets a bit
1818
; trickier, however, when interoperating with Racket modules, which obviously do not have a notion of
19-
; a type namespace. In this case, users must explicitly use ‘only-types-in’ or ‘unmangle-types-in’
20-
; with the ‘#:no-introduce’ or ‘#:prefix’ options in order to flatten the two Hackett namespaces into
19+
; a type namespace. In this case, users must explicitly use ‘unmangle-types-in’, possibly with the
20+
; ‘#:only’, ‘#:no-introduce’, or ‘#:prefix’ options in order to flatten the two Hackett namespaces into
2121
; Racket’s single one.
2222

2323
(require (for-syntax racket/base
@@ -29,77 +29,18 @@
2929
racket/require
3030
syntax/parse/define
3131

32-
(for-syntax hackett/private/typecheck))
32+
(for-syntax hackett/private/typecheck
33+
"mangle/mangle-reqprov.rkt"))
3334

34-
(provide for-type only-types-in unmangle-types-in)
35+
(provide for-type unmangle-types-in)
3536

3637
(begin-for-syntax
37-
(define mangled-type-regexp #rx"^#%hackett-type:(.+)$")
38-
(define (unmangle-type-name name)
39-
(and~> (regexp-match mangled-type-regexp name) second))
38+
(define type-prefix "#%hackett-type:"))
4039

41-
(struct for-type-transformer ()
42-
#:property prop:require-transformer
43-
(λ (self)
44-
(syntax-parser
45-
[(_ require-spec ...)
46-
#:do [(define-values [imports sources] (expand-import (syntax/loc this-syntax
47-
(combine-in require-spec ...))))]
48-
(values (for/list ([i (in-list imports)])
49-
(struct-copy import i [local-id (type-namespace-introduce (import-local-id i))]))
50-
sources)]))
51-
#:property prop:provide-transformer
52-
(λ (self)
53-
(λ (stx modes)
54-
(syntax-parse stx
55-
[(_ {~optional {~and #:no-introduce no-introduce?}} provide-spec ...)
56-
(for/list ([e (in-list (expand-export (syntax/loc this-syntax
57-
(combine-out provide-spec ...))
58-
modes))])
59-
(struct-copy export e
60-
[local-id (if (attribute no-introduce?)
61-
(export-local-id e)
62-
(type-namespace-introduce (export-local-id e)))]
63-
[out-sym (~>> (export-out-sym e)
64-
symbol->string
65-
(string-append "#%hackett-type:")
66-
string->symbol)]))])))))
67-
68-
(define-syntax for-type (for-type-transformer))
69-
70-
(define-syntax only-types-in
71-
(make-require-transformer
72-
(syntax-parser
73-
[(_ require-spec ...)
74-
(expand-import
75-
#`(matching-identifiers-in #,mangled-type-regexp (combine-in require-spec ...)))])))
40+
(define-syntax for-type
41+
(make-mangling-provide-transformer #:mangle-prefix type-prefix
42+
#:introducer type-namespace-introduce))
7643

7744
(define-syntax unmangle-types-in
78-
(make-require-transformer
79-
(syntax-parser
80-
[(_ {~or {~optional {~or {~and #:no-introduce no-introduce?}
81-
{~seq #:prefix prefix:id}}}}
82-
require-spec ...)
83-
#:do [(define-values [imports sources] (expand-import #'(combine-in require-spec ...)))]
84-
(values (map (match-lambda
85-
[(and i (import local-id src-sym src-mod-path mode req-mode orig-mode orig-stx))
86-
(let* ([local-name (symbol->string (syntax-e local-id))]
87-
[unmangled-type-name (unmangle-type-name local-name)])
88-
(if unmangled-type-name
89-
(let* ([prefixed-type-name
90-
(if (attribute prefix)
91-
(string-append (symbol->string (syntax-e #'prefix))
92-
unmangled-type-name)
93-
unmangled-type-name)]
94-
[unmangled-id (datum->syntax local-id
95-
(string->symbol prefixed-type-name)
96-
local-id
97-
local-id)])
98-
(import (if (or (attribute no-introduce?)
99-
(attribute prefix))
100-
unmangled-id
101-
(type-namespace-introduce unmangled-id))
102-
src-sym src-mod-path mode req-mode orig-mode orig-stx))
103-
i))])
104-
imports)
105-
sources)])))
45+
(make-unmangling-require-transformer #:mangle-prefix type-prefix
46+
#:introducer type-namespace-introduce))

0 commit comments

Comments
 (0)