1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
4 USING: accessors ascii assocs combinators
5 combinators.short-circuit formatting kernel make math namespaces
6 regexp regexp.parser sequences splitting strings
7 xmode.marker.state xmode.rules xmode.tokens xmode.utilities ;
11 ! Next two words copied from parser-combinators
12 ! Just like head?, but they optionally ignore case
14 : string= ( str1 str2 ignore-case -- ? )
15 [ [ >upper ] bi@ ] when sequence= ;
17 : string-head? ( str1 str2 ignore-case -- ? )
22 [ length head-slice ] 2bi
26 ! Based on org.gjt.sp.jedit.syntax.TokenMarker
28 : current-keyword ( -- string )
29 last-offset get position get line get subseq ;
31 : keyword-number? ( keyword -- ? )
33 [ current-rule-set highlight-digits?>> ]
34 [ dup [ digit? ] any? ]
37 current-rule-set digit-re>>
38 [ dupd matches? ] [ f ] if*
43 : mark-number ( keyword -- id )
44 keyword-number? DIGIT and ;
46 : mark-keyword ( keyword -- id )
47 current-rule-set keywords>> at ;
49 : add-remaining-token ( -- )
50 current-rule-set default>> prev-token, ;
54 dup mark-number [ ] [ mark-keyword ] ?if
55 [ prev-token, ] when* ;
57 : current-char ( -- char )
58 position get line get nth ;
60 GENERIC: match-position ( rule -- n )
62 M: mark-previous-rule match-position drop last-offset get ;
64 M: rule match-position drop position get ;
66 : can-match-here? ( matcher rule -- ? )
69 [ over at-line-start?>> over zero? implies ]
70 [ over at-whitespace-end?>> over whitespace-end get = implies ]
71 [ over at-word-start?>> over last-offset get = implies ]
74 : rest-of-line ( -- str )
75 line get position get tail-slice ;
77 : match-start ( string regexp -- slice/f )
78 first-match dup [ dup from>> 0 = [ drop f ] unless ] when ;
80 GENERIC: text-matches? ( string text -- match-count/f )
85 M: string-matcher text-matches?
86 [ string>> ] [ ignore-case?>> ] bi
87 [ string-head? ] keepd length and ;
89 M: regexp text-matches?
90 [ >string ] dip match-start dup [ to>> ] when ;
94 ! XXX: Terrible inefficient regexp match group support
96 : #match-groups ( regexp -- n/f )
97 raw>> [ CHAR: ( = ] count [ f ] when-zero ;
99 : nth-index ( n obj seq -- i )
100 [ = dup [ drop 1 - dup 0 < ] when ] with find drop nip ;
102 : match-group-regexp ( regexp n -- skip-regexp match-regexp )
103 [ [ options>> options>string ] [ raw>> ] bi ] dip
104 CHAR: ( pick nth-index cut CHAR: ) over index 1 + head
105 rot '[ _ <optioned-regexp> ] bi@ ;
107 : skip-first-match ( match regexp -- tailseq )
108 first-match [ seq>> ] [ to>> ] bi tail ;
110 : nth-match ( match regexp n -- slice/f )
111 match-group-regexp [ skip-first-match ] [ first-match ] bi* ;
113 : update-match-group ( str match regexp n -- str' )
114 [ nth-match ] [ CHAR: 1 + "$%c" sprintf ] bi swap replace ;
116 : update-match-groups ( str match regexp -- str' )
118 dup #match-groups [ update-match-group ] 2with each-integer ;
120 GENERIC: fixup-end ( match regexp end -- end' )
122 M: string-matcher fixup-end
123 [ string>> -rot update-match-groups ]
124 [ ignore-case?>> ] bi <string-matcher> ;
126 MEMO: <fixup-regexp> ( raw matched options -- regexp )
128 [ parse-tree>> ] [ options>> ] [ dfa>> ] [ next-match>> ]
129 } cleave regexp boa ;
132 [ raw>> [ -rot update-match-groups ] keep swap ]
133 [ options>> options>string ] bi <fixup-regexp> ;
135 : fixup-end? ( text -- ? )
136 { [ regexp? ] [ #match-groups ] } 1&& ;
138 : fixup-end/text-matches? ( string regexp rule -- match-count/f )
139 [ >string ] 2dip [ [ match-start dup ] keep ] dip pick [
140 end>> [ [ fixup-end ] change-text drop ] [ 2drop ] if*
143 ] if dup [ to>> ] when ;
147 :: rule-start-matches? ( rule -- match-count/f )
148 rule start>> dup rule can-match-here? [
149 rest-of-line swap text>>
151 rule fixup-end/text-matches?
159 : rule-end-matches? ( rule -- match-count/f )
160 dup mark-following-rule? [
161 [ start>> ] keep can-match-here? 0 and
163 [ end>> dup ] keep can-match-here? [
165 swap text>> context get end>> or
174 : get-always-rules ( vector/f ruleset -- vector/f )
175 f swap rules>> at ?push-all ;
177 : get-char-rules ( vector/f char ruleset -- vector/f )
178 [ ch>upper ] dip rules>> at ?push-all ;
180 : get-rules ( char ruleset -- seq )
181 [ f ] 2dip [ get-char-rules ] keep get-always-rules ;
183 GENERIC: handle-rule-start ( match-count rule -- )
185 GENERIC: handle-rule-end ( match-count rule -- )
187 : find-escape-rule ( -- rule )
189 in-rule-set>> escape-rule>> [ ] [
190 parent>> in-rule-set>>
191 dup [ escape-rule>> ] when
194 : check-escape-rule ( rule -- ? )
195 escape-rule>> [ find-escape-rule ] unless*
197 dup rule-start-matches? [
198 swap handle-rule-start
199 delegate-end-escaped? toggle
206 : check-every-rule ( -- ? )
207 current-char current-rule-set get-rules
208 [ rule-start-matches? ] map-find
209 [ handle-rule-start t ] [ drop f ] if* ;
213 dup rule-end-matches?
214 [ swap handle-rule-end ] [ drop ] if*
217 : rule-match-token* ( rule -- id )
219 { f [ dup body-token>> ] }
220 { t [ current-rule-set default>> ] }
224 M: escape-rule handle-rule-start
227 process-escape? get [
229 position [ + ] change
232 M: seq-rule handle-rule-start
236 [ body-token>> next-token, ] keep
237 delegate>> [ push-context ] when* ;
239 UNION: abstract-span-rule span-rule eol-span-rule ;
241 M: abstract-span-rule handle-rule-start
245 [ rule-match-token* next-token, ] keep
247 dup context get in-rule<<
248 delegate>> push-context ;
250 M: span-rule handle-rule-end
253 M: mark-following-rule handle-rule-start
255 mark-token add-remaining-token
256 [ rule-match-token* next-token, ] keep
258 context get in-rule<< ;
260 M: mark-following-rule handle-rule-end
261 nip rule-match-token* prev-token,
262 f context get in-rule<< ;
264 M: mark-previous-rule handle-rule-start
267 dup body-token>> prev-token,
268 rule-match-token* next-token, ;
276 : check-end-delegate ( -- ? )
277 context get parent>> [
279 dup rule-end-matches? [
285 ] keep context get parent>> in-rule>>
286 rule-match-token* next-token,
288 seen-whitespace-end? on t
289 ] [ check-escape-rule ] if*
293 : handle-no-word-break ( -- )
294 context get parent>> [
296 dup no-word-break?>> [
297 rule-match-token* prev-token,
307 add-remaining-token ;
309 : (check-word-break) ( -- )
312 1 current-rule-set default>> next-token, ;
314 : rule-set-empty? ( ruleset -- ? )
315 [ rules>> ] [ keywords>> ] bi
316 [ assoc-empty? ] both? ;
318 : check-word-break ( -- ? )
319 current-char dup blank? [
322 seen-whitespace-end? get [
323 position get 1 + whitespace-end set
329 ! Micro-optimization with incorrect semantics; we keep
330 ! it here because jEdit mode files depend on it now...
331 current-rule-set rule-set-empty? [
337 current-rule-set rule-set-no-word-sep* member? [
343 seen-whitespace-end? on
346 delegate-end-escaped? off t ;
349 : mark-token-loop ( -- )
350 position get line get length < [
352 [ check-end-delegate ]
361 : mark-remaining ( -- )
362 line get length position set
365 : unwind-no-line-break ( -- )
366 context get parent>> [
375 : tokenize-line ( line-context line rules -- line-context' seq )