1 | #|[ |
---|
2 | Author: Juergen Lorenz |
---|
3 | ju (at) jugilo (dot) de |
---|
4 | |
---|
5 | Copyright (c) 2014, Juergen Lorenz |
---|
6 | All rights reserved. |
---|
7 | |
---|
8 | Redistribution and use in source and binary forms, with or without |
---|
9 | modification, are permitted provided that the following conditions are |
---|
10 | met: |
---|
11 | |
---|
12 | Redistributions of source code must retain the above copyright |
---|
13 | notice, this list of conditions and the following disclaimer. |
---|
14 | |
---|
15 | Redistributions in binary form must reproduce the above copyright |
---|
16 | notice, this list of conditions and the following disclaimer in the |
---|
17 | documentation and/or other materials provided with the distribution. |
---|
18 | |
---|
19 | Neither the name of the author nor the names of its contributors may be |
---|
20 | used to endorse or promote products derived from this software without |
---|
21 | specific prior written permission. |
---|
22 | |
---|
23 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS |
---|
24 | IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED |
---|
25 | TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A |
---|
26 | PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT |
---|
27 | HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, |
---|
28 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED |
---|
29 | TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR |
---|
30 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF |
---|
31 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING |
---|
32 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS |
---|
33 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |
---|
34 | ]|# |
---|
35 | |
---|
36 | ;;; The option datatype is inspired by the equally named type in ML. It |
---|
37 | ;;; simply stores one or no value at all. To be able to type options, we |
---|
38 | ;;; implement it as a functor, named options-functor, and supply an |
---|
39 | ;;; untyped version as a module named options, which simply applies the |
---|
40 | ;;; functor to a module with an any? type test, i.e. no check at all. |
---|
41 | ;;; This argument module is generated implicitly by instantiation of the |
---|
42 | ;;; functor and named _options. |
---|
43 | ;;; Unfortunately, Chicken's functor implementation contains a bug, |
---|
44 | ;;; which appears only when compiling the generated module: The functor |
---|
45 | ;;; parameter, M, must be replaced by the functor argument, _options, in |
---|
46 | ;;; the Chicken generated file options.import.scm. Hence we need to |
---|
47 | ;;; patch that latter file. |
---|
48 | ;;; |
---|
49 | (require-library datatype) |
---|
50 | |
---|
51 | (functor (options-functor (M (item?))) |
---|
52 | (options option? none some none? some-ref) |
---|
53 | (import scheme datatype M |
---|
54 | (only chicken error case-lambda)) |
---|
55 | |
---|
56 | (define-datatype option option? |
---|
57 | (none) |
---|
58 | (some (item item?))) |
---|
59 | |
---|
60 | (define (none? xpr) |
---|
61 | (cases option xpr |
---|
62 | (none () #t) |
---|
63 | (else #f))) |
---|
64 | |
---|
65 | (define (some-ref xpr) |
---|
66 | (cases option xpr |
---|
67 | (none () (error 'option "no value available")) |
---|
68 | (some (item) item))) |
---|
69 | |
---|
70 | (define options |
---|
71 | (let ( |
---|
72 | (signatures '( |
---|
73 | (none) |
---|
74 | (some item) |
---|
75 | (option? xpr) |
---|
76 | (none? xpr) |
---|
77 | (some-ref opt) |
---|
78 | )) |
---|
79 | ) |
---|
80 | (case-lambda |
---|
81 | (() (map car signatures)) |
---|
82 | ((sym) (assq sym signatures))))) |
---|
83 | |
---|
84 | ) ; options-functor |
---|
85 | |
---|
86 | (module options = options-functor |
---|
87 | (import scheme) |
---|
88 | (define (item? xpr) #t) |
---|
89 | ) ; options |
---|
90 | |
---|