extra/regexp/regexp.factor

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