Scheme - Portable module model

Author

Portable module model

Jan Skibinski

2006-03-05, 9:57 pm

Summary
-------
This is a presentation of a small yet portable module model,
tentatively named 'my-module', which relies on a host macro support,
but ignores its existing module system, if any. It has been
successfully used with two very diverse Scheme implementations: Chez
Scheme and Mzscheme.
Modules produced by this model are first class: they can be
stored in data structures, passed to functions as arguments,
evaluated on demand, queried for meta information and -- most
importantly -- used as an export/import facility.
Compared to somewhat similar Lexmod [3], this model extends the
import/export mechanism to handle not only regular variables but also
the syntax -- although indirectly via transformer procedures, which
act
as proxies for syntax. Transformers, as opposed to regular variables,
must be self-contained; that is, references to modularized procedures
within their bodies must be fully qualified, as in: (from module-set
subset).
By design, the modules are expanded in normal environment of the top
level. However, their individual exportable definitions can be
imported
to the transformer environment via 'for-syntax or 'for-dual-use forms
-- if the host platform supports such duality of environments. Other
than that, the model does not introduce or use any kind of syntactic
tower.
This model clearly separates the definitions from the run block of
expressions. Consequently, a module can be either 'visited' to access
its variables or meta-data, or 'invoked' via the explicit (run module)
command to execute its block of expressions.
In this unortodox view of visitation vs. invocation, the visitation
mode is the normal operational mode -- irrespectively of the visitor's
intentions; the module does not care whether its exported definitions
will be used for expansion or for runtime. In contrary, the invocation
mode converts a library-like module into an application, with possible
side effects.
There are no restrictions on what runtime blocks are supposed to do.
Some modules may wish to return a list of formal signatures - possibly
enhanced with comments, some may provide commented tests, some may
return results from a specialized, possibly time-consuming,
application.
The run block is allowed to use qualified variables from modules other

than those specified in the require clause since this has no impact
on the visitation mode of the module.

Contents:
1. Overview
2. Input
3. Output
4. Error checking
5. Repository of Modular Interfaces
6. A simple example of syntax handling
7. An example of elaborate transformer

1.Overview
----------
In this incarnation, a module descriptor expands to a
top-level procedure definition, which has two distinct regions:
a block of definitions and a block of expressions designed to run
only on demand, via the run command: (run module).

The block of definitions includes links to imported
definitions in either one of the three forms:

(define variable (from other-module variable))
(define renamed-variable (from other-module original-variable))
(define-syntax* item (from other-module transformer-procedure))

and locally defined variables and syntax.
Any regular variable -- and that includes transformer procedures
-- is exportable, while the syntax is not. This restriction is not
as severe as it seems since in this model the exportable transformer
procedures work as the proxies for syntax.
Such first-class transformers can be shared among modules, or
imported to the top level or other modules in order to form actual
syntax definitions, as in

(define-syntax* item (from some-module transformer-procedure))

or used as runtime macros for pattern matching or other such tasks,
as described in [6].
During the module creation a static list of exportable
bindings is compiled -- based on the export declarations -- but
not before the import/export/local consistency checks have been
successfully performed. Other modules will have indirect access
the module exportable variables via this list of bindings.
The system also assures that the module imports are the legal
subsets of interfaces publicly declared within the global Repository
of Modular Interfaces, which is the place where exports of newly
created modules are being registered.

Aside from this basic access functionality, a module responds
to several introspective requests. Altogether, here is my-module
interface:

(interface <module> ) =3D=3D> meta: all provided symbols
(module-name <module> ) =3D=3D> meta: the name of the <module>
(providers <module> ) =3D=3D> meta: direct suppliers of symbols
(providers-tree <module> ) =3D=3D> meta: tree of suppliers of symbols
(from <module> s1) =3D=3D> import qualified variable s1
(run <module> ) =3D=3D> execute a block of expressions

2. Input
---------
Macro my-module accepts a text of this form:

(my-module module-name
(provide: export ...) ;; mandatory clause
(require: (other-module imp-item ...) ...) ;; optional clause
definition ...
(run:
expression ...
) ;; optional clause
)
where
+ export =3D=3D> a symbol
+ other-module =3D=3D> a symbol
+ imp-item =3D=3D> either a symbol or a symbol pair (original
renamed)
+ definition =3D=3D> a procedure definition or a syntax definition
+ expression =3D=3D> an expression
+ (provide: require: run:) =3D=3D> literal symbols

The provide clause must exist, although it may be empty -- as in
(provide: ). Both, the require and the run clauses may be either empty
or entirely omitted, in which case the former defaults to the empty
set
and the latter defaults to a set with the single expression #t.
The positions of the clauses are fixed; that is, the error will be
signaled when the structure of input data is not as declared above.
(See the section on error checking below.)
The keywords (provide: require: run:) used here are provisional
and marked with colons in order to avoid confusion with the keywords
(provide require) used by the host Mzscheme. We could have used
(import
export) keywords instead, but they would in turn lead to confusion
on the Chez Scheme platform.

3. Output
---------
If the input to the macro <my-module> is correctly specified
then it will be expanded into a definition of a procedure <name>
representing the module <name> and an expression performing
registration of the module interface:

(begin
(define (name first . rest)
import-definition ...
definition ...
(module-dispatcher
'name
first
rest
'modules
(list (list 'export export) ...)
(lambda () #t expression ...)
))

(register-interface! 'name (list export ...))
)

4. Error checking
-----------------
If it were not for testing for errors the macro <my-module>
would be short and sweet. However, my objective was to test as
much as possible during the macro expansion in order to avoid
unpleasant errors that would otherwise appear either at wrong
context during the expansion itself or later at runtime.
For this reason this script is several hundred lines long --
although a significant percentage of these line is due to pretty
formatting and documentation.

The macro <my-module> signals informative errors when the input
is lexically incorrect, that is when:
1. Missing symbolic name for the module
2. Unexpected items between module name and the provide clause
3. Unexpected items between provide and require clauses
4. Unexpected items after the run clause
5. Missing mandatory provide clause
6. Non-symbols in the provide clause
7. Duplicate items within the provide clause
8. Non-lists within the require clause
9. Non-symbols in place of modules within the require clause
10. Some import items within the require clause
are not symbols or symbol pairs
11. Duplicate modules within the require clause
12. Module references self within the require clause
13. A definition within the run block
14. An expression in the definition context

or when the input is internally inconsistent:
15. Local items contain duplicate names
16. Imported items contain duplicate names even after renaming
17. Some items in sets of local and imported names overlap
18. Available bindings do not support some of the exports
19. Input is otherwise malformed

or when the specified imports do not match the registered interfaces
of requested modules:
20. The Repository of Modular Interfaces does not exist
at the top level or is not accessible
21. Some requested modules are not registered
22. Some imports are incompatible with registered interfaces

5. Repository of Modular Interfaces
------------------------------------
No attempt is made to keep modules registered in some central
repository. The modules are just top-level regular procedures,
although they have some extra semantics. Modules interplay at
runtime -- as regular procedures do. If a required module
'module-foo' is not available when needed by a calling module the
system will signal a 'variable module-foo not bound' error.
However, when a module is being defined, the 'my-module' macro
tests the compatibility of required imports with interfaces of
providing modules. This feature increases user-friendliness of
<my-module> framework. The interfaces are managed by a top-level
Repository of Modular Interfaces. The interfaces can be prepared in
advance - even if the corresponding module definitions are not
available yet. With this feature any new module can be defined and
tested against promises that some providers will eventually deliver
required functionality.

6. A simple example of syntax handling
--------------------------------------
This little module module-kons defines and exports two definitions
only,
one of which happens to be a transformer procedure, kons and
another a variable, dummy.

(my-module module-kons
(provide:
kons ;; kons :: a -> Stream a -> Stream a
dummy ;; dummy :: Integer
)

;; Cons-ing a strict head with a delayed tail
(define kons
(syntax-rules ()
((kons a b) (cons a (delay b)))))

(define dummy 13)
[run:
(show
("Blah" (* 10 dummy))
)
]
)
;; (interface module-kons) =3D=3D> (kons dummy)
;; (run module-kons) =3D=3D> ("Blah" (* 10 dummy) =3D=3D> 130)
;; (from module-kons dummy) =3D=3D> 13

The kons definition can be then imported to the library module
module-stream and converted to macro via define-syntax*. Many
definitions
of module-stream rely on properly functioning macro kons. The kons can
be
also imported to a user module or to the top level and converted to
syntax to be used at will:

(define-syntax* kons (from module-kons kons)) ;; top level

(kons 1 2) =3D=3D> (1 . #<struct:promise> )

The define-syntax* binds an imported transformer procedure to a
syntax name while taking care of negotiation between the transformer
environment and the normal environment. (The environment separation
is particular to Mzscheme, while in Chez there is only one
environment.)
The syntax kons could have been explicitely defined in the
module-stream, but then it would not be exportable. On the other
hand, the transformer kons could have been defined within the
module-stream and made exportable, but it could not have been
converted
to syntax within module-stream, because of the chicken and egg
problem.
For this reason we use here the auxiliary module-kons. This is
nothing new: both Mzscheme and Chez must rely on such technique in
one way or another.

Here is a skeleton of the module-stream:

(my-module module-stream
(provide:
head ;; Stream a -> a
tail ;; Stream a -> Stream a
.... ;; 30 or so other exports
)
(require:
(<kons>
(dummy not-so-dummy)))

;; This is how the syntax is handled now. The require clause
;; might have specified kons, but such info is unsused for now
;; unless we wish to re-export the kons transformer procedure.
;; Instead the explicit import is used, when dealing with
;; syntax.

(define-syntax* kons (from module-stream kons))

;; A bunch of local definitions
(define (head xs) (car xs))
(define (tail xs) (force (cdr xs)))
....

;; and a definition that uses imported dummy,
;; renamed as not-so-dummy. Nothing special
;; is done here, since 'not-so-dummy definition
;; will be inserted in front of any other
;; definition.
(define y (* 10 not-so-dummy))

;; The run clause has access to everything above:
;; local definitions, imported definitions and syntax kons
(run:
y
)

)

7. An example of elaborate transformer
-------------------------------------
To show that the my-module mechanism is not just a toy, below is a
working example of a module that defines, but not uses, the
transformer
'list-of' - a powerful list comprehension construct. See the comment
attached to the transformer inside the module.
Module-comprehension exports not only the transformer 'list-of' but
also all modular procedures used by the transformer. The latter
exports
are not strictly necessary, but helpful in localizing references
within
the transformer to this one particular module.
The direct providers of this module are module-compose and
module-set,
which can be verified by inspecting the require clause, or by
accessing
such meta-data during runtime:

(providers module-comprehension) =3D=3D> (module-compose module-set)

These two direct providers depend, in turn, on other providers -- as
shown by another meta-data information:

(providers-tree module-comprehension) =3D=3D>
((module-compose
(module-hof))
(module-set
(module-flip)
(module-hof)))

These dependencies are, however, made invisible within the body of the
transformer by re-exporting those procedures that are needed by the
transformer. Now look inside its body and then jump to end of the
module-comprehension for the final discussion.

(my-module module-comprehension
(provide:
list-of ;; transformer list-of
=E2=97=8B ;; re-exported from module-compose
subset ;; re-exported from module-set
=E2=8A=97 ;; re-exported from module-set
)
(require:
(module-compose =E2=97=8B) ;; forward composition
(module-set
subset ;; Subset generator
=E2=8A=97 ;; Cartesian product of two sets
))

;; List comprehension
;; (list-of expression | (=E2=88=88 x xs) ...)
;; (list-of expression | (=E2=88=88 x xs) ... where constraint)
;;
;; Generate list based on 'expression containing variables x ...
;; such that each variable x is a member of its domain xs
;; and the set of variables x ... is a subject to an optional
;; constraint that follows the 'where' keyword.
;; Example:
;; (list-of (* z z) =C2=A6 (=E2=88=88 z '(1 2 3 4 5 6)) where (< (* z z) =
20))
;; =3D=3D> (1 4 9 16)
(define (list-of stx)
(syntax-case stx (=C2=A6 =E2=88=88 where)

[ ;; 1. One variable, no constraint
(list-of expr =C2=A6 (=E2=88=88 x xs))
(syntax
((from module-comprehension subset)
(=CE=BB(x) expr) ;; generator
(=CE=BB(x) #t) ;; no constraint, pass through
xs)) ;; superset

][ ;; 2. One variable, with constraint
(list-of expr =C2=A6 (=E2=88=88 x xs) where formula)
(syntax
((from module-comprehension subset)
(=CE=BB(x) expr) ;; generator
(=CE=BB(x) formula) ;; constraint predicate
xs)) ;; superset

][ ;; 3. Two or more variables, no constraint
(list-of expr =C2=A6 (=E2=88=88 x xs) ... (=E2=88=88 y ys))
(syntax
((from module-comprehension subset)
((curry 2 apply) (=CE=BB(x ... y) expr))
(=CE=BB formals #t)
(((from module-comprehension =E2=97=8B)
((curry 2
(from module-comprehension =E2=8A=97)) xs)
...) ys)))

][ ;; 4. Two or more variables, with constraint
(list-of expr =C2=A6 (=E2=88=88 x xs) ... (=E2=88=88 y ys) where formu=
la)
(syntax
((from module-comprehension subset)
((curry 2 apply) (=CE=BB(x ... y) expr))
((curry 2 apply) (=CE=BB(x ... y) formula))
(((from module-comprehension =E2=97=8B)
((curry 2
(from module-comprehension =E2=8A=97)) xs)
...) ys)))
])))

Perhaps, some explanation is warranted what is this little magic in
the clauses 3 and 4 above:
(((from module-comprehension =E2=97=8B)
((curry 2 (from module-comprehension =E2=8A=97)) xs) ...) ys)
In the case of four source sets: xs, bs, cs, ys all it does is a
forward
composition of partially applied curried operator =E2=8A=97 -- effectively
forming a cartesian product of four sets:
(=E2=8A=97 xs (=E2=8A=97 bs (=E2=8A=97 cs ys)))
The operator =E2=8A=97 has been defined in module-set as a binary operato=
r,
unlike the Scheme operator * that can accept any number of arguments.
For this reason the above magic is needed to formulate the desired
effect within the confines of the syntax-case pattern matching.
As you can see, the transformer references the module within which it
is defined. But there is another piece of foreign information embedded
in its body -- the reference to the macro 'curry'. I use 'curry' quite
often, so I have exported it to the top level, but this is not
necessary; it is enough to acquire both 'curry' and the 'list-of' in
the context they are to be used, for example of some test module.

Here is how you could use the transformer 'list-of':

(define-syntax* curry (from module-curry curry))
(define-syntax* list-of (from module-comprehension list-of))

(list-of (+ x y) =C2=A6 (=E2=88=88 x '(1 2 3 4 5 6)) (=E2=88=88 y '(10 10=
0)))
=3D=3D> (11 101 12 102 13 103 14 104 15 105 16 106)

References:
----------

1. Andre van Tonder, 'Simple macros and simple modules' (SRFI-72
proposal
and implementation as well as his SRFI-83 implementation)

2. The implementation 'lib342' that supports typing concepts
described in the paper 'A Type Notation for Scheme by Gary T.
Leavens, Curtis Clifton, and Brian Dorn' provides some sort of
translation of MzScheme modules into Chez Scheme.

3. Lexmod by Taylor Campbell .

4. SRFI-83 Library proposal for R6RS

5. An alternative to SRFI-83 proposal by Taylor Campbell.
=09
6. Run-time macros, a message to comp.lang.scheme by Oleg Kiselov

andreuri2000@yahoo.com

2006-03-06, 7:00 pm

This looks very interesting. Do you have a reference implementation
available?

Cheers
Andre

Jan Skibinski

2006-03-06, 7:00 pm

;;file: "my-module.scm"
;; require: scheme-implementation-type to be defined. See
begin-for-dual-use below.
;; author: Jan Skibinski
;; email: [: base-64 translate-string: "asO5dz16cWndz16YGfbh07F2Pft"
to: ascii]
;; copyright: at the bottom of the file
;; version: 0.1
;; date: 2006.03.06
;; description: in a separate message
;; note: access to Repository of Modular Interfaces is temporarily
disabled until I finish it up.
;;
;; Macro: (begin-for-dual-use definition defs ...)
;; It expands accordingly to "scheme-implementation-type".
;; In Mzscheme two sets of definitions are created: one
;; for the normal use and one for syntax.
;; In Chez Scheme only normal definitions are needed.
;;
;; Make sure that scheme-implementation-type
;; has been defined both for syntax and for
;; normal use in initialization script .mzschemerc:
;; (define (scheme-implementation-type) 'mzscheme)
;; Similarly, Chez needs to evaluate this from its .schemerc:
;; (define (scheme-implementation-type) 'chez)
(define-syntax (begin-for-dual-use stx)
(syntax-case stx ()
[
(begin-for-dual-use definition defs ...)
(eq? (scheme-implementation-type) 'mzscheme)
(syntax
(begin
(begin-for-syntax
definition defs ...
)
definition defs ...))
][
(begin-for-dual-use definition defs ...)
(syntax (begin definition defs ...))
]))

;; Copy of few items that exist elsewhere but cannot
;; be imported yet, until my-module is defined.
(begin-for-dual-use
;; Function (any->string any)
;; Converts any object to a string.
;; This function is used for error
;; reporting in both phases: expansion
;; and runtime.
(define (any->string u)
(define (intersperse delimeter xs)
(cond
((<= (length xs) 1) xs)
(else (cons (car xs)
(cons delimeter (intersperse delimeter (cdr xs)))))))
(cond
((string? u) u)
((symbol? u) (symbol->string u))
((number? u) (number->string u))
((boolean? u) (if #t "true" "false"))
((char? u) (string u))
;((object? u) (: u as-string u))
((list? u) (string-append "("
(apply string-append
(intersperse " "
(map any->string u))) ")"))
;; default handler of objects defined by "define-type"
((pair? u) (string-append "("
(any->string (car u))
" . "
(any->string (cdr u))
")"))

((vector? u) (string-append "#"
(any->string (vector->list u))))
((procedure? u) "#<procedure>")
((port? u) "#<port>")
(else (error u "Unsupported any->string conversion"))
))

(define (filter pred? lst)
(define (filter-aux pred? lst result)
(cond
((null? lst) (reverse result))
((pred? (car lst)) (filter-aux pred? (cdr lst)
(cons (car lst) result)))
(else (filter-aux pred? (cdr lst) result))))
(filter-aux pred? lst '()))

(define (every pred? list)
(or (null? list)
(and (pair? list)
(pred? (car list))
(every pred? (cdr list)))))

(define (some pred? list)
(and (pair? list)
(or (pred? (car list))
(some pred? (cdr list)))))

)

;; Recursive CPS macro subroutine: extract-ids
;; Extract a list of ids from a list of definitions, syntax definitions

;; and expressions. The ids are being extracted only from the "define"
;; and "define*" forms only. All other forms are being ignored.
;;
;; The pattern variables <jump-to> and <jump-args> are here to tell
;; this macro where to jump back (and with what args) when finished.
(define-syntax (extract-ids stx)
(define (defining-keyword? stx-x)
(and
(identifier? stx-x)
(or
(free-identifier=? stx-x (syntax define))
(free-identifier=? stx-x (syntax define*))
)))

(syntax-case stx ()
[ ;; Start here -> specify the empty result list
;; as the last item
(extract-ids jump-to jump-args input)
(syntax (extract-ids jump-to jump-args input ()))

][ ;; Job done, jump to the <jump-to> with preserved
;; <jump-args> and the <result>
(extract-ids jump-to jump-args () result )
(syntax (jump-to jump-args result))

][ ;; 1. head is (defining (id arg ...) body ...),
;; accumulate id and iterate
(extract-ids jump-to jump-args
((defining (id arg ...) body ...) rest ...) (result ...))
(defining-keyword? (syntax defining))
(syntax (extract-ids jump-to jump-args
(rest ...) (result ... id)))

][ ;; 2. head is (defining (id arg ... . options) body ...),
;; accumulate id and iterate
(extract-ids jump-to jump-args
((defining (id arg ... . options) body ...) rest ...) (result ...))
(defining-keyword? (syntax defining))
(syntax (extract-ids jump-to jump-args
(rest ...) (result ... id)))

][ ;; 3. head is (defining id body), accumulate
;; id and iterate
(extract-ids jump-to jump-args
((defining id body) rest ...) (result ...))
(defining-keyword? (syntax defining))
(syntax (extract-ids jump-to jump-args
(rest ...) (result ... id)))

][ ;; 4. head is none of the above
;; - skip it and iterate
(extract-ids jump-to jump-args
(otherwise rest ...) (result ...))
(syntax (extract-ids jump-to jump-args
(rest ...) (result ...)))
]))

;; Macro: my-module, the prelude to my-module-kernel macro
;;
;; Input:
;; (my-module name
;; (provide: export ...) ;; Exactly 1 clause
;; (require: (other-mod-name item ...) ...) ;; 1 or 0 clauses
;; definition ...
;; (run: expression ...) ... ;; 1 or 0 clauses
;; )
;; where
;; + export ==> a symbol
;; + other-mod-name ==> a symbol
;; + item ==> either a symbol or a symbol pair (original
renamed)
;; + definition ==> a local definition or an expression at the tail
;; + expression ==> an expression to be evaluated on request
;; + (provide: require: run:) ==> literal symbols
;;
;; Output: Generated procedure <name>. Macro also registers
;; the public interface of the module in the
;; repository-of-modular-interfaces.
;;
;; The public interface to the generated procedure is described in the
;; introduction and implemented at the bottom of this file.
;;
;; The macro expander does the following:
;; + Tests for variety of errors and signals the failures.
;; If the tests succeed then:
;; + Generates and compiles the procedure <name>, which represents
;; the module.
;; + Registers the module interface
;;
;; The macro signals syntax errors in variety of circumstances,
;; as described in the header of this document.
;;
;; Macro my-module is just a front end to the main macro
"my-module-kernel".
;; The control will be passed to the latter only after a succession
;; of pattern tests have been satisfied, otherwise a usage error will
;; be produced.

(define-syntax (my-module stx)

(define definition?
(lambda(x)
(and
(list? x)
(symbol? (car x))
(or
(eqv? (car x) 'define)
(eqv? (car x) 'define*)
(eqv? (car x) 'define-syntax)
(eqv? (car x) 'define-syntax*)
))))

(define clause?
(lambda(keyword)
(lambda(x)
(and
(list? x)
(eqv? (car x) keyword)))))

(define (import-item? x)
(or
(symbol? x)
(and
(pair? x)
(= (length x) 2)
(symbol? (car x))
(symbol? (cadr x)))))

; A list of duplicates found in list xs
;;(duplicates '(1 3 1 2 5 2))
(define (duplicates xs)
(define (collect xs zs)
(cond
((null? xs) (reverse zs))
((member (car xs) zs) (collect (cdr xs) zs))
((member (car xs) (cdr xs))
(collect (cdr xs) (cons (car xs) zs)))
(else (collect (cdr xs) zs))))
(collect xs '()))

(define (duplicate-items? xs)
(pair? (duplicates xs)))

(syntax-case stx (provide: require: run:)
;; The pattern of the very first request to this macro
;; will carry no label, and therefore the request will
;; percolate down to the very bottom, where it
;; will be redirected here again, but this time with
;; the pattern having the label "test-name".
;; From then on the real tests will start from here.

[ ;; 2. test-name clause
(my-module "test-name" name anything ...)
(cond
[
(identifier? (syntax name))
(syntax
(my-module "test-provide" name anything ...))
][
else
(syntax
(my-module "error"
"Missing symbolic name for the module.\n"))
])

][ ;; 3. test-provide clause
(my-module "test-provide" name (provide: p ...) anything ...)
(cond
[
(not (every symbol?
(syntax-object->datum
(syntax (p ...)))))
(syntax
(my-module "error"
"Some exports in provide clause are not symbols"))
][
(duplicate-items?
(syntax-object->datum
(syntax (p ...))))
(syntax
(my-module "error"
"Duplicate items within the provide clause"))
][
else
(syntax
(my-module "test-require" name (provide: p ...) anything ...))
])

][ ;; 3a.
(my-module "test-provide" name anything ...)
(cond
[
(some (clause? 'provide:)
(syntax-object->datum
(syntax (anything ...))))
(syntax
(my-module "error"
"Unexpected items between module name and the provide clause\n"))
][
else
(syntax
(my-module "error"
"Missing mandatory (provide: p ...) clause\n"))
])

][ ;; 4. test-require clause
(my-module "test-require" name
(provide: p ...) (require: r ...) anything ...)
(let* ( (module-name (syntax-object->datum (syntax name)))
(imports (syntax-object->datum
(syntax (r ...))))
(modules (map car imports)))

(cond
[
(null? imports)
(syntax
(my-module "test-run" name
(provide: p ...) (require: r ...) anything ...))
][
(not (every pair? imports))
(syntax
(my-module "error"
"Some import specifications are not lists"))
][
(not (every symbol? modules))
(syntax
(my-module "error"
"Some required modules are not symbols"))
][
(duplicate-items? modules)
(syntax
(my-module "error"
"Duplicate modules within the require clause"))
][
(memq module-name modules)
(syntax
(my-module "error"
"Module references self within require clause"))
][
(not (every import-item?
(apply append (map cdr imports))))
(syntax
(my-module "error"
"Some import items are not symbols or symbol pairs"))
][
else
(syntax
(my-module "test-run" name
(provide: p ...) (require: r ...) anything ...))
]))

][ ;; 4a.
(my-module "test-require" name (provide: p ...) anything ...)
(cond
[
(not (some (clause? 'require:)
(syntax-object->datum
(syntax (anything ...)))))
(syntax
(my-module "test-run" name
(provide: p ...) (require: ) anything ...))
][
else
(syntax
(my-module "error"
"Unexpected items between provide and require clauses"))
])

][ ;; 5. test-run clause
(my-module "test-run" name
(provide: p ...) (require: r ...) anything ... (run: expr ...))
(cond
[
(not (some definition?
(syntax-object->datum
(syntax (expr ...)))))
(syntax
(my-module "test-def" name
(provide: p ...) (require: r ...) (anything ...)
(run: expr ...)))
][
else
(syntax (my-module "error"
"A definition within the run clause"))
])

][ ;; 5a.
(my-module "test-run" name
(provide: p ...) (require: r ...) anything ...)
(syntax
(my-module "test-def" name
(provide: p ...) (require: r ...) (anything ...) (run: )))

][ ;; 6. test-def clause. On success jump to macro "my-module-kernel"
(my-module "test-def" name
(provide: p ...) (require: r ...) (anything ...) (run: x ...))
(syntax '(anything ...))

(cond
[
(some (clause? 'run:)
(syntax-object->datum
(syntax (anything ...))))
(syntax (my-module "error"
"Unexpected items after the run clause"))

][
(every definition?
(syntax-object->datum
(syntax (anything ...))))

(syntax
(my-module-kernel name unification
(provide: p ...) (require: r ...) anything ... (run: x ...)))
][
else
(syntax (my-module "error"
"An expression in a definition context"))
])

][ ;; 7. Error clause
(my-module "error" message ...)
(syntax (error 'my-module (any->string (list
"\n"
message ...
"\nUsage pattern::\n"
"\n"
"(my-module name\n"
" (provide: export ...) ;; mandatory\n"
" (require: (import-module import-item more ...) ...) ;; optional\n"

" definition ...\n"
" (run: expression ...) ;; optional\n"
")\n"
"where:\n"
" name -> a symbol (not quoted)\n"
" export -> a symbol\n"
" import-module -> a symbol\n"
" import-item, more -> a symbol or a pair of symbols (old new)\n"
" definition -> one of (define define*)\n"
" my-module, provide:, require:, run: -> literals\n"
))))
][ ;; 1. This is where everything starts.
;; Jump to the top with the "test-name" label.
(my-module anything ...)
(syntax (my-module "test-name" anything ...))

]))

;; Macro: my-module-kernel, the continuation of my-module macro.
;; At this point the structure of the input
;; should have been thoroughly validated.
;; Do not invoke it directly, but always via "my-module".
(define-syntax (my-module-kernel stx)

(define (fold-left f init list)
(if (null? list)
init
(fold-left f (f init (car list)) (cdr list))))

(define (subset? xs ys)
(every (lambda(x)(member x ys)) xs))

(define (intersect? xs ys)
(not (null? (intersection xs ys))))

;;A list with duplicates removed.
;; (nub '(1 3 1 2 5 2)) ==> (1 3 2 5)
(define (nub xs)
(define (collect xs zs)
(cond
((null? xs) (reverse zs))
((member (car xs) zs) (collect (cdr xs) zs))
(else (collect (cdr xs) (cons (car xs) zs)))))
(collect xs '()))

; A list of duplicates found in list xs
;;(duplicates '(1 3 1 2 5 2))
(define (duplicates xs)
(define (collect xs zs)
(cond
((null? xs) (reverse zs))
((member (car xs) zs) (collect (cdr xs) zs))
((member (car xs) (cdr xs))
(collect (cdr xs) (cons (car xs) zs)))
(else (collect (cdr xs) zs))))
(collect xs '()))

(define (duplicate-items? xs)
(not (= (length xs) (length (nub xs)))))

;(set-difference '(a x) '(a b c)) ==> (x)
(define (set-difference xs ys)
(filter (lambda(x)(not (member x ys))) xs))

;(intersection '(a x) '(a b c)) ==> (a)
(define (intersection xs ys)
(filter (lambda(x)(member x ys)) xs))

;; Represent require specification, such as
;; (import->triples '((mod-1 (a a1) (b b1) c) (mod-2 (p p2) q)))
;; as a flat list of triples, as in:
;; ((mod-1 a a1) (mod-1 b b1) (mod-1 c c) (mod-2 p p2) (mod-2 q q))
(define (import->triples ms)
(define (tx xs)
(define (tx* m ps zs)
(cond
((null? ps) (reverse zs))
(else (tx* m (cdr ps) (cons (f m (car ps)) zs)))))
(define (f m p)
(cond
((symbol? p) (list m p p))
((symbol-pair? p) (cons m p))
(else
(error* "a module"
"Import item" p
"is neither a symbol"
"nor a pair of symbols"))))
(tx* (car xs) (cdr xs) ()))
(fold-left append () (map tx ms)))

;; Convert <require:> specification to a alist of interfaces.
;; (import->interfaces '((mod-1 (a a1) (b b1) c) (mod-2 (p p2) q)))
;; ==> ((mod-1 (a b c)) (mod-2 (p q)))
(define (import->interfaces ms)
(define (f xs)
(list (car xs) (map g (cdr xs))))
(define (g x)
(cond
((symbol? x) x)
((symbol-pair? x) (car x))
(else
(error* "a module"
"Import item" x
"is neither a symbol"
"nor a pair of symbols")
)))
(map f ms))

(define (symbol-pair? x)
(and
(pair? x)
(= (length x) 2)
(symbol? (car x))
(symbol? (cadr x))))

(define (error* name . items)
(error 'my-module-kernel
(any->string
(append (list "When making" name "==>")
items))))

;; True if the module specification is internally consistent.
;; Signals an error if any failure whatsoever.
;; This test does not concern itself with existence of
;; required modules, nor validation against their interfaces.
(define (internal-consistency-test
name exports modules locals imp-items)
(cond

[
(duplicate-items? locals)
(error* name
"Local definitions contain duplicate names:"
(duplicates locals))
][
(duplicate-items? imp-items)
(error* <name>
"Duplicate names:"
(duplicates imp-items)
"in explicitly imported items."
)
][
(intersect? imp-items locals)
(error* name
"Intersection of local and imported"
"set of items:"
(intersection imp-items locals)
"is not empty"
)
][
(not (subset? exports
(append locals imp-items)))
(error* name
"Neither local set of definitions" locals
"nor definitions imported from modules" modules
"support this subset of exports:"
(set-difference exports
(append locals imp-items)))
][
else #t
]))

;; Validates the required items against interfaces
;; of required modules, which should be stored in the top-level
;; repository "repository-of-modular-interfaces". Signals an error
;; on any failure, otherwise returns #t.
(define (external-consistency-test name require-spec)
(define (interface-test name require-spec)
(let* (
(specified-ifaces (import->interfaces require-spec))
(modules (map car specified-ifaces))
(queried-ifaces (map registered-interface modules))
(missing-mods (map car (filter
(lambda(x)(not (cadr x)))
queried-ifaces)))
(pair-wise-subset? (lambda(x y)(subset? (cadr x) (cadr y))))
(pair-wise-difference
(lambda(x y)(list (car x)
(set-difference (cadr x) (cadr y)))))
)

(cond
[
(not (null? missing-mods))
(error* name

"Missing registered interfaces"
"for the following modules:"
missing-mods
)
][
(not (all-true?
(map pair-wise-subset? specified-ifaces
queried-ifaces)))
(error* name
"Imports from some modules"
(map pair-wise-difference specified-ifaces
queried-ifaces)
"are not supported by their corresponding"
"Registered Modular Interfaces."
)
][
else #t
])))
(if (not (top-level-bound? 'repository-of-modular-interfaces))
(error* name
"Repository of Modular Interfaces"
"does not appear to be bound at the top level")
(interface-test name require-spec)))

(define (all-true? xs)
(every (lambda(x)(eq? x #t)) xs))

;; The entry point to the "my-module-kernel" macro.
;; Main structure of the input has been already
;; validated by the front end macro "my-module"
(syntax-case stx (provide: require: run:
unification testing production dualizing)

[ ;; 1. clause unification:
;; Strip the (provide: require: run:) labels -- we do not
;; need them any more, since the input blocks are clearly
;; identified.
;; Jump to "extract-ids" macro in order to extract ids from
;; the local definitions
(my-module-kernel name unification
(provide: e ...)
(require: i ...)
d ...
(run: r ...))

(syntax
(extract-ids ;; sub-macro call. Pass 3 args:
my-module-kernel ;; 1. "Return address"
(name testing
(e ...)
(i ...)
d ...
(r ...)) ;; 2. "The call frame" to be preserved
(d ...) ;; 3. Data to be acted upon by extract-ids
)) ;; Expect 2 args on return: frame and result

][ ;; 2. Clause testing. Control is back from extract-ids.
;; => Test and produce if not failures.
(my-module-kernel
( name testing
(export ...)
(import ...)
definition ...
(expression ...)
) ;; preserved call frame
(local ...)) ;; result from extract-ids

;; Testing fender, which should evaluate to true
;; - unless escaped with error.
(let* (
(<name> (syntax-object->datum (syntax name)))

(<locals> (syntax-object->datum
(syntax (local ...))))
(<required> (syntax-object->datum
(syntax (import ...))))

(<modules> (map car <required> ))

(<imports> (map caddr (import->triples <required> )))

(<exports> (syntax-object->datum
(syntax (export ...)))))

;; Performs a bunch of internal consistency tests,
;; such as test for duplicates in the spec, etc.
;; Signals and error on any failure whatsoever.
(internal-consistency-test
<name> <exports> <modules> <locals> <imports> )

;; Validates required items against interfaces
;; of required modules, which should be stored in
;; the top-level "repository-of-modular-interfaces".
;; Signals an error on any failure, otherwise returns #t.
;(external-consistency-test <name> <required> )
)
;; Enter the final production with additional syntax objects
(with-syntax (
[ ;; For tools dealing with dependencies
modules
(datum->syntax-object
(syntax name)
(map car
(syntax-object->datum
(syntax (import ...)))))
][ ;; To insert local definitions of imported items
((mod old new) ...)
(datum->syntax-object
(syntax name)
(import->triples (syntax-object->datum
(syntax (import ...)))))
])
(syntax
(my-module-kernel production name
modules
(export ...)
((define new (mod 'old)) ...)
definition ...
(expression ...))))

][ ;; 3. clause production
(my-module-kernel production name
modules
(export ...)
(import-definition ...)
definition ...
(expression ...))

(with-syntax (
[
procedure-definition
(datum->syntax-object
(syntax name)
(syntax-object->datum (syntax

(define (name first . rest)
import-definition ...
definition ...
(module-dispatcher
'name
first
rest
'modules
(list (list 'export export) ...)
(lambda () #t expression ...)
))
)))
])
(syntax
;'(begin
procedure-definition
;(register-interface! 'name (list 'export ...))
;)
))
]
))

(begin-for-dual-use
;; module-dispatcher
;; A helper function used by macro-generated procedures
;; representing modules.
(define (module-dispatcher module-name first rest modules bindings
runtime)

;; Several calling patterns can be wrapped in
;; a user-friendly module interface
;; -- as shown at the bottom of this file.
(define (usage-error module-name)
(error module-name (any->string (list
"Wrong usage of module" module-name ".\n"
"Correct usage:\n"
"1. (from" module-name "a-symbol)\n"
"2a. (bindings" module-name ")\n"
"2b. (bindings" module-name "a-symbol ...)\n"
"3. (interface" module-name ")\n"
"4. (run" module-name ")\n"
"5. (providers" module-name ")\n"
"6. (module-name" module-name ")\n"
))))

(define (access-error module-name symbol)
(error module-name (any->string (list
"module" module-name
"does not provide a binding for"
symbol))))

(define (dispatch msg)
(cond
((assq msg bindings) => cadr)
(else (access-error module-name msg))))
(cond
[
(symbol? first)
(dispatch first)
][ ;; Do not worry about these integers.
;; The public interface below takes care of it.
(not (integer? first))
(usage-error module-name)
][
(= first 2)
(if (null? rest)
bindings
(filter (lambda(u)(member (car u) rest))
bindings))
][
(= first 3)
(map car bindings)
][
(= first 4)
(runtime)
][
(= first 5)
modules
][
(= first 6)
module-name
][
else (usage-error module-name)
]))

)
;; ================== my-module interface ====================

;; (import-transformer module-name transformer-name)
;; A wrapper for importing transformers from normal environments
;; to transformer environments.
;;
;; The reason why eval must be used here is this: Mzscheme maintains
;; strong separation of normal environment from transformer
environment.
;; Since modules are being constructed in normal environment only, they
;; cannot be directly accessed from the transformer environment, as in
;; this failing attempt to form a syntax definition:
;; (define-syntax item (from module item)) ;; ==> error
;; However, the eval may serve as a bridge between these two
environments,
;; since according to the Mzscheme manual, section 14.1, Eval and Load:
;; "(eval expr) evaluates expr in the current namespace."
;; The current namespace, in turn, is a set of several environments:
normal,
;; transformer and template. The eval evaluates '(from module item)
;; within the normal environment and then magically submits the result
;; to define-syntax construct. Consequently, the following definition,
;; which uses eval, will succeed:
;; (define-syntax item (import-transformer 'module 'item)).
;;
;; None of this is needed in Chez Scheme, which makes no distinction
;; between normal and transformer environments. However, this function
;; executes fine on Chez Scheme platform as well.

(begin-for-dual-use
(define (import-transformer module item)
(eval `(from ,module ,item)))
)

;; macro: (define-syntax* name (from module transformer))
;;
;; A version of define-syntax that imports the 'transformer
;; from the specified 'module and binds it to the 'name.
(define-syntax (define-syntax* stx)
(syntax-case stx (from)
[
(define-syntax* name (from module transformer))
(syntax (define-syntax name
(import-transformer 'module 'transformer)))
]))

;; Macro: (from module item)
;; Expands to: (module 'item)
(define-syntax (from stx)
(syntax-case stx ()
[
(from module-name item)
(syntax (module-name 'item))
]))

;; Macro: (show (comment ... expr) ...)
;; Convenience macro to wrap demo expressions
;; in run: block.
;; (show ("Test 1:" (* 2 3))) ==> (("Test 1:" (* 2 3) ==> 6))
(define-syntax (show stx)
(syntax-case stx ()
[
(show (comment ... expr) ...)
(syntax (list (list comment ... 'expr '==> expr) ...))
]
))

;; Provided bindings - all or some.
(define (bindings module . symbols)
(cond
((null? symbols) (module 2))
(else (apply module 2 symbols))))

;; All provided symbols
(define (interface module)
(module 3))

;; Evaluate run block of the module
(define (run module)
(module 4))

;; Providers of the module
(define (providers module)
(module 5))

;; Module name
(define (module-name module)
(module 6))

;; Hierarchy of providers of the module
(define (providers-tree module)
(map (lambda(x)(cons x (providers-tree (eval x))))
(providers module)))

;; ============ Repository Of Modular Interfaces ============

;;(define xs '((a a1) (b b1) (c c1) (d d1)))
;;(apply-romi '(f f1) xs) => ((f f1) (a a1) (b b1) (c c1) (d d1))
;;(apply-romi '(c c2) xs) => ((a a1) (b b1) (c c2) (d d1))
(begin-for-dual-use
(define repository-of-modular-interfaces '())

;; Register interface 'module-interface for 'module-name
(define (register-interface! module-name module-interface)
(set! repository-of-modular-interfaces
(apply-romi
(list module-name module-interface)
repository-of-modular-interfaces)))

;; A registered interface for (module-name iface)
;; or (module-name #f)
(define (registered-interface module-name)
(cond
[
(assq module-name
repository-of-modular-interfaces) => (lambda(x) x)
][
else (list module-name #f)
]))

(define (apply-romi pare romi)
(define partitions
(list-span
(lambda(x)(not (eq? (car x) (car pare))))
romi))
(define (list-span p xs)
(define (span p us xs)
(cond
((null? xs) (list (reverse us) xs))
((p (car xs)) (span p (cons (car xs) us) (cdr xs)))
(else (list (reverse us) xs))))
(span p '() xs))

(cond
[
(null? (cadr partitions))
(cons pare romi)
][
else
(append (car partitions) (list pare) (cdadr partitions))
]))
)
#|
Copyright (C) Jan Skibinski (2006). All Rights Reserved.
Permission is hereby granted, free of charge, to any person obtaining a
copy of this software and associated documentation files (the
"Software"), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:

The above copyright notice and this permission notice shall be included
in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
|#

Sponsored Links