/
shorten.ss
101 lines (88 loc) · 3.65 KB
/
shorten.ss
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
; shorten.ss
;
; Copyright (c) 2010 OKUMURA Yuki and Higepon(Taro Minowa)
;
;
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions
; are met:
;
; 1. Redistributions of source code must retain the above copyright
; notice, this list of conditions and the following disclaimer.
;
; 2. Redistributions in binary form must reproduce the above copyright
; notice, this list of conditions and the following disclaimer in the
; documentation and/or other materials provided with the distribution.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;
#|
Title: Shorten
This library provides a short alias for lambda expression.
The idea come from "Gauche Devlog - Shorter names http://blog.practical-scheme.net/gauche/20100428-shorter-names" by Shiro.
Example:
(start code)
(map (^(x y) (+ x y)) '(1 2 3 4) '(1 2 3 4)) => (map (lambda (x y) (+ x y)) '(1 2 3 4) '(1 2 3 4))
(^a body ...) => (lambda (a) body ...)
(^b body ...) => (lambda (b) body ...)
...
(^z body ...) => (lambda (z) body ...)
(^_ body ...) => (lambda (_) body ...)
(^a* body ...) => (lambda a* body ...)
(^b* body ...) => (lambda b* body ...)
...
(^z* body ...) => (lambda z* body ...)
(^_* body ...) => (lambda _* body ...)
(end code)
library: (shorten)
|#
(library (shorten)
(export ^a ^b ^c ^d ^e ^f ^g ^h ^i ^j ^k ^l ^m ^n ^o ^p ^q ^r ^s ^t ^u ^v ^w ^x ^y ^z ^_ ^
^a* ^b* ^c* ^d* ^e* ^f* ^g* ^h* ^i* ^j* ^k* ^l* ^m* ^n* ^o* ^p* ^q* ^r* ^s* ^t* ^u* ^v* ^w* ^x* ^y* ^z* ^_*)
(import (rnrs) (for (shorten helper) expand))
(define-syntax ^
(lambda (x)
(syntax-case x ()
[(_ args ...)
#'(lambda args ...)])))
(define-syntax define-^
(lisp-transformer
(lambda (f)
(define (entry name)
(let ((namestr (symbol->string name)))
`(define-syntax ,(string->symbol (string-append "^" namestr))
(lambda (x)
(syntax-case x ()
((k args ...)
(with-syntax ((larg (datum->syntax #'k (quote ,name))))
#'(lambda (larg) args ...))))))))
(let ((l (cdr f)))
(cons 'begin (map entry l))))))
(define-syntax define-^*
(lisp-transformer
(lambda (f)
(define (entry name)
(let ((namestr (symbol->string name)))
`(define-syntax ,(string->symbol (string-append "^" namestr "*"))
(lambda (x)
(syntax-case x ()
((k args ...)
(with-syntax ((larg (datum->syntax #'k (quote ,(string->symbol (string-append (symbol->string name) "*"))))))
#'(lambda larg args ...))))))))
(let ((l (cdr f)))
(cons 'begin (map entry l))))))
(define-^
_ a b c d e f g h i j k l m n o p q r s t u v w x y z)
(define-^*
_ a b c d e f g h i j k l m n o p q r s t u v w x y z)
)