-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathrules.scm
176 lines (154 loc) · 6.24 KB
/
rules.scm
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
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
;;; This file is part of Rules, an extensible pattern matching,
;;; pattern dispatch, and term rewriting system for MIT Scheme.
;;; Copyright 2010-2013 Alexey Radul, Massachusetts Institute of
;;; Technology
;;;
;;; Rules is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU Affero General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This code is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public
;;; License along with Rules; if not, see
;;; <http://www.gnu.org/licenses/>.
(declare (usual-integrations))
;;;; Rules
;;; A rule is a pattern and a handler. The pattern determines the
;;; applicability of the rule, and the match bindings that enable said
;;; applicability, and the handler can compute an arbitrary value from
;;; them. Once constructed, a rule is a procedure that accepts a
;;; datum, and returns either the datum if the pattern doesn't match
;;; or the value of the handler when applied to the dictionary if it
;;; does. The input datum is used as the sentinel value for failure
;;; because in the context of term rewriting, succeeding with the
;;; input as the answer is equivalent to failing.
;;; The handler can reject a putative match by returning #f, which
;;; causes backtracking into the matcher, and may cause the handler to
;;; be called again with different bindings. If the handler always
;;; returns #f, the rule may fail even though its pattern matched.
(define (make-rule pattern handler)
(if (accepts-variables? handler)
(make-rule pattern (accept-dictionary
handler (match:pattern-names pattern)))
(let ((combinator (match:->combinators pattern)))
;; The value to return on failure can be overridden to
;; distinguish idempotent success from actual failure, should
;; that be important.
(lambda (data #!optional fail-token)
(if (default-object? fail-token) (set! fail-token data))
(interpret-success
(or (combinator data '() handler)
;; Not fail-token because it might be a success object
(make-success fail-token)))))))
;;; Handler interface normalization
;;; The function f is expected to be a procedure that binds the
;;; variables that appear in the match and uses them somehow. This
;;; converts it into a success procedure that accepts the match
;;; dictionary. Does not deal with optional and rest arguments to f.
(define (accept-dictionary f #!optional default-argl)
(let ((argl (procedure-argl f default-argl)))
(accepts-dictionary!
(lambda (dict)
(define (matched-value name)
(dict:value
(or (dict:lookup name dict)
(error "Handler asked for unknown name"
name dict))))
(let ((argument-list (map matched-value argl)))
(apply f argument-list))))))
(define (accepts-variables? thing)
(not (accepts-dictionary? thing)))
(define (accepts-dictionary? thing)
(eq-get thing 'accepts-dictionary))
(define (accepts-dictionary! thing)
(eq-put! thing 'accepts-dictionary #t)
thing)
;;; To allow the handler to cause its rule to succeed with #f, we
;;; provide a custom data structure in which that #f can be wrapped so
;;; it looks like a true value to the matcher combinators. It is then
;;; unwrapped by `interpret-success' in the rule procedure.
(define-structure success
value)
(define succeed make-success)
(define (interpret-success thing)
(if (success? thing)
(success-value thing)
thing))
;;;; Rule syntax
;;; The `rule' macro is convenient syntax for writing rules. A rule
;;; is written as a quoted pattern and an expression. If the pattern
;;; matches, the expression will be evaluated in an environment that
;;; includes the bindings of the pattern variables. If the expression
;;; returns #f, that will cause the pattern matcher to backtrack.
(define-syntax rule
(sc-macro-transformer
(lambda (form use-env)
(let ((pattern (cadr form))
(handler-body (caddr form)))
`(make-rule
,(close-syntax pattern use-env)
,(compile-handler handler-body use-env
(match:pattern-names pattern)))))))
(define (compile-handler form env names)
(make-lambda names env
(lambda (env*) (close-syntax form env*))))
;; Magic!
(define (make-lambda bvl use-env generate-body)
(capture-syntactic-environment
(lambda (transform-env)
(close-syntax
`(,(close-syntax 'lambda transform-env)
,bvl
,(capture-syntactic-environment
(lambda (use-env*)
(close-syntax (generate-body use-env*)
transform-env))))
use-env))))
#|
(pp (syntax '(rule '(* (? a) (? b))
(and (expr<? a b)
`(* ,a ,b)))
(the-environment)))
; (make-rule '(* (? a) (? b))
; (lambda (b a)
; (and (expr<? a b)
; (list '* a b))))
;Unspecified return value
|#
;;; This procedure was dredged from the dark recesses of Edwin. Many
;;; computer scientists would claim that it should never have been
;;; allowed to see the light of day. The purpose is to be able to
;;; interpret the formal parameter names of the closure that defines a
;;; handler as variables to look up in a dictionary produced by a
;;; matcher.
(define (procedure-argl proc #!optional default-argl)
"Returns the arg list of PROC.
Grumbles if PROC is an undocumented primitive."
(if (primitive-procedure? proc)
(let ((doc-string
(primitive-procedure-documentation proc)))
(if doc-string
(let ((newline
(string-find-next-char doc-string #\newline)))
(if newline
(string-head doc-string newline)
doc-string))
(string-append
(write-to-string proc)
" has no documentation string.")))
(let ((code (procedure-lambda proc)))
(if code
(lambda-components* code
(lambda (name required optional rest body)
name body
(append required
(if (null? optional) '() `(#!optional ,@optional))
(if rest `(#!rest ,rest) '()))))
(if (default-object? default-argl)
"No debugging information available for this procedure."
default-argl)))))