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 ! XXX: support named-capturing groups?
98 : group-start ( i raw -- n/f )
99 [ CHAR: ( -rot index-from ] keep 2dup
100 { [ drop ] [ [ 1 + ] dip ?nth CHAR: ? = ] } 2&&
101 [ [ 1 + ] dip group-start ] [ drop ] if ;
103 : nth-group-start ( n raw -- n )
104 [ -1 ] 2dip '[ dup [ 1 + _ group-start ] when ] times ;
106 : nth-group ( n raw -- before nth )
107 [ nth-group-start ] keep swap cut CHAR: ) over index 1 + head ;
109 : match-group-regexp ( regexp n -- skip-regexp match-regexp )
110 [ [ options>> options>string ] [ raw>> ] bi ] dip swap
111 nth-group rot '[ _ H{ } [ <optioned-regexp> ] 2cache ] bi@ ;
113 : skip-first-match ( match regexp -- tailseq )
114 [ >string ] dip first-match [ seq>> ] [ to>> ] bi tail ;
116 : nth-match ( match regexp n -- slice/f )
117 match-group-regexp [ skip-first-match ] [ match-start ] bi* ;
119 : update-match-groups ( str match regexp -- str' )
120 pick CHAR: $ swap index [
121 R/ [$]\d/ [ second CHAR: 0 - nth-match ] 2with re-replace-with
124 GENERIC: fixup-end ( match regexp end -- end' )
126 M: string-matcher fixup-end
127 [ string>> -rot update-match-groups ]
128 [ ignore-case?>> ] bi <string-matcher> ;
130 MEMO: <fixup-regexp> ( raw matched options -- regexp )
132 [ parse-tree>> ] [ options>> ] [ dfa>> ] [ next-match>> ]
133 } cleave regexp boa ;
136 [ raw>> [ -rot update-match-groups ] keep swap ]
137 [ options>> options>string ] bi <fixup-regexp> ;
139 : fixup-end? ( text -- ? )
140 { [ regexp? ] [ 0 swap raw>> group-start ] } 1&& ;
142 : fixup-end/text-matches? ( string regexp rule -- match-count/f )
143 [ >string ] 2dip [ [ match-start dup ] keep ] dip pick [
144 end>> [ [ fixup-end ] change-text drop ] [ 2drop ] if*
147 ] if dup [ to>> ] when ;
151 :: rule-start-matches? ( rule -- match-count/f )
152 rule start>> dup rule can-match-here? [
153 rest-of-line swap text>>
155 rule fixup-end/text-matches?
163 : rule-end-matches? ( rule -- match-count/f )
164 dup mark-following-rule? [
165 [ start>> ] keep can-match-here? 0 and
167 [ end>> dup ] keep can-match-here? [
169 swap text>> context get end>> or
178 : get-always-rules ( ruleset -- vector/f )
181 : get-char-rules ( char ruleset -- vector/f )
182 [ ch>upper ] dip rules>> at ;
184 : get-rules ( char ruleset -- seq )
185 [ get-char-rules ] [ get-always-rules ] bi [ append ] when* ;
187 GENERIC: handle-rule-start ( match-count rule -- )
189 GENERIC: handle-rule-end ( match-count rule -- )
191 : find-escape-rule ( -- rule )
193 in-rule-set>> escape-rule>> [ ] [
194 parent>> in-rule-set>>
195 dup [ escape-rule>> ] when
198 : check-escape-rule ( rule -- ? )
199 escape-rule>> [ find-escape-rule ] unless*
201 dup rule-start-matches? [
202 swap handle-rule-start
203 delegate-end-escaped? toggle
210 : check-every-rule ( -- ? )
211 current-char current-rule-set get-rules
212 [ rule-start-matches? ] map-find
213 [ handle-rule-start t ] [ drop f ] if* ;
217 dup rule-end-matches?
218 [ swap handle-rule-end ] [ drop ] if*
221 : rule-match-token* ( rule -- id )
223 { f [ dup body-token>> ] }
224 { t [ current-rule-set default>> ] }
228 M: escape-rule handle-rule-start
231 process-escape? get [
233 position [ + ] change
236 M: seq-rule handle-rule-start
240 [ body-token>> next-token, ] keep
241 delegate>> [ push-context ] when* ;
243 UNION: abstract-span-rule span-rule eol-span-rule ;
245 M: abstract-span-rule handle-rule-start
249 [ rule-match-token* next-token, ] keep
251 dup context get in-rule<<
252 delegate>> push-context ;
254 M: span-rule handle-rule-end
257 M: mark-following-rule handle-rule-start
259 mark-token add-remaining-token
260 [ rule-match-token* next-token, ] keep
262 context get in-rule<< ;
264 M: mark-following-rule handle-rule-end
265 nip rule-match-token* prev-token,
266 f context get in-rule<< ;
268 M: mark-previous-rule handle-rule-start
271 dup body-token>> prev-token,
272 rule-match-token* next-token, ;
280 : check-end-delegate ( -- ? )
281 context get parent>> [
283 dup rule-end-matches? [
289 ] keep context get parent>> in-rule>>
290 rule-match-token* next-token,
292 seen-whitespace-end? on t
293 ] [ check-escape-rule ] if*
297 : handle-no-word-break ( -- )
298 context get parent>> [
300 dup no-word-break?>> [
301 rule-match-token* prev-token,
311 add-remaining-token ;
313 : (check-word-break) ( -- )
316 1 current-rule-set default>> next-token, ;
318 : rule-set-empty? ( ruleset -- ? )
319 [ rules>> ] [ keywords>> ] bi
320 [ assoc-empty? ] both? ;
322 : check-word-break ( -- ? )
323 current-char dup blank? [
326 seen-whitespace-end? get [
327 position get 1 + whitespace-end set
333 ! Micro-optimization with incorrect semantics; we keep
334 ! it here because jEdit mode files depend on it now...
335 current-rule-set rule-set-empty? [
341 current-rule-set rule-set-no-word-sep* member? [
347 seen-whitespace-end? on
350 delegate-end-escaped? off t ;
353 : mark-token-loop ( -- )
354 position get line get length < [
356 [ check-end-delegate ]
365 : mark-remaining ( -- )
366 line get length position set
369 : unwind-no-line-break ( -- )
370 context get parent>> [
379 : tokenize-line ( line-context line rules -- line-context' seq )