diff --git a/hackett-doc/scribble/manual/hackett.rkt b/hackett-doc/scribble/manual/hackett.rkt index 7f8efe8..0d4c1f7 100644 --- a/hackett-doc/scribble/manual/hackett.rkt +++ b/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 diff --git a/hackett-lib/hackett/private/adt.rkt b/hackett-lib/hackett/private/adt.rkt index 77c4ea6..66bc03c 100644 --- a/hackett-lib/hackett/private/adt.rkt +++ b/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 diff --git a/hackett-lib/hackett/private/class.rkt b/hackett-lib/hackett/private/class.rkt index 2608d5f..66db914 100644 --- a/hackett-lib/hackett/private/class.rkt +++ b/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) diff --git a/hackett-lib/hackett/private/kernel.rkt b/hackett-lib/hackett/private/kernel.rkt index c81ee58..ff80171 100644 --- a/hackett-lib/hackett/private/kernel.rkt +++ b/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) diff --git a/hackett-lib/hackett/private/mangle/mangle-identifier.rkt b/hackett-lib/hackett/private/mangle/mangle-identifier.rkt new file mode 100644 index 0000000..4838fc7 --- /dev/null +++ b/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])) + +;; --------------------------------------------------------- diff --git a/hackett-lib/hackett/private/mangle/mangle-import-export.rkt b/hackett-lib/hackett/private/mangle/mangle-import-export.rkt new file mode 100644 index 0000000..32e621d --- /dev/null +++ b/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))])) + +;; --------------------------------------------------------- + diff --git a/hackett-lib/hackett/private/mangle/mangle-reqprov.rkt b/hackett-lib/hackett/private/mangle/mangle-reqprov.rkt new file mode 100644 index 0000000..c3ea440 --- /dev/null +++ b/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*))])))) diff --git a/hackett-lib/hackett/private/mangle/mangle-string.rkt b/hackett-lib/hackett/private/mangle/mangle-string.rkt new file mode 100644 index 0000000..97d9aa3 --- /dev/null +++ b/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) + ) + diff --git a/hackett-lib/hackett/private/prim/op.rkt b/hackett-lib/hackett/private/prim/op.rkt index 7d8e7a5..f718cf7 100644 --- a/hackett-lib/hackett/private/prim/op.rkt +++ b/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]) diff --git a/hackett-lib/hackett/private/prim/type-provide.rkt b/hackett-lib/hackett/private/prim/type-provide.rkt index eb573fe..1064d00 100644 --- a/hackett-lib/hackett/private/prim/type-provide.rkt +++ b/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) diff --git a/hackett-lib/hackett/private/type-reqprov.rkt b/hackett-lib/hackett/private/type-reqprov.rkt index 3e22375..6295e6d 100644 --- a/hackett-lib/hackett/private/type-reqprov.rkt +++ b/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)) diff --git a/hackett-lib/info.rkt b/hackett-lib/info.rkt index e1fc9f0..a13c981 100644 --- a/hackett-lib/info.rkt +++ b/hackett-lib/info.rkt @@ -9,4 +9,4 @@ "syntax-classes-lib" "threading-lib")) (define build-deps - '()) + '("rackunit-lib")) diff --git a/hackett-test/hackett/private/test.rkt b/hackett-test/hackett/private/test.rkt index 410f57a..3708ddb 100644 --- a/hackett-test/hackett/private/test.rkt +++ b/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