Add module exports

main.scrbl

@@ -12,6 +12,7 @@ languages, new frameworks, and new tools with.
 @include-section[(lib "rebellion/private/entry.scrbl")]
 @include-section[(lib "rebellion/private/generative-token.scrbl")]
 @include-section[(lib "rebellion/private/keyset.scrbl")]
+@include-section[(lib "rebellion/private/module-export.scrbl")]
 @include-section[(lib "rebellion/private/pair.scrbl")]
 @include-section[(lib "rebellion/private/permutation.scrbl")]
 @include-section[(lib "rebellion/private/point.scrbl")]

module-export.rkt

@@ -0,0 +1,2 @@
+#lang reprovide
+rebellion/private/module-export

private/module-export.rkt

@@ -0,0 +1,184 @@
+#lang racket/base
+
+(require racket/contract/base)
+
+(provide
+ (contract-out
+  [export? (-> any/c boolean?)]
+  [export-name (-> export? symbol?)]
+  [export-phase (-> export? natural?)]
+  [export-origin? (-> any/c boolean?)]
+  [export-origin-source-module (-> export-origin? module-path-index?)]
+  [export-origin-phase (-> export-origin? natural?)]
+  [export-origin-phase-shift (-> export-origin? natural?)]
+  [export-origin-imported-alias (-> export-origin? symbol?)]
+  [export-origins (-> export? (set/c export-origin? #:cmp 'equal))]
+  [module-exports (-> module-path? (set/c export? #:cmp 'equal))]
+  [syntax-export? (-> any/c boolean?)]
+  [variable-export? (-> any/c boolean?)]))
+
+(require (for-syntax racket/base
+                     racket/syntax)
+         racket/bool
+         racket/list
+         racket/math
+         racket/set
+         racket/struct
+         rebellion/struct-equal-property
+         rebellion/tuple-type
+         syntax/parse/define)
+
+;@------------------------------------------------------------------------------
+
+(define empty-set (set))
+
+(define-simple-macro
+  (define-tuple-type id:id (field:id ...)
+    (~alt (~optional (~seq #:constructor constructor:id)
+                     #:defaults ([constructor #'id]))
+          (~optional (~seq #:predicate predicate:id)
+                     #:defaults ([predicate
+                                  (format-id #'id "~a?" (syntax-e #'id))]))
+          (~optional (~seq #:property-maker property-maker:expr)
+                     #:defaults ([property-maker
+                                  #'make-default-tuple-properties])))
+    ...)
+  #:do [(define size (length (syntax->list #'(field ...))))]
+  #:with quoted-size #`(quote #,size)
+  #:with (field-accessor ...)
+  (map (λ (field-id)
+         (format-id field-id "~a-~a" (syntax-e #'id) (syntax-e field-id)))
+       (syntax->list #'(field ...)))
+  #:with (field-position ...) (build-list size (λ (n) #`(quote #,n)))
+  (begin
+    (define descriptor
+      (tuple-type-make-implementation
+       (tuple-type 'id quoted-size
+                   #:constructor-name 'constructor
+                   #:predicate-name 'predicate)
+       #:property-maker property-maker))
+    (define constructor (tuple-descriptor-constructor descriptor))
+    (define predicate (tuple-descriptor-predicate descriptor))
+    (define field-accessor
+      (make-tuple-field-accessor descriptor field-position 'field))
+    ...))
+
+(define (make-tuple-equal+hash-property descriptor)
+  (define size (tuple-type-size (tuple-descriptor-type descriptor)))
+  (define accessor (tuple-descriptor-accessor descriptor))
+  (make-equal+hash-property size accessor))
+
+;@------------------------------------------------------------------------------
+
+(define (make-export-properties descriptor)
+  (define equal+hash (make-tuple-equal+hash-property descriptor))
+  (define name (tuple-type-name (tuple-descriptor-type descriptor)))
+  (define accessor (tuple-descriptor-accessor descriptor))
+  (define custom-write
+    (make-constructor-style-printer
+     (λ (_) name)
+     (λ (this)
+       (define export-name (accessor this 0))
+       (define phase (accessor this 1))
+       (define origins (accessor this 2))
+       (append (list export-name)
+               (if (zero? phase)
+                   empty
+                   (list (unquoted-printing-string "#:phase") phase))
+               (if (set-empty? origins)
+                   empty
+                   (list (unquoted-printing-string "#:origins") origins))))))
+  (list (cons prop:equal+hash equal+hash)
+        (cons prop:custom-write custom-write)))
+
+(define (make-origin-properties descriptor)
+  (define equal+hash (make-tuple-equal+hash-property descriptor))
+  (define name (tuple-type-name (tuple-descriptor-type descriptor)))
+  (define accessor (tuple-descriptor-accessor descriptor))
+  (define custom-write
+    (make-constructor-style-printer
+     (λ (_) name)
+     (λ (this)
+       (define source-module (accessor this 0))
+       (define phase (accessor this 1))
+       (define phase-shift (accessor this 2))
+       (define imported-alias (accessor this 3))
+       (append (list source-module)
+               (if (zero? phase)
+                   empty
+                   (list (unquoted-printing-string "#:phase") phase))
+               (if (zero? phase-shift)
+                   empty
+                   (list (unquoted-printing-string "#:phase-shift")
+                         phase-shift))
+               (if (false? imported-alias)
+                   empty
+                   (list (unquoted-printing-string "#:imported-alias")
+                         imported-alias))))))
+  (list (cons prop:equal+hash equal+hash)
+        (cons prop:custom-write custom-write)))
+
+(define-tuple-type variable-export (name phase origins)
+  #:constructor constructor:variable-export
+  #:property-maker make-export-properties)
+
+(define-tuple-type syntax-export (name phase origins)
+  #:constructor constructor:syntax-export
+  #:property-maker make-export-properties)
+
+(define-tuple-type export-origin
+  (source-module phase phase-shift imported-alias)
+  #:constructor constructor:export-origin
+  #:property-maker make-origin-properties)
+
+(define (variable-export name #:phase [phase 0] #:origins [origins empty-set])
+  (constructor:variable-export name phase origins))
+
+(define (syntax-export name #:phase [phase 0] #:origins [origins empty-set])
+  (constructor:syntax-export name phase origins))
+
+(define (export-origin mpi
+                       #:phase [phase 0]
+                       #:phase-shift [shift 0]
+                       #:new-name [new-name #f])
+  (constructor:export-origin mpi phase shift new-name))
+
+(define (export? v) (or (variable-export? v) (syntax-export? v)))
+
+(define (export-case export #:variable f #:syntax g)
+  (if (variable-export? export) (f export) (g export)))
+
+(define (export-name export)
+  (export-case export
+               #:variable variable-export-name
+               #:syntax syntax-export-name))
+
+(define (export-phase export)
+  (export-case export
+               #:variable variable-export-phase
+               #:syntax syntax-export-phase))
+
+(define (export-origins export)
+  (export-case export
+               #:variable variable-export-origins
+               #:syntax syntax-export-origins))
+
+(define (module-exports modpath)
+  (dynamic-require modpath #f)
+  (define-values (exported-variables exported-syntax) (module->exports modpath))
+  (define (make-exports maker exported-lst)
+    (for*/set ([phase-variables (in-list exported-lst)]
+               [phase (in-value (first phase-variables))]
+               [variable-origins (in-list (rest phase-variables))]
+               [variable (in-value (first variable-origins))])
+      (define origins
+        (for/set ([origin (in-list (second variable-origins))])
+          (if (module-path-index? origin)
+              (export-origin origin)
+              (export-origin (first origin)
+                             #:phase (second origin)
+                             #:phase-shift (fourth origin)
+                             #:new-name (third origin)))))
+      (maker variable #:phase phase #:origins origins)))
+  (set-union (make-exports variable-export exported-variables)
+             (make-exports syntax-export exported-syntax)))

private/module-export.scrbl

@@ -0,0 +1,55 @@
+#lang scribble/manual
+
+@(require (for-label racket/base
+                     racket/contract/base
+                     racket/set
+                     rebellion/module-export)
+          rebellion/private/scribble-evaluator-factory
+          scribble/example)
+
+@(define make-evaluator
+   (make-module-sharing-evaluator-factory
+    #:public (list 'rebellion/module-export)
+    #:private (list 'racket/base)))
+
+@title{Module Exports}
+@defmodule[rebellion/module-export]
+
+@defproc[(module-exports [modpath module-path?]) (set/c export? #:cmp 'equal)]{
+ Loads @racket[modpath] and returns its exports. This function is a convenience
+ wrapper around @racket[module->exports].
+
+ @(examples
+   #:eval (make-evaluator) #:once
+   (module-exports 'racket/bool))}
+
+@defproc[(export? [v any/c]) boolean?]{
+ A predicate for module exports returned by @racket[module-exports].}
+
+@defproc[(variable-export? [v any/c]) boolean?]{
+ A predicate for variable exports. Implies @racket[export?].}
+
+@defproc[(syntax-export? [v any/c]) boolean?]{
+ A predicate for syntax exports. Implies @racket[export?].}
+
+@deftogether[[
+ @defproc[(export-name [export export?]) symbol?]
+ @defproc[(export-phase [export export?]) (or/c exact-integer? #f)]
+ @defproc[(export-origins [export export?])
+          (set/c export-origin? #:cmp 'equal)]]]{
+ Accessors for a module export's name, phase, and set of origins (for bindings
+ that were required from other modules and then re-provided).}
+
+@defproc[(export-origin? [v any/c]) boolean?]{
+ A predicate for module export origin information.}
+
+@deftogether[[
+ @defproc[(export-origin-source-module [origin export-origin?])
+          module-path-index?]
+ @defproc[(export-origin-phase [origin export-origin?])
+          (or/c exact-integer? #f)]
+ @defproc[(export-origin-phase-shift [origin export-origin?])
+          (or/c exact-integer? #f)]
+ @defproc[(export-origin-imported-alias [origin export-origin?])
+          (or/c symbol? #f)]]]{
+ Accessors for the various fields of a module export origin information value.}