basis/xmode/rules/rules.factor

   1 USING: accessors xmode.tokens xmode.keyword-map kernel
   2 sequences vectors assocs strings memoize regexp unicode.case ;
   3 IN: xmode.rules
   4
   5 TUPLE: string-matcher string ignore-case? ;
   6
   7 C: <string-matcher> string-matcher
   8
   9 ! Based on org.gjt.sp.jedit.syntax.ParserRuleSet
  10 TUPLE: rule-set
  11 name
  12 props
  13 keywords
  14 rules
  15 imports
  16 terminate-char
  17 ignore-case?
  18 default
  19 escape-rule
  20 highlight-digits?
  21 digit-re
  22 no-word-sep
  23 finalized?
  24 ;
  25
  26 : <rule-set> ( -- ruleset )
  27     rule-set new
  28         H{ } clone >>rules
  29         H{ } clone >>props
  30         V{ } clone >>imports ;
  31
  32 MEMO: standard-rule-set ( id -- ruleset )
  33     <rule-set> swap >>default ;
  34
  35 : import-rule-set ( import ruleset -- )
  36     imports>> push ;
  37
  38 : inverted-index ( hashes key index -- )
  39     [ swapd push-at ] 2curry each ;
  40
  41 : ?push-all ( seq1 seq2 -- seq1+seq2 )
  42     [
  43         over [ >r V{ } like r> over push-all ] [ nip ] if
  44     ] when* ;
  45
  46 : rule-set-no-word-sep* ( ruleset -- str )
  47     [ no-word-sep>> ]
  48     [ keywords>> ] bi
  49     dup [ keyword-map-no-word-sep* ] when
  50     "_" 3append ;
  51
  52 ! Match restrictions
  53 TUPLE: matcher text at-line-start? at-whitespace-end? at-word-start? ;
  54
  55 C: <matcher> matcher
  56
  57 ! Based on org.gjt.sp.jedit.syntax.ParserRule
  58 TUPLE: rule
  59 no-line-break?
  60 no-word-break?
  61 no-escape?
  62 start
  63 end
  64 match-token
  65 body-token
  66 delegate
  67 chars
  68 ;
  69
  70 TUPLE: seq-rule < rule ;
  71
  72 TUPLE: span-rule < rule ;
  73
  74 TUPLE: eol-span-rule < rule ;
  75
  76 : init-span ( rule -- )
  77     dup delegate>> [ drop ] [
  78         dup body-token>> standard-rule-set
  79         swap (>>delegate)
  80     ] if ;
  81
  82 : init-eol-span ( rule -- )
  83     dup init-span
  84     t >>no-line-break? drop ;
  85
  86 TUPLE: mark-following-rule < rule ;
  87
  88 TUPLE: mark-previous-rule < rule ;
  89
  90 TUPLE: escape-rule < rule ;
  91
  92 : <escape-rule> ( string -- rule )
  93     f <string-matcher> f f f <matcher>
  94     escape-rule new swap >>start ;
  95
  96 GENERIC: text-hash-char ( text -- ch )
  97
  98 M: f text-hash-char ;
  99
 100 M: string-matcher text-hash-char string>> first ;
 101
 102 M: regexp text-hash-char drop f ;
 103
 104 : rule-chars* ( rule -- string )
 105     [ chars>> ] [ start>> ] bi text>>
 106     text-hash-char [ suffix ] when* ;
 107
 108 : add-rule ( rule ruleset -- )
 109     >r dup rule-chars* >upper swap
 110     r> rules>> inverted-index ;
 111
 112 : add-escape-rule ( string ruleset -- )
 113     over [
 114         [ <escape-rule> ] dip
 115         2dup (>>escape-rule)
 116         add-rule
 117     ] [
 118         2drop
 119     ] if ;