1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel namespaces make xmode.rules xmode.tokens
4 xmode.marker.state xmode.marker.context xmode.utilities
5 xmode.catalog sequences math assocs combinators strings
6 regexp splitting ascii combinators.short-circuit accessors ;
9 ! Next two words copied from parser-combinators
10 ! Just like head?, but they optionally ignore case
12 : string= ( str1 str2 ignore-case -- ? )
13 [ [ >upper ] bi@ ] when sequence= ;
15 : string-head? ( str1 str2 ignore-case -- ? )
20 [ length head-slice ] 2bi
24 ! Based on org.gjt.sp.jedit.syntax.TokenMarker
26 : current-keyword ( -- string )
27 last-offset get position get line get subseq ;
29 : keyword-number? ( keyword -- ? )
31 [ current-rule-set highlight-digits?>> ]
32 [ dup [ digit? ] any? ]
35 current-rule-set digit-re>>
36 dup [ dupd matches? ] [ drop f ] if
41 : mark-number ( keyword -- id )
42 keyword-number? DIGIT and ;
44 : mark-keyword ( keyword -- id )
45 current-rule-set keywords>> at ;
47 : add-remaining-token ( -- )
48 current-rule-set default>> prev-token, ;
52 dup mark-number [ ] [ mark-keyword ] ?if
53 [ prev-token, ] when* ;
55 : current-char ( -- char )
56 position get line get nth ;
58 GENERIC: match-position ( rule -- n )
60 M: mark-previous-rule match-position drop last-offset get ;
62 M: rule match-position drop position get ;
64 : can-match-here? ( matcher rule -- ? )
67 [ over at-line-start?>> over zero? implies ]
68 [ over at-whitespace-end?>> over whitespace-end get = implies ]
69 [ over at-word-start?>> over last-offset get = implies ]
72 : rest-of-line ( -- str )
73 line get position get tail-slice ;
75 GENERIC: text-matches? ( string text -- match-count/f )
80 M: string-matcher text-matches?
82 [ string>> ] [ ignore-case?>> ] bi string-head?
83 ] keep string>> length and ;
85 M: regexp text-matches?
86 [ >string ] dip first-match dup [ to>> ] when ;
88 : rule-start-matches? ( rule -- match-count/f )
89 [ start>> dup ] keep can-match-here? [
90 rest-of-line swap text>> text-matches?
95 : rule-end-matches? ( rule -- match-count/f )
96 dup mark-following-rule? [
97 dup start>> swap can-match-here? 0 and
99 [ end>> dup ] keep can-match-here? [
101 swap text>> context get end>> or
110 : get-always-rules ( vector/f ruleset -- vector/f )
111 f swap rules>> at ?push-all ;
113 : get-char-rules ( vector/f char ruleset -- vector/f )
114 [ ch>upper ] dip rules>> at ?push-all ;
116 : get-rules ( char ruleset -- seq )
117 [ f ] 2dip [ get-char-rules ] keep get-always-rules ;
119 GENERIC: handle-rule-start ( match-count rule -- )
121 GENERIC: handle-rule-end ( match-count rule -- )
123 : find-escape-rule ( -- rule )
125 in-rule-set>> escape-rule>> [ ] [
126 parent>> in-rule-set>>
127 dup [ escape-rule>> ] when
130 : check-escape-rule ( rule -- ? )
132 find-escape-rule dup [
133 dup rule-start-matches? dup [
134 swap handle-rule-start
135 delegate-end-escaped? [ not ] change
143 : check-every-rule ( -- ? )
144 current-char current-rule-set get-rules
145 [ rule-start-matches? ] map-find
146 dup [ handle-rule-start t ] [ 2drop f ] if ;
150 dup rule-end-matches?
151 dup [ swap handle-rule-end ] [ 2drop ] if
154 : rule-match-token* ( rule -- id )
156 { f [ dup body-token>> ] }
157 { t [ current-rule-set default>> ] }
161 M: escape-rule handle-rule-start
164 process-escape? get [
165 escaped? [ not ] change
166 position [ + ] change
169 M: seq-rule handle-rule-start
173 [ body-token>> next-token, ] keep
174 delegate>> [ push-context ] when* ;
176 UNION: abstract-span-rule span-rule eol-span-rule ;
178 M: abstract-span-rule handle-rule-start
182 [ rule-match-token* next-token, ] keep
184 dup context get (>>in-rule)
185 delegate>> push-context ;
187 M: span-rule handle-rule-end
190 M: mark-following-rule handle-rule-start
192 mark-token add-remaining-token
193 [ rule-match-token* next-token, ] keep
194 f context get (>>end)
195 context get (>>in-rule) ;
197 M: mark-following-rule handle-rule-end
198 nip rule-match-token* prev-token,
199 f context get (>>in-rule) ;
201 M: mark-previous-rule handle-rule-start
204 dup body-token>> prev-token,
205 rule-match-token* next-token, ;
213 : check-end-delegate ( -- ? )
214 context get parent>> [
216 dup rule-end-matches? dup [
222 ] keep context get parent>> in-rule>>
223 rule-match-token* next-token,
225 seen-whitespace-end? on t
226 ] [ drop check-escape-rule ] if
230 : handle-no-word-break ( -- )
231 context get parent>> [
233 dup no-word-break?>> [
234 rule-match-token* prev-token,
244 add-remaining-token ;
246 : (check-word-break) ( -- )
249 1 current-rule-set default>> next-token, ;
251 : rule-set-empty? ( ruleset -- ? )
252 [ rules>> ] [ keywords>> ] bi
253 [ assoc-empty? ] bi@ and ;
255 : check-word-break ( -- ? )
256 current-char dup blank? [
259 seen-whitespace-end? get [
260 position get 1 + whitespace-end set
266 ! Micro-optimization with incorrect semantics; we keep
267 ! it here because jEdit mode files depend on it now...
268 current-rule-set rule-set-empty? [
274 current-rule-set rule-set-no-word-sep* member? [
280 seen-whitespace-end? on
283 delegate-end-escaped? off t ;
286 : mark-token-loop ( -- )
287 position get line get length < [
289 [ check-end-delegate ]
298 : mark-remaining ( -- )
299 line get length position set
302 : unwind-no-line-break ( -- )
303 context get parent>> [
312 : tokenize-line ( line-context line rules -- line-context' seq )