basis/regexp/regexp.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors combinators kernel math sequences strings
   4 sets assocs prettyprint.backend make lexer namespaces parser
   5 arrays fry regexp.backend regexp.utils regexp.parser regexp.nfa
   6 regexp.dfa regexp.traversal regexp.transition-tables splitting
   7 sorting ;
   8 IN: regexp
   9
  10 : default-regexp ( string -- regexp )
  11     regexp new
  12         swap >>raw
  13         <transition-table> >>nfa-table
  14         <transition-table> >>dfa-table
  15         <transition-table> >>minimized-table
  16         H{ } clone >>nfa-traversal-flags
  17         H{ } clone >>dfa-traversal-flags
  18         H{ } clone >>options
  19         reset-regexp ;
  20
  21 : construct-regexp ( regexp -- regexp' )
  22     {
  23         [ parse-regexp ]
  24         [ construct-nfa ]
  25         [ construct-dfa ]
  26         [ ]
  27     } cleave ;
  28
  29 : (match) ( string regexp -- dfa-traverser )
  30     <dfa-traverser> do-match ; inline
  31
  32 : match ( string regexp -- slice/f )
  33     (match) return-match ;
  34
  35 : match* ( string regexp -- slice/f captured-groups )
  36     (match) [ return-match ] [ captured-groups>> ] bi ;
  37
  38 : matches? ( string regexp -- ? )
  39     dupd match
  40     [ [ length ] bi@ = ] [ drop f ] if* ;
  41
  42 : match-head ( string regexp -- end/f ) match [ length ] [ f ] if* ;
  43
  44 : match-at ( string m regexp -- n/f finished? )
  45     [
  46         2dup swap length > [ 2drop f f ] [ tail-slice t ] if
  47     ] dip swap [ match-head f ] [ 2drop f t ] if ;
  48
  49 : match-range ( string m regexp -- a/f b/f )
  50     3dup match-at over [
  51         drop nip rot drop dupd +
  52     ] [
  53         [ 3drop drop f f ] [ drop [ 1+ ] dip match-range ] if
  54     ] if ;
  55
  56 : first-match ( string regexp -- slice/f )
  57     dupd 0 swap match-range rot over [ <slice> ] [ 3drop f ] if ;
  58
  59 : re-cut ( string regexp -- end/f start )
  60     dupd first-match
  61     [ split1-slice swap ] [ "" like f swap ] if* ;
  62
  63 : re-split ( string regexp -- seq )
  64     [ dup length 0 > ] swap '[ _ re-cut ] [ ] produce nip ;
  65
  66 : re-replace ( string regexp replacement -- result )
  67     [ re-split ] dip join ;
  68
  69 : next-match ( string regexp -- end/f match/f )
  70     dupd first-match dup
  71     [ [ split1-slice nip ] keep ] [ 2drop f f ] if ;
  72
  73 : all-matches ( string regexp -- seq )
  74     [ dup ] swap '[ _ next-match ] [ ] produce nip harvest ;
  75
  76 : count-matches ( string regexp -- n )
  77     all-matches length ;
  78
  79 <PRIVATE
  80
  81 : find-regexp-syntax ( string -- prefix suffix )
  82     {
  83         { "R/ "  "/"  }
  84         { "R! "  "!"  }
  85         { "R\" " "\"" }
  86         { "R# "  "#"  }
  87         { "R' "  "'"  }
  88         { "R( "  ")"  }
  89         { "R@ "  "@"  }
  90         { "R[ "  "]"  }
  91         { "R` "  "`"  }
  92         { "R{ "  "}"  }
  93         { "R| "  "|"  }
  94     } swap [ subseq? not nip ] curry assoc-find drop ;
  95
  96 ERROR: unknown-regexp-option option ;
  97
  98 : option>ch ( option -- string )
  99     {
 100         { case-insensitive [ CHAR: i ] }
 101         { multiline [ CHAR: m ] }
 102         { reversed-regexp [ CHAR: r ] }
 103         { dotall [ CHAR: s ] }
 104         [ unknown-regexp-option ]
 105     } case ;
 106
 107 : ch>option ( ch -- option )
 108     {
 109         { CHAR: i [ case-insensitive ] }
 110         { CHAR: m [ multiline ] }
 111         { CHAR: r [ reversed-regexp ] }
 112         { CHAR: s [ dotall ] }
 113         [ unknown-regexp-option ]
 114     } case ;
 115
 116 : string>options ( string -- options )
 117     [ ch>option dup ] H{ } map>assoc ;
 118
 119 : options>string ( options -- string )
 120     keys [ option>ch ] map natural-sort >string ;
 121
 122 PRIVATE>
 123
 124 : <optioned-regexp> ( string option-string -- regexp )
 125     [ default-regexp ] [ string>options ] bi* >>options
 126     construct-regexp ;
 127
 128 : <regexp> ( string -- regexp ) "" <optioned-regexp> ;
 129
 130 <PRIVATE
 131
 132 : parsing-regexp ( accum end -- accum )
 133     lexer get dup skip-blank
 134     [ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
 135     lexer get dup still-parsing-line?
 136     [ (parse-token) ] [ drop f ] if
 137     <optioned-regexp> parsed ;
 138
 139 PRIVATE>
 140
 141 : R! CHAR: ! parsing-regexp ; parsing
 142 : R" CHAR: " parsing-regexp ; parsing
 143 : R# CHAR: # parsing-regexp ; parsing
 144 : R' CHAR: ' parsing-regexp ; parsing
 145 : R( CHAR: ) parsing-regexp ; parsing
 146 : R/ CHAR: / parsing-regexp ; parsing
 147 : R@ CHAR: @ parsing-regexp ; parsing
 148 : R[ CHAR: ] parsing-regexp ; parsing
 149 : R` CHAR: ` parsing-regexp ; parsing
 150 : R{ CHAR: } parsing-regexp ; parsing
 151 : R| CHAR: | parsing-regexp ; parsing
 152
 153 M: regexp pprint*
 154     [
 155         [
 156             [ raw>> dup find-regexp-syntax swap % swap % % ]
 157             [ options>> options>string % ] bi
 158         ] "" make
 159     ] keep present-text ;