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 '[ _ H{ } [ <optioned-regexp> ] 2cache ] 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 n H{ } [ 1 + CHAR: $ swap "" 2sequence ] cache :> x
116 x match "" like regexp n nth-match str replace
119 : update-match-groups ( str match regexp -- str' )
120 dup #match-groups [ update-match-group ] 2with each-integer ;
122 GENERIC: fixup-end ( match regexp end -- end' )
124 M: string-matcher fixup-end
125 [ string>> -rot update-match-groups ]
126 [ ignore-case?>> ] bi <string-matcher> ;
128 MEMO: <fixup-regexp> ( raw matched options -- regexp )
130 [ parse-tree>> ] [ options>> ] [ dfa>> ] [ next-match>> ]
131 } cleave regexp boa ;
134 [ raw>> [ -rot update-match-groups ] keep swap ]
135 [ options>> options>string ] bi <fixup-regexp> ;
137 : fixup-end? ( text -- ? )
138 { [ regexp? ] [ #match-groups ] } 1&& ;
140 : fixup-end/text-matches? ( string regexp rule -- match-count/f )
141 [ >string ] 2dip [ [ match-start dup ] keep ] dip pick [
142 end>> [ [ fixup-end ] change-text drop ] [ 2drop ] if*
145 ] if dup [ to>> ] when ;
149 :: rule-start-matches? ( rule -- match-count/f )
150 rule start>> dup rule can-match-here? [
151 rest-of-line swap text>>
153 rule fixup-end/text-matches?
161 : rule-end-matches? ( rule -- match-count/f )
162 dup mark-following-rule? [
163 [ start>> ] keep can-match-here? 0 and
165 [ end>> dup ] keep can-match-here? [
167 swap text>> context get end>> or
176 : get-always-rules ( ruleset -- vector/f )
179 : get-char-rules ( char ruleset -- vector/f )
180 [ ch>upper ] dip rules>> at ;
182 : get-rules ( char ruleset -- seq )
183 [ get-char-rules ] [ get-always-rules ] bi [ append ] when* ;
185 GENERIC: handle-rule-start ( match-count rule -- )
187 GENERIC: handle-rule-end ( match-count rule -- )
189 : find-escape-rule ( -- rule )
191 in-rule-set>> escape-rule>> [ ] [
192 parent>> in-rule-set>>
193 dup [ escape-rule>> ] when
196 : check-escape-rule ( rule -- ? )
197 escape-rule>> [ find-escape-rule ] unless*
199 dup rule-start-matches? [
200 swap handle-rule-start
201 delegate-end-escaped? toggle
208 : check-every-rule ( -- ? )
209 current-char current-rule-set get-rules
210 [ rule-start-matches? ] map-find
211 [ handle-rule-start t ] [ drop f ] if* ;
215 dup rule-end-matches?
216 [ swap handle-rule-end ] [ drop ] if*
219 : rule-match-token* ( rule -- id )
221 { f [ dup body-token>> ] }
222 { t [ current-rule-set default>> ] }
226 M: escape-rule handle-rule-start
229 process-escape? get [
231 position [ + ] change
234 M: seq-rule handle-rule-start
238 [ body-token>> next-token, ] keep
239 delegate>> [ push-context ] when* ;
241 UNION: abstract-span-rule span-rule eol-span-rule ;
243 M: abstract-span-rule handle-rule-start
247 [ rule-match-token* next-token, ] keep
249 dup context get in-rule<<
250 delegate>> push-context ;
252 M: span-rule handle-rule-end
255 M: mark-following-rule handle-rule-start
257 mark-token add-remaining-token
258 [ rule-match-token* next-token, ] keep
260 context get in-rule<< ;
262 M: mark-following-rule handle-rule-end
263 nip rule-match-token* prev-token,
264 f context get in-rule<< ;
266 M: mark-previous-rule handle-rule-start
269 dup body-token>> prev-token,
270 rule-match-token* next-token, ;
278 : check-end-delegate ( -- ? )
279 context get parent>> [
281 dup rule-end-matches? [
287 ] keep context get parent>> in-rule>>
288 rule-match-token* next-token,
290 seen-whitespace-end? on t
291 ] [ check-escape-rule ] if*
295 : handle-no-word-break ( -- )
296 context get parent>> [
298 dup no-word-break?>> [
299 rule-match-token* prev-token,
309 add-remaining-token ;
311 : (check-word-break) ( -- )
314 1 current-rule-set default>> next-token, ;
316 : rule-set-empty? ( ruleset -- ? )
317 [ rules>> ] [ keywords>> ] bi
318 [ assoc-empty? ] both? ;
320 : check-word-break ( -- ? )
321 current-char dup blank? [
324 seen-whitespace-end? get [
325 position get 1 + whitespace-end set
331 ! Micro-optimization with incorrect semantics; we keep
332 ! it here because jEdit mode files depend on it now...
333 current-rule-set rule-set-empty? [
339 current-rule-set rule-set-no-word-sep* member? [
345 seen-whitespace-end? on
348 delegate-end-escaped? off t ;
351 : mark-token-loop ( -- )
352 position get line get length < [
354 [ check-end-delegate ]
363 : mark-remaining ( -- )
364 line get length position set
367 : unwind-no-line-break ( -- )
368 context get parent>> [
377 : tokenize-line ( line-context line rules -- line-context' seq )