basis/xmode/rules/rules.factor

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