basis/xmode/rules/rules.factor

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