summaryrefslogtreecommitdiff
path: root/Build/source/utils/xindy/xindy-src/src/ordrules.lsp
blob: ea372eb94eae60fe76572d44f0bcf96d72619549 (plain)
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
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
;;; $Id$
;;;----------------------------------------------------------------------

;;;
;;; ordrules  ---  order rules for xindy
;;;
;;; (history at end)


(provide "ordrules")


;;;; ============================================================
;;;;
;;;; SPECIFICATION
;;;;

;;;
;;; package ordrules XXX
;;;

(defpackage "ORDRULES"
    (:documentation "Order rules for xindy.
Provides functionality for merge-rules and sort-rules, as ordrule collections.
An ordrule collection is an ordered set of order rules.
An order rule is an object that manages replacement of a string or
regular expression by a string.
Ordrule collections are applied to strings, the result is created by
successive application of matching order rules.")
  (:use common-lisp clos regexp)
  (:shadow match)
  (:export ;; object interface
	   "MAKE-ORDRULE-TABLE" "ADD-RULE" "APPLY-RULES"
	   ;; legacy (C plugin) interface
	   "INITIALIZE" "ADD-KEYWORD-MERGE-RULE" "ADD-KEYWORD-SORT-RULE"
	   "GEN-KEYWORD-MERGEKEY" "GEN-KEYWORD-SORTKEY"
	   "*MESSAGE-BUFFER-PTR*" "*MESSAGE-BUFFER*" "*MESSAGE-LOGGING*")
  )
(in-package "ORDRULES")



;;;; ============================================================
;;;;
;;;; ORDRULE OBJECTS
;;;;

;;; class ORDRULE
;;; Slots:
;;;  -- match: regexp, string, or char that might be matched
;;;  -- repl: replacement for the matched substring
;;;  -- again: boolean flag if repl should be eligible for further ordrules
;;;
;;; subclass ORDRULE-STRING -- no additional slots
;;; subclass ORDRULE-CHAR -- no additional slots
;;; subclass ORDRULE-REGEXP
;;; Additional Slots:
;;;  -- only-at-start: boolean flag if match should only be tested at start
;;;     of string

(defclass ordrule ()
    ((match :initarg :match :reader match)
     (repl :initarg :repl :reader repl)
     (again :initarg :again :reader again))
  (:documentation
   "An order rule that represents the replacement of a matching expression
with a replacement string."))

(defclass ordrule-string (ordrule)
    ()
  (:documentation
   "An ordrule where the matching expression is a string"))

(defclass ordrule-char (ordrule)
    ()
  (:documentation
   "An ordrule where the matching expression is a char"))

(defclass ordrule-regexp (ordrule)
    ((pattern :initarg :pattern :reader pattern)
     (only-at-start :initarg :only-at-start :reader only-at-start))
  (:documentation
   "An ordrule where the matching expression is a regexp"))

(defmethod print-object ((obj ordrule) stream)
  "Print an ordrule."
  (format stream "#<ordrule: '~A' => '~A' :again ~A>"
	  (match obj) (repl obj) (again obj)))

(defmethod print-object ((obj ordrule-regexp) stream)
  "Print an ordrule."
  (format stream "#<ordrule-regexp: '~A' => '~A' :again ~A :only-at-start ~A>"
	  (pattern obj) (repl obj) (again obj) (only-at-start obj)))

(defun make-ordrule-string (match repl &key again)
  "Create an ordrule-string object.
MATCH is a string to compare."
  (make-instance 'ordrule-string :match match :repl repl :again again))

(defun make-ordrule-char (match repl &key again)
  "Create an ordrule-string object.
MATCH is a character to compare."
  (make-instance 'ordrule-char :match match :repl (string repl) :again again))

(defun make-ordrule-regexp (match-pattern repl &key again (extended t))
  "Create an ordrule-regexp object.
MATCH-PATTERN is a POSIX regular expression.
The boolean keyword argument :extended tells if the regex is a basic
one or an extended one; default is to use extended ones."
  (let* ((only-at-start (char= (char match-pattern 0) #\^))
	 (match (if only-at-start (subseq match-pattern 1) match-pattern)))
    (make-instance 'ordrule-regexp
		   :match (regexp-compile (concatenate 'string "^(" match ")")
					  :extended extended)
		   :repl repl :again again
		   :pattern match-pattern :only-at-start only-at-start)))

;; A regexp-compile object does not survive dump and reload.
;; Therefore we have to initialize it at first usage.
(defvar *REGEXP-PATTERN*
  nil
  "If this pattern matches, the string is a regexp.")

(defun make-ordrule (match repl &key again)
  "Create an ordrule object.
MATCH may be a string, a char, or a POSIX regular expression.
If it's a regexp, it's an extended one."
  (or *REGEXP-PATTERN*
      (setq *REGEXP-PATTERN* (regexp-compile "[][|(){}.*+^$?]")))
  (cond ((characterp match)
	   (make-ordrule-char match repl :again again))
	((= (length match) 1)
	   (make-ordrule-char (char match 0) repl :again again))
	((regexp-exec *REGEXP-PATTERN* match)
	   (make-ordrule-regexp match repl :again again))
	(t (make-ordrule-string match repl :again again))))


;;;
;;; (try-rule RULE SOURCE) => FINAL ; SOURCE-REST  or  <no values>
;;;

(defgeneric try-rule (ordrule source &key at-start)
  (:documentation "Apply an ordrule to a source string.
If the rule does not match, return nothing. If it matches, return two
values: the 1st is the final prefix with the replacement
string and the 2nd is the rest of SOURCE that's left after the matched
text. If the rule's again flag is true, FINAL will be the empty string
and the replacement will be at the start of SOURCE-REST.
An ordrule is not allowed to turn a source completely into an empty string.
If that would happen, a warning is output and nothing is returned.
That situation would exist, if AT-START is true and both FINAL and
SOURCE-REST would be empty.
AT-START tells if we are at the start to process the source string."))

(defmethod try-rule ((rule ordrule-char) source &key at-start)
  (if (char= (char source 0) (match rule))
      (maybe-again-maybe-no rule source at-start
			    (repl rule) (subseq source 1))
    (values)))

(defun maybe-again-maybe-no (rule source at-start repl source-rest)
  (cond ((and at-start (string= repl "") (string= source-rest ""))
	   (warn "Would replace complete index key by empty string, ignoring ~S" rule)
	   (values source ""))
	((again rule)
	   (values "" (concatenate 'string repl source-rest)))
	(t (values repl source-rest))))

(defmethod try-rule ((rule ordrule-string) source &key at-start)
  (let* ((match-string (match rule))
	 (match-length (length match-string)))
    (cond ((> match-length (length source)) (values))
	  ((string= source match-string :end1 match-length)
	     (maybe-again-maybe-no rule source at-start
				   (repl rule) (subseq source match-length)))
	  (t (values)))))

(defmethod try-rule ((rule ordrule-regexp) source &key at-start)
  (if (and (only-at-start rule) (not at-start))
      nil
    (let ((match-regexp (multiple-value-list (regexp-exec (match rule) source))))
      (if match-regexp
	  (maybe-again-maybe-no rule source at-start
		       (maybe-repl-subexpr (repl rule) (rest match-regexp) source)
		       (subseq source (match-end (first match-regexp))))
	(values)))))

;; A regexp-compile object does not survive dump and reload.
;; Therefore we have to initialize it at first usage.
(defvar *REPL-PATTERN*
  nil
  "Compiled regexp that matches a backpattern in a regexp replacement text.")

;; We need to substitute all \x and & constructs in the replacement text by
;; the respective subexpression from source's matches. They are
;; located with a regexp in a loop and we collect in 'final-repl the
;; strings in front of each \x and the actual subexpression.
(defun maybe-repl-subexpr (repl source-matches source)
  (or *REPL-PATTERN*
      (setq *REPL-PATTERN* (regexp-compile "\\\\([1-9])|&" :extended t)))
  (do* ((start 0 (match-end (first subexpr-match)))
	(subexpr-match (multiple-value-list (regexp-exec *REPL-PATTERN* repl))
		       (multiple-value-list (regexp-exec *REPL-PATTERN* repl
							 :start start)))
       (final-repl ""))
      ((null subexpr-match)
	 ;; Don't forget to return the rest of the string, too. Its
	 ;; index is now in 'start.
	 (concatenate 'string final-repl (subseq repl start)))
    ;; OK, need a subexpr replacement. First, we determine which subexpression
    ;; this shall be: If it's "&", the second match subexpression will be nil,
    ;; as the parenthesis did not match anything. Otherwise the 2nd match
    ;; subexpr will be the digit. Then we get that subexpression from the
    ;; source string. Finally, we add the 'repl string part in front of \x and
    ;; the respective subexpression to 'final-repl and are ready to look for
    ;; our next \x construct.
    (let* ((subexpr-match-struct (second subexpr-match))
	   (subexpr (and subexpr-match-struct
			 (match-string repl subexpr-match-struct)))
	   (subexpr-repl (match-string source
				       (nth (if (null subexpr)
						0
					      (read-from-string subexpr))
					    source-matches))))
      (setq final-repl
	    (concatenate 'string final-repl
			 (subseq repl 0 (match-start (first subexpr-match)))
			 subexpr-repl)))))


;;;
;;; (rule-first-char RULE) => char or :regexp
;;;

(defgeneric rule-first-char (rule)
  (:documentation "Returns the first char of a rule match.
This returns either the first char of a rule match, or :regexp
if that first char is a regular expression. The is used to find the
slot for a rule in a rule table."))

(defmethod rule-first-char ((rule ordrule-char))
  (match rule))

(defmethod rule-first-char ((rule ordrule-string))
  (char (match rule) 0))

(defmethod rule-first-char ((rule ordrule-regexp))
  (let* ((pattern (pattern rule))
	 (start-index (if (only-at-start rule) 1 0))
	 (first-char (char pattern start-index)))
    (cond ((char= first-char #\\)
	     (char pattern (1+ start-index)))
	  ((find first-char "[]|(){}.*+?")
	     :regexp)
	  (t first-char))))



;;;; ============================================================
;;;;
;;;; ORDRULE TABLES
;;;;

;; An ordrule table is a hash table of ordrule lists, indexed by the first
;; character of the rule. The key :regexp is the entry for rules that start
;; with a regexp pattern.

(defclass ordrule-table ()
    ((table :initarg :table :reader table))
  (:documentation
   "A collection of ordrules."))

(defmethod print-object ((obj ordrule-table) stream)
  "Print an ordrule table."
  (format stream "#<ordrule table with ~A entries>" (hash-table-count (table obj))))

(defun make-ordrule-table ()
  "Create an ordrule-table object."
  (make-instance 'ordrule-table :table (make-hash-table :size 256)))

(defun add-rule (rule-table rule)
  "Add a rule to an ordrule table."
  (let* ((first-char (rule-first-char rule))
	 (first-char-rules (gethash first-char (table rule-table))))
    (if first-char-rules
	(nconc first-char-rules (list rule))
      (setf (gethash first-char (table rule-table)) (list rule)))))

;; XXX This is the place where we might want to sort rules according to their
;; length. But then we should also cache that sort result, because this
;; function is called for each character in the index!
;;
;; XXX Maybe we should try a cache anyhow, to save appends, too? Need to
;; measure that.
(defun get-rules (rule-table source-start)
  (append (gethash source-start (table rule-table))
	  (gethash :regexp (table rule-table))))

(defun apply-rules-once (rule-table source at-start)
  "Apply rules from rule-table once to source.
Returns two values: (1) prefix that has been processed, (2) suffix that has
still to be processed."
  (dolist (rule (get-rules rule-table (char source 0))
	   (values))
    (multiple-value-bind (prefix suffix)
	(try-rule rule source :at-start at-start)
      (if (stringp prefix)
	  (return (values prefix suffix))))))

(defun apply-rules (rule-table source &optional (at-start t))
  "Apply rules from rule-table to source."
  (multiple-value-bind (prefix suffix)
      (apply-rules-once rule-table source at-start)
    (log-rule (format nil "apply rules once: '~A' => '~A' '~A'~%"
		      source prefix suffix))
    (cond ((null prefix)
	     (if (= (length source) 1)
		 source
	       (concatenate 'string (subseq source 0 1)
			    (apply-rules rule-table (subseq source 1) nil))))
	  ((string= suffix "") prefix)
	  (t (concatenate 'string prefix
			  (apply-rules rule-table suffix nil))))))



;;;; ============================================================
;;;;
;;;; LEGACY (C PLUGIN) INTERFACE
;;;;

;; The following code realizes the interface of xindy 2.3, even though we
;; could now use real Lisp objects. This is a transient phase only.

(defvar *merge-rule-table*
  (make-ordrule-table))

;; By default, we have runs 0..7.
(defvar *sort-rule-tables*
  (let ((tables (make-array '(8) :element-type 'ordrule-table)))
    (dotimes (i 8)
      (setf (aref tables i) (make-ordrule-table)))
    tables))

(defun initialize (num)
  (setq *sort-rule-tables* (make-array (list num) :element-type 'ordrule-table))
  (dotimes (i num)
    (setf (aref *sort-rule-tables* i) (make-ordrule-table))))

(defun add-keyword-rule (rule-table rule repl again ruletype)
  (let* ((again (if (= again 1) t nil))
	 (rule-obj (ecase ruletype
		     (0 (make-ordrule rule repl :again again))
		     (1 (make-ordrule-string rule repl :again again))
		     (2 (make-ordrule-regexp rule repl :again again :extended nil))
		     (3 (make-ordrule-regexp rule repl :again again))
		     (4 (make-ordrule-char rule repl :again again)))))
    (add-rule rule-table rule-obj)))

(defun add-keyword-merge-rule (rule repl again ruletype)
  (let* ((rule-list (add-keyword-rule *merge-rule-table* rule
				     repl again ruletype))
	 (message (format nil "Add merge rule: ~S~%" (first (last rule-list)))))
    (log-rule message)))

(defun add-keyword-sort-rule (run rule repl again ruletype)
  (let* ((rule-list (add-keyword-rule (aref *sort-rule-tables* run)
				      rule repl again ruletype))
	 (message (format nil "Add sort rule to run ~A: ~S~%"
			  run (first (last rule-list)))))
    (log-rule message)))

(defun gen-keyword-mergekey (key)
  (let ((result (apply-rules *merge-rule-table* key)))
    (log-rule (format nil "Final merge-rule result: '~A' -> '~A'~%"
		      key result))
    result))

(defun gen-keyword-sortkey (key run)
  (let ((result (apply-rules (aref *sort-rule-tables* run) key)))
    (log-rule (format nil "Final sort-rule result, run ~A: '~A' -> '~A'~%"
		      run key result))
    result))


;;;
;;; Logging
;;;

(defvar *message-logging*
  nil
  "Boolean: Shall rule replacement be logged?")

(defvar *message-buffer*
  ""
  "String with the log message.
This is remaining cruft from the C plugin that could not use Lisp
output streams itself.")

(defvar *message-buffer-ptr*
  0
  "Current position in *message-buffer*.
This is remaining cruft from the C plugin that could not use Lisp
output streams itself.")

(defun log-rule (message)
  (and *message-logging*
       (if (= (incf *message-buffer-ptr*) 1)
	   (setq *message-buffer* message)
	 (setq *message-buffer* (concatenate 'string *message-buffer*
					     message)))
       ))



;;;======================================================================
;;
;; $Log$