extra/regexp/regexp.factor

   1 USING: arrays combinators kernel lists math math.parser
   2 namespaces parser parser-combinators parser-combinators.simple
   3 promises quotations sequences combinators.lib strings math.order
   4 assocs prettyprint.backend memoize unicode.case unicode.categories ;
   5 USE: io
   6 IN: regexp
   7
   8 <PRIVATE
   9
  10 SYMBOL: ignore-case?
  11
  12 : char=-quot ( ch -- quot )
  13     ignore-case? get
  14     [ ch>upper [ swap ch>upper = ] ] [ [ = ] ] if
  15     curry ;
  16
  17 : char-between?-quot ( ch1 ch2 -- quot )
  18     ignore-case? get
  19     [ [ ch>upper ] bi@ [ >r >r ch>upper r> r> between? ] ]
  20     [ [ between? ] ]
  21     if 2curry ;
  22
  23 : or-predicates ( quots -- quot )
  24     [ \ dup prefix ] map [ [ t ] ] f short-circuit \ nip suffix ;
  25
  26 : <@literal ( parser obj -- action ) [ nip ] curry <@ ;
  27
  28 : <@delay ( parser quot -- action ) [ curry ] curry <@ ;
  29
  30 PRIVATE>
  31
  32 : ascii? ( n -- ? )
  33     0 HEX: 7f between? ;
  34
  35 : octal-digit? ( n -- ? )
  36     CHAR: 0 CHAR: 7 between? ;
  37
  38 : decimal-digit? ( n -- ? )
  39     CHAR: 0 CHAR: 9 between? ;
  40
  41 : hex-digit? ( n -- ? )
  42     dup decimal-digit?
  43     over CHAR: a CHAR: f between? or
  44     swap CHAR: A CHAR: F between? or ;
  45
  46 : control-char? ( n -- ? )
  47     dup 0 HEX: 1f between?
  48     swap HEX: 7f = or ;
  49
  50 : punct? ( n -- ? )
  51     "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ;
  52
  53 : c-identifier-char? ( ch -- ? )
  54     dup alpha? swap CHAR: _ = or ;
  55
  56 : java-blank? ( n -- ? )
  57     {
  58         CHAR: \s
  59         CHAR: \t CHAR: \n CHAR: \r
  60         HEX: c HEX: 7 HEX: 1b
  61     } member? ;
  62
  63 : java-printable? ( n -- ? )
  64     dup alpha? swap punct? or ;
  65
  66 : 'ordinary-char' ( -- parser )
  67     [ "\\^*+?|(){}[$" member? not ] satisfy
  68     [ char=-quot ] <@ ;
  69
  70 : 'octal-digit' ( -- parser ) [ octal-digit? ] satisfy ;
  71
  72 : 'octal' ( -- parser )
  73     "0" token 'octal-digit' 1 3 from-m-to-n &>
  74     [ oct> ] <@ ;
  75
  76 : 'hex-digit' ( -- parser ) [ hex-digit? ] satisfy ;
  77
  78 : 'hex' ( -- parser )
  79     "x" token 'hex-digit' 2 exactly-n &>
  80     "u" token 'hex-digit' 6 exactly-n &> <|>
  81     [ hex> ] <@ ;
  82
  83 : satisfy-tokens ( assoc -- parser )
  84     [ >r token r> <@literal ] { } assoc>map <or-parser> ;
  85
  86 : 'simple-escape-char' ( -- parser )
  87     {
  88         { "\\" CHAR: \\ }
  89         { "t"  CHAR: \t }
  90         { "n"  CHAR: \n }
  91         { "r"  CHAR: \r }
  92         { "f"  HEX: c   }
  93         { "a"  HEX: 7   }
  94         { "e"  HEX: 1b  }
  95     } [ char=-quot ] assoc-map satisfy-tokens ;
  96
  97 : 'predefined-char-class' ( -- parser )
  98     {
  99         { "d" [ digit? ] }
 100         { "D" [ digit? not ] }
 101         { "s" [ java-blank? ] }
 102         { "S" [ java-blank? not ] }
 103         { "w" [ c-identifier-char? ] }
 104         { "W" [ c-identifier-char? not ] }
 105     } satisfy-tokens ;
 106
 107 : 'posix-character-class' ( -- parser )
 108     {
 109         { "Lower" [ letter? ] }
 110         { "Upper" [ LETTER? ] }
 111         { "ASCII" [ ascii? ] }
 112         { "Alpha" [ Letter? ] }
 113         { "Digit" [ digit? ] }
 114         { "Alnum" [ alpha? ] }
 115         { "Punct" [ punct? ] }
 116         { "Graph" [ java-printable? ] }
 117         { "Print" [ java-printable? ] }
 118         { "Blank" [ " \t" member? ] }
 119         { "Cntrl" [ control-char? ] }
 120         { "XDigit" [ hex-digit? ] }
 121         { "Space" [ java-blank? ] }
 122     } satisfy-tokens "p{" "}" surrounded-by ;
 123
 124 : 'simple-escape' ( -- parser )
 125     'octal'
 126     'hex' <|>
 127     "c" token [ LETTER? ] satisfy &> <|>
 128     any-char-parser <|>
 129     [ char=-quot ] <@ ;
 130
 131 : 'escape' ( -- parser )
 132     "\\" token
 133     'simple-escape-char'
 134     'predefined-char-class' <|>
 135     'posix-character-class' <|>
 136     'simple-escape' <|> &> ;
 137
 138 : 'any-char' ( -- parser )
 139     "." token [ drop t ] <@literal ;
 140
 141 : 'char' ( -- parser )
 142     'any-char' 'escape' 'ordinary-char' <|> <|> [ satisfy ] <@ ;
 143
 144 DEFER: 'regexp'
 145
 146 TUPLE: group-result str ;
 147
 148 C: <group-result> group-result
 149
 150 : 'non-capturing-group' ( -- parser )
 151     "?:" token 'regexp' &> ;
 152
 153 : 'positive-lookahead-group' ( -- parser )
 154     "?=" token 'regexp' &> [ ensure ] <@ ;
 155
 156 : 'negative-lookahead-group' ( -- parser )
 157     "?!" token 'regexp' &> [ ensure-not ] <@ ;
 158
 159 : 'simple-group' ( -- parser )
 160     'regexp' [ [ <group-result> ] <@ ] <@ ;
 161
 162 : 'group' ( -- parser )
 163     'non-capturing-group'
 164     'positive-lookahead-group'
 165     'negative-lookahead-group'
 166     'simple-group' <|> <|> <|>
 167     "(" ")" surrounded-by ;
 168
 169 : 'range' ( -- parser )
 170     [ CHAR: ] = not ] satisfy "-" token <&
 171     [ CHAR: ] = not ] satisfy <&>
 172     [ first2 char-between?-quot ] <@ ;
 173
 174 : 'character-class-term' ( -- parser )
 175     'range'
 176     'escape' <|>
 177     [ "\\]" member? not ] satisfy [ char=-quot ] <@ <|> ;
 178
 179 : 'positive-character-class' ( -- parser )
 180     "]" token [ CHAR: ] = ] <@literal 'character-class-term' <*> <&:>
 181     'character-class-term' <+> <|>
 182     [ or-predicates ] <@ ;
 183
 184 : 'negative-character-class' ( -- parser )
 185     "^" token 'positive-character-class' &>
 186     [ [ not ] append ] <@ ;
 187
 188 : 'character-class' ( -- parser )
 189     'negative-character-class' 'positive-character-class' <|>
 190     "[" "]" surrounded-by [ satisfy ] <@ ;
 191
 192 : 'escaped-seq' ( -- parser )
 193     any-char-parser <*>
 194     [ ignore-case? get <token-parser> ] <@
 195     "\\Q" "\\E" surrounded-by ;
 196
 197 : 'break' ( quot -- parser )
 198     satisfy ensure epsilon just <|> ;
 199
 200 : 'break-escape' ( -- parser )
 201     "$" token [ "\r\n" member? ] 'break' <@literal
 202     "\\b" token [ blank? ] 'break' <@literal <|>
 203     "\\B" token [ blank? not ] 'break' <@literal <|>
 204     "\\z" token epsilon just <@literal <|> ;
 205
 206 : 'simple' ( -- parser )
 207     'escaped-seq'
 208     'break-escape' <|>
 209     'group' <|>
 210     'character-class' <|>
 211     'char' <|> ;
 212
 213 : 'exactly-n' ( -- parser )
 214     'integer' [ exactly-n ] <@delay ;
 215
 216 : 'at-least-n' ( -- parser )
 217     'integer' "," token <& [ at-least-n ] <@delay ;
 218
 219 : 'at-most-n' ( -- parser )
 220     "," token 'integer' &> [ at-most-n ] <@delay ;
 221
 222 : 'from-m-to-n' ( -- parser )
 223     'integer' "," token <& 'integer' <&> [ first2 from-m-to-n ] <@delay ;
 224
 225 : 'greedy-interval' ( -- parser )
 226     'exactly-n' 'at-least-n' <|> 'at-most-n' <|> 'from-m-to-n' <|> ;
 227
 228 : 'interval' ( -- parser )
 229     'greedy-interval'
 230     'greedy-interval' "?" token <& [ "reluctant {}" print ] <@ <|>
 231     'greedy-interval' "+" token <& [ "possessive {}" print ] <@ <|>
 232     "{" "}" surrounded-by ;
 233
 234 : 'repetition' ( -- parser )
 235     ! Posessive
 236     "*+" token [ <!*> ] <@literal
 237     "++" token [ <!+> ] <@literal <|>
 238     "?+" token [ <!?> ] <@literal <|>
 239     ! Reluctant
 240     "*?" token [ <(*)> ] <@literal <|>
 241     "+?" token [ <(+)> ] <@literal <|>
 242     "??" token [ <(?)> ] <@literal <|>
 243     ! Greedy
 244     "*" token [ <*> ] <@literal <|>
 245     "+" token [ <+> ] <@literal <|>
 246     "?" token [ <?> ] <@literal <|> ;
 247
 248 : 'dummy' ( -- parser )
 249     epsilon [ ] <@literal ;
 250
 251 MEMO: 'term' ( -- parser )
 252     'simple'
 253     'repetition' 'interval' 'dummy' <|> <|> <&> [ first2 call ] <@
 254     <!+> [ <and-parser> ] <@ ;
 255
 256 LAZY: 'regexp' ( -- parser )
 257     'term' "|" token nonempty-list-of [ <or-parser> ] <@ ;
 258 !    "^" token 'term' "|" token nonempty-list-of [ <or-parser> ] <@
 259 !        &> [ "caret" print ] <@ <|>
 260 !    'term' "|" token nonempty-list-of [ <or-parser> ] <@
 261 !        "$" token <& [ "dollar" print ] <@ <|>
 262 !    "^" token 'term' "|" token nonempty-list-of [ <or-parser> ] <@ &>
 263 !        "$" token [ "caret dollar" print ] <@ <& <|> ;
 264
 265 TUPLE: regexp source parser ignore-case? ;
 266
 267 : <regexp> ( string ignore-case? -- regexp )
 268     [
 269         ignore-case? [
 270             dup 'regexp' just parse-1
 271         ] with-variable
 272     ] keep regexp boa ;
 273
 274 : do-ignore-case ( string regexp -- string regexp )
 275     dup regexp-ignore-case? [ >r >upper r> ] when ;
 276
 277 : matches? ( string regexp -- ? )
 278     do-ignore-case regexp-parser just parse nil? not ;
 279
 280 : match-head ( string regexp -- end )
 281     do-ignore-case regexp-parser parse dup nil?
 282     [ drop f ] [ car parse-result-unparsed slice-from ] if ;
 283
 284 ! Literal syntax for regexps
 285 : parse-options ( string -- ? )
 286     #! Lame
 287     {
 288         { "" [ f ] }
 289         { "i" [ t ] }
 290     } case ;
 291
 292 : parse-regexp ( accum end -- accum )
 293     lexer get dup skip-blank
 294     [ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
 295     lexer get dup still-parsing-line?
 296     [ (parse-token) parse-options ] [ drop f ] if
 297     <regexp> parsed ;
 298
 299 : R! CHAR: ! parse-regexp ; parsing
 300 : R" CHAR: " parse-regexp ; parsing
 301 : R# CHAR: # parse-regexp ; parsing
 302 : R' CHAR: ' parse-regexp ; parsing
 303 : R( CHAR: ) parse-regexp ; parsing
 304 : R/ CHAR: / parse-regexp ; parsing
 305 : R@ CHAR: @ parse-regexp ; parsing
 306 : R[ CHAR: ] parse-regexp ; parsing
 307 : R` CHAR: ` parse-regexp ; parsing
 308 : R{ CHAR: } parse-regexp ; parsing
 309 : R| CHAR: | parse-regexp ; parsing
 310
 311 : find-regexp-syntax ( string -- prefix suffix )
 312     {
 313         { "R/ "  "/"  }
 314         { "R! "  "!"  }
 315         { "R\" " "\"" }
 316         { "R# "  "#"  }
 317         { "R' "  "'"  }
 318         { "R( "  ")"  }
 319         { "R@ "  "@"  }
 320         { "R[ "  "]"  }
 321         { "R` "  "`"  }
 322         { "R{ "  "}"  }
 323         { "R| "  "|"  }
 324     } swap [ subseq? not nip ] curry assoc-find drop ;
 325
 326 M: regexp pprint*
 327     [
 328         dup regexp-source
 329         dup find-regexp-syntax swap % swap % %
 330         dup regexp-ignore-case? [ "i" % ] when
 331     ] "" make
 332     swap present-text ;