basis/regexp/regexp.factor

   1 ! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors combinators kernel math sequences strings sets
   4 assocs prettyprint.backend prettyprint.custom make lexer
   5 namespaces parser arrays fry locals regexp.minimize
   6 regexp.parser regexp.nfa regexp.dfa regexp.traversal
   7 regexp.transition-tables splitting sorting regexp.ast
   8 regexp.negation ;
   9 IN: regexp
  10
  11 TUPLE: regexp
  12     { raw read-only }
  13     { parse-tree read-only }
  14     { options read-only }
  15     dfa ;
  16
  17 : make-regexp ( string ast -- regexp )
  18     f f <options> f regexp boa ; foldable
  19     ! Foldable because, when the dfa slot is set,
  20     ! it'll be set to the same thing regardless of who sets it
  21
  22 : <optioned-regexp> ( string options -- regexp )
  23     [ dup parse-regexp ] [ string>options ] bi*
  24     f regexp boa ;
  25
  26 : <regexp> ( string -- regexp ) "" <optioned-regexp> ;
  27
  28 <PRIVATE
  29
  30 : compile-regexp ( regexp -- regexp )
  31     dup dfa>> [
  32         dup
  33         [ parse-tree>> ]
  34         [ options>> ] bi
  35         <with-options> ast>dfa
  36         >>dfa
  37     ] unless ;
  38
  39 : (match) ( string regexp -- dfa-traverser )
  40     compile-regexp dfa>> <dfa-traverser> do-match ; inline
  41
  42 PRIVATE>
  43
  44 : match ( string regexp -- slice/f )
  45     (match) return-match ;
  46
  47 : matches? ( string regexp -- ? )
  48     dupd match
  49     [ [ length ] bi@ = ] [ drop f ] if* ;
  50
  51 : match-head ( string regexp -- end/f ) match [ length ] [ f ] if* ;
  52
  53 : match-at ( string m regexp -- n/f finished? )
  54     [
  55         2dup swap length > [ 2drop f f ] [ tail-slice t ] if
  56     ] dip swap [ match-head f ] [ 2drop f t ] if ;
  57
  58 : match-range ( string m regexp -- a/f b/f )
  59     3dup match-at over [
  60         drop nip rot drop dupd +
  61     ] [
  62         [ 3drop drop f f ] [ drop [ 1+ ] dip match-range ] if
  63     ] if ;
  64
  65 : first-match ( string regexp -- slice/f )
  66     dupd 0 swap match-range rot over [ <slice> ] [ 3drop f ] if ;
  67
  68 : re-cut ( string regexp -- end/f start )
  69     dupd first-match
  70     [ split1-slice swap ] [ "" like f swap ] if* ;
  71
  72 <PRIVATE
  73
  74 : (re-split) ( string regexp -- )
  75     over [ [ re-cut , ] keep (re-split) ] [ 2drop ] if ;
  76
  77 PRIVATE>
  78
  79 : re-split ( string regexp -- seq )
  80     [ (re-split) ] { } make ;
  81
  82 : re-replace ( string regexp replacement -- result )
  83     [ re-split ] dip join ;
  84
  85 : next-match ( string regexp -- end/f match/f )
  86     dupd first-match dup
  87     [ [ split1-slice nip ] keep ] [ 2drop f f ] if ;
  88
  89 : all-matches ( string regexp -- seq )
  90     [ dup ] swap '[ _ next-match ] [ ] produce nip harvest ;
  91
  92 : count-matches ( string regexp -- n )
  93     all-matches length ;
  94
  95 <PRIVATE
  96
  97 : find-regexp-syntax ( string -- prefix suffix )
  98     {
  99         { "R/ "  "/"  }
 100         { "R! "  "!"  }
 101         { "R\" " "\"" }
 102         { "R# "  "#"  }
 103         { "R' "  "'"  }
 104         { "R( "  ")"  }
 105         { "R@ "  "@"  }
 106         { "R[ "  "]"  }
 107         { "R` "  "`"  }
 108         { "R{ "  "}"  }
 109         { "R| "  "|"  }
 110     } swap [ subseq? not nip ] curry assoc-find drop ;
 111
 112 : parsing-regexp ( accum end -- accum )
 113     lexer get dup skip-blank
 114     [ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
 115     lexer get dup still-parsing-line?
 116     [ (parse-token) ] [ drop f ] if
 117     <optioned-regexp> compile-regexp parsed ;
 118
 119 PRIVATE>
 120
 121 : R! CHAR: ! parsing-regexp ; parsing
 122 : R" CHAR: " parsing-regexp ; parsing
 123 : R# CHAR: # parsing-regexp ; parsing
 124 : R' CHAR: ' parsing-regexp ; parsing
 125 : R( CHAR: ) parsing-regexp ; parsing
 126 : R/ CHAR: / parsing-regexp ; parsing
 127 : R@ CHAR: @ parsing-regexp ; parsing
 128 : R[ CHAR: ] parsing-regexp ; parsing
 129 : R` CHAR: ` parsing-regexp ; parsing
 130 : R{ CHAR: } parsing-regexp ; parsing
 131 : R| CHAR: | parsing-regexp ; parsing
 132
 133 M: regexp pprint*
 134     [
 135         [
 136             [ raw>> dup find-regexp-syntax swap % swap % % ]
 137             [ options>> options>string % ] bi
 138         ] "" make
 139     ] keep present-text ;