extra/xmode/rules/rules.factor

   1 USING: xmode.tokens xmode.keyword-map kernel
   2 sequences vectors assocs strings memoize regexp ;
   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 : init-rule-set ( ruleset -- )
  27     #! Call after constructor.
  28     >r H{ } clone H{ } clone V{ } clone r>
  29     {
  30         set-rule-set-rules
  31         set-rule-set-props
  32         set-rule-set-imports
  33     } set-slots ;
  34
  35 : <rule-set> ( -- ruleset )
  36     rule-set construct-empty dup init-rule-set ;
  37
  38 MEMO: standard-rule-set ( id -- ruleset )
  39     <rule-set> [ set-rule-set-default ] keep ;
  40
  41 : import-rule-set ( import ruleset -- )
  42     rule-set-imports push ;
  43
  44 : inverted-index ( hashes key index -- )
  45     [ swapd [ ?push ] change-at ] 2curry each ;
  46
  47 : ?push-all ( seq1 seq2 -- seq1+seq2 )
  48     [
  49         over [ >r V{ } like r> over push-all ] [ nip ] if
  50     ] when* ;
  51
  52 : rule-set-no-word-sep* ( ruleset -- str )
  53     dup rule-set-no-word-sep
  54     swap rule-set-keywords dup [ keyword-map-no-word-sep* ] when
  55     "_" 3append ;
  56
  57 ! Match restrictions
  58 TUPLE: matcher text at-line-start? at-whitespace-end? at-word-start? ;
  59
  60 C: <matcher> matcher
  61
  62 ! Based on org.gjt.sp.jedit.syntax.ParserRule
  63 TUPLE: rule
  64 no-line-break?
  65 no-word-break?
  66 no-escape?
  67 start
  68 end
  69 match-token
  70 body-token
  71 delegate
  72 chars
  73 ;
  74
  75 : construct-rule ( class -- rule )
  76     >r rule construct-empty r> construct-delegate ; inline
  77
  78 TUPLE: seq-rule ;
  79
  80 TUPLE: span-rule ;
  81
  82 TUPLE: eol-span-rule ;
  83
  84 : init-span ( rule -- )
  85     dup rule-delegate [ drop ] [
  86         dup rule-body-token standard-rule-set
  87         swap set-rule-delegate
  88     ] if ;
  89
  90 : init-eol-span ( rule -- )
  91     dup init-span
  92     t swap set-rule-no-line-break? ;
  93
  94 TUPLE: mark-following-rule ;
  95
  96 TUPLE: mark-previous-rule ;
  97
  98 TUPLE: escape-rule ;
  99
 100 : <escape-rule> ( string -- rule )
 101     f <string-matcher> f f f <matcher>
 102     escape-rule construct-rule
 103     [ set-rule-start ] keep ;
 104
 105 GENERIC: text-hash-char ( text -- ch )
 106
 107 M: f text-hash-char ;
 108
 109 M: string-matcher text-hash-char string-matcher-string first ;
 110
 111 M: regexp text-hash-char drop f ;
 112
 113 : rule-chars* ( rule -- string )
 114     dup rule-chars
 115     swap rule-start matcher-text
 116     text-hash-char [ add ] when* ;
 117
 118 : add-rule ( rule ruleset -- )
 119     >r dup rule-chars* >upper swap
 120     r> rule-set-rules inverted-index ;
 121
 122 : add-escape-rule ( string ruleset -- )
 123     over [
 124         >r <escape-rule> r>
 125         2dup set-rule-set-escape-rule
 126         add-rule
 127     ] [
 128         2drop
 129     ] if ;