basis/xmode/marker/marker.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   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 ;
   8
   9 IN: xmode.marker
  10
  11 ! Next two words copied from parser-combinators
  12 ! Just like head?, but they optionally ignore case
  13
  14 : string= ( str1 str2 ignore-case -- ? )
  15     [ [ >upper ] bi@ ] when sequence= ;
  16
  17 : string-head? ( str1 str2 ignore-case -- ? )
  18     2over shorter?
  19     [ 3drop f ] [
  20         [
  21             [ nip ]
  22             [ length head-slice ] 2bi
  23         ] dip string=
  24     ] if ;
  25
  26 ! Based on org.gjt.sp.jedit.syntax.TokenMarker
  27
  28 : current-keyword ( -- string )
  29     last-offset get position get line get subseq ;
  30
  31 : keyword-number? ( keyword -- ? )
  32     {
  33         [ current-rule-set highlight-digits?>> ]
  34         [ dup [ digit? ] any? ]
  35         [
  36             dup [ digit? ] all? [
  37                 current-rule-set digit-re>>
  38                 [ dupd matches? ] [ f ] if*
  39             ] unless*
  40         ]
  41     } 0&& nip ;
  42
  43 : mark-number ( keyword -- id )
  44     keyword-number? DIGIT and ;
  45
  46 : mark-keyword ( keyword -- id )
  47     current-rule-set keywords>> at ;
  48
  49 : add-remaining-token ( -- )
  50     current-rule-set default>> prev-token, ;
  51
  52 : mark-token ( -- )
  53     current-keyword
  54     dup mark-number [ ] [ mark-keyword ] ?if
  55     [ prev-token, ] when* ;
  56
  57 : current-char ( -- char )
  58     position get line get nth ;
  59
  60 GENERIC: match-position ( rule -- n )
  61
  62 M: mark-previous-rule match-position drop last-offset get ;
  63
  64 M: rule match-position drop position get ;
  65
  66 : can-match-here? ( matcher rule -- ? )
  67     match-position {
  68         [ over ]
  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 ]
  72     } 0&& 2nip ;
  73
  74 : rest-of-line ( -- str )
  75     line get position get tail-slice ;
  76
  77 : match-start ( string regexp -- slice/f )
  78     first-match dup [ dup from>> 0 = [ drop f ] unless ] when ;
  79
  80 GENERIC: text-matches? ( string text -- match-count/f )
  81
  82 M: f text-matches?
  83     2drop f ;
  84
  85 M: string-matcher text-matches?
  86     [ string>> ] [ ignore-case?>> ] bi
  87     [ string-head? ] keepd length and ;
  88
  89 M: regexp text-matches?
  90     [ >string ] dip match-start dup [ to>> ] when ;
  91
  92 <PRIVATE
  93
  94 ! XXX: Terrible inefficient regexp match group support
  95
  96 : #match-groups ( regexp -- n/f )
  97     raw>> [ CHAR: ( = ] count [ f ] when-zero ;
  98
  99 : nth-index ( n obj seq -- i )
 100     [ = dup [ drop 1 - dup 0 < ] when ] with find drop nip ;
 101
 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@ ;
 106
 107 : skip-first-match ( match regexp -- tailseq )
 108     first-match [ seq>> ] [ to>> ] bi tail ;
 109
 110 : nth-match ( match regexp n -- slice/f )
 111     match-group-regexp [ skip-first-match ] [ first-match ] bi* ;
 112
 113 : update-match-group ( str match regexp n -- str' )
 114     [ nth-match ] [ CHAR: 1 + "$%c" sprintf ] bi swap replace ;
 115
 116 : update-match-groups ( str match regexp -- str' )
 117     [ >string ] dip
 118     dup #match-groups [ update-match-group ] 2with each-integer ;
 119
 120 GENERIC: fixup-end ( match regexp end -- end' )
 121
 122 M: string-matcher fixup-end
 123     [ string>> -rot update-match-groups ]
 124     [ ignore-case?>> ] bi <string-matcher> ;
 125
 126 M: regexp fixup-end
 127     [ raw>> [ -rot update-match-groups ] keep swap ]
 128     [ options>> options>string ] bi <optioned-regexp> {
 129         [ parse-tree>> ] [ options>> ] [ dfa>> ] [ next-match>> ]
 130     } cleave regexp boa ;
 131
 132 : fixup-end? ( text -- ? )
 133     { [ regexp? ] [ #match-groups ] } 1&& ;
 134
 135 : fixup-end/text-matches? ( string regexp rule -- match-count/f )
 136     [ >string ] 2dip [ [ match-start dup ] keep ] dip pick [
 137         end>> [ [ fixup-end ] change-text drop ] [ 2drop ] if*
 138     ] [
 139         3drop
 140     ] if dup [ to>> ] when ;
 141
 142 PRIVATE>
 143
 144 :: rule-start-matches? ( rule -- match-count/f )
 145     rule start>> dup rule can-match-here? [
 146         rest-of-line swap text>>
 147         dup fixup-end? [
 148             rule fixup-end/text-matches?
 149         ] [
 150             text-matches?
 151         ] if
 152     ] [
 153         drop f
 154     ] if ;
 155
 156 : rule-end-matches? ( rule -- match-count/f )
 157     dup mark-following-rule? [
 158         [ start>> ] keep can-match-here? 0 and
 159     ] [
 160         [ end>> dup ] keep can-match-here? [
 161             rest-of-line
 162             swap text>> context get end>> or
 163             text-matches?
 164         ] [
 165             drop f
 166         ] if
 167     ] if ;
 168
 169 DEFER: get-rules
 170
 171 : get-always-rules ( vector/f ruleset -- vector/f )
 172     f swap rules>> at ?push-all ;
 173
 174 : get-char-rules ( vector/f char ruleset -- vector/f )
 175     [ ch>upper ] dip rules>> at ?push-all ;
 176
 177 : get-rules ( char ruleset -- seq )
 178     [ f ] 2dip [ get-char-rules ] keep get-always-rules ;
 179
 180 GENERIC: handle-rule-start ( match-count rule -- )
 181
 182 GENERIC: handle-rule-end ( match-count rule -- )
 183
 184 : find-escape-rule ( -- rule )
 185     context get dup
 186     in-rule-set>> escape-rule>> [ ] [
 187         parent>> in-rule-set>>
 188         dup [ escape-rule>> ] when
 189     ] ?if ;
 190
 191 : check-escape-rule ( rule -- ? )
 192     escape-rule>> [ find-escape-rule ] unless*
 193     dup [
 194         dup rule-start-matches? [
 195             swap handle-rule-start
 196             delegate-end-escaped? toggle
 197             t
 198         ] [
 199             drop f
 200         ] if*
 201     ] when ;
 202
 203 : check-every-rule ( -- ? )
 204     current-char current-rule-set get-rules
 205     [ rule-start-matches? ] map-find
 206     [ handle-rule-start t ] [ drop f ] if* ;
 207
 208 : ?end-rule ( -- )
 209     current-rule [
 210         dup rule-end-matches?
 211         [ swap handle-rule-end ] [ drop ] if*
 212     ] when* ;
 213
 214 : rule-match-token* ( rule -- id )
 215     dup match-token>> {
 216         { f [ dup body-token>> ] }
 217         { t [ current-rule-set default>> ] }
 218         [ ]
 219     } case nip ;
 220
 221 M: escape-rule handle-rule-start
 222     drop
 223     ?end-rule
 224     process-escape? get [
 225         escaped? toggle
 226         position [ + ] change
 227     ] [ drop ] if ;
 228
 229 M: seq-rule handle-rule-start
 230     ?end-rule
 231     mark-token
 232     add-remaining-token
 233     [ body-token>> next-token, ] keep
 234     delegate>> [ push-context ] when* ;
 235
 236 UNION: abstract-span-rule span-rule eol-span-rule ;
 237
 238 M: abstract-span-rule handle-rule-start
 239     ?end-rule
 240     mark-token
 241     add-remaining-token
 242     [ rule-match-token* next-token, ] keep
 243     ! ... end subst ...
 244     dup context get in-rule<<
 245     delegate>> push-context ;
 246
 247 M: span-rule handle-rule-end
 248     2drop ;
 249
 250 M: mark-following-rule handle-rule-start
 251     ?end-rule
 252     mark-token add-remaining-token
 253     [ rule-match-token* next-token, ] keep
 254     f context get end<<
 255     context get in-rule<< ;
 256
 257 M: mark-following-rule handle-rule-end
 258     nip rule-match-token* prev-token,
 259     f context get in-rule<< ;
 260
 261 M: mark-previous-rule handle-rule-start
 262     ?end-rule
 263     mark-token
 264     dup body-token>> prev-token,
 265     rule-match-token* next-token, ;
 266
 267 : do-escaped ( -- )
 268     escaped? get [
 269         escaped? off
 270         ! ...
 271     ] when ;
 272
 273 : check-end-delegate ( -- ? )
 274     context get parent>> [
 275         in-rule>> [
 276             dup rule-end-matches? [
 277                 [
 278                     swap handle-rule-end
 279                     ?end-rule
 280                     mark-token
 281                     add-remaining-token
 282                 ] keep context get parent>> in-rule>>
 283                 rule-match-token* next-token,
 284                 pop-context
 285                 seen-whitespace-end? on t
 286             ] [ check-escape-rule ] if*
 287         ] [ f ] if*
 288     ] [ f ] if* ;
 289
 290 : handle-no-word-break ( -- )
 291     context get parent>> [
 292         in-rule>> [
 293             dup no-word-break?>> [
 294                 rule-match-token* prev-token,
 295                 pop-context
 296             ] [ drop ] if
 297         ] when*
 298     ] when* ;
 299
 300 : check-rule ( -- )
 301     ?end-rule
 302     handle-no-word-break
 303     mark-token
 304     add-remaining-token ;
 305
 306 : (check-word-break) ( -- )
 307     check-rule
 308
 309     1 current-rule-set default>> next-token, ;
 310
 311 : rule-set-empty? ( ruleset -- ? )
 312     [ rules>> ] [ keywords>> ] bi
 313     [ assoc-empty? ] both? ;
 314
 315 : check-word-break ( -- ? )
 316     current-char dup blank? [
 317         drop
 318
 319         seen-whitespace-end? get [
 320             position get 1 + whitespace-end set
 321         ] unless
 322
 323         (check-word-break)
 324
 325     ] [
 326         ! Micro-optimization with incorrect semantics; we keep
 327         ! it here because jEdit mode files depend on it now...
 328         current-rule-set rule-set-empty? [
 329             drop
 330         ] [
 331             dup alpha? [
 332                 drop
 333             ] [
 334                 current-rule-set rule-set-no-word-sep* member? [
 335                     (check-word-break)
 336                 ] unless
 337             ] if
 338         ] if
 339
 340         seen-whitespace-end? on
 341     ] if
 342     escaped? off
 343     delegate-end-escaped? off t ;
 344
 345
 346 : mark-token-loop ( -- )
 347     position get line get length < [
 348         {
 349             [ check-end-delegate ]
 350             [ check-every-rule ]
 351             [ check-word-break ]
 352         } 0|| drop
 353
 354         position inc
 355         mark-token-loop
 356     ] when ;
 357
 358 : mark-remaining ( -- )
 359     line get length position set
 360     check-rule ;
 361
 362 : unwind-no-line-break ( -- )
 363     context get parent>> [
 364         in-rule>> [
 365             no-line-break?>> [
 366                 pop-context
 367                 unwind-no-line-break
 368             ] when
 369         ] when*
 370     ] when* ;
 371
 372 : tokenize-line ( line-context line rules -- line-context' seq )
 373     [
 374         "MAIN" of -rot
 375         init-token-marker
 376         mark-token-loop
 377         mark-remaining
 378         unwind-no-line-break
 379         context get
 380     ] { } make ;