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.classes
   7 regexp.transition-tables splitting sorting regexp.ast
   8 regexp.negation regexp.matchers regexp.compiler ;
   9 IN: regexp
  10
  11 TUPLE: regexp
  12     { raw read-only }
  13     { parse-tree read-only }
  14     { options read-only }
  15     dfa reverse-dfa ;
  16
  17 : make-regexp ( string ast -- regexp )
  18     f f <options> f 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 f regexp boa ;
  25
  26 : <regexp> ( string -- regexp ) "" <optioned-regexp> ;
  27
  28 TUPLE: reverse-matcher regexp ;
  29 C: <reverse-matcher> reverse-matcher
  30 ! Reverse matchers won't work properly with most combinators, for now
  31
  32 <PRIVATE
  33
  34 : get-ast ( regexp -- ast )
  35     [ parse-tree>> ] [ options>> ] bi <with-options> ;
  36
  37 : compile-regexp ( regexp -- regexp )
  38     dup '[ [ _ get-ast ast>dfa dfa>quotation ] unless* ] change-dfa ;
  39
  40 : <reversed-option> ( ast -- reversed )
  41     "r" string>options <with-options> ;
  42
  43 : maybe-negated ( lookaround quot -- regexp-quot )
  44     '[ term>> @ ] [ positive?>> [ ] [ not ] ? ] bi compose ; inline
  45
  46 M: lookahead question>quot ! Returns ( index string -- ? )
  47     [ ast>dfa dfa>shortest-quotation ] maybe-negated ;
  48
  49 M: lookbehind question>quot ! Returns ( index string -- ? )
  50     [
  51         <reversed-option>
  52         ast>dfa dfa>reverse-shortest-quotation
  53         [ [ 1- ] dip ] prepose
  54     ] maybe-negated ;
  55
  56 : compile-reverse ( regexp -- regexp )
  57     dup '[
  58         [
  59             _ get-ast <reversed-option>
  60             ast>dfa dfa>reverse-quotation
  61         ] unless*
  62     ] change-reverse-dfa ;
  63
  64 M: regexp match-index-from
  65     compile-regexp dfa>> <quot-matcher> match-index-from ;
  66
  67 M: reverse-matcher match-index-from
  68     regexp>> compile-reverse reverse-dfa>>
  69     <quot-matcher> match-index-from ;
  70
  71 ! The following two should do some caching
  72
  73 : find-regexp-syntax ( string -- prefix suffix )
  74     {
  75         { "R/ "  "/"  }
  76         { "R! "  "!"  }
  77         { "R\" " "\"" }
  78         { "R# "  "#"  }
  79         { "R' "  "'"  }
  80         { "R( "  ")"  }
  81         { "R@ "  "@"  }
  82         { "R[ "  "]"  }
  83         { "R` "  "`"  }
  84         { "R{ "  "}"  }
  85         { "R| "  "|"  }
  86     } swap [ subseq? not nip ] curry assoc-find drop ;
  87
  88 : take-until ( end lexer -- string )
  89     dup skip-blank [
  90         [ index-from ] 2keep
  91         [ swapd subseq ]
  92         [ 2drop 1+ ] 3bi
  93     ] change-lexer-column ;
  94
  95 : parse-noblank-token ( lexer -- str/f )
  96     dup still-parsing-line? [ (parse-token) ] [ drop f ] if ;
  97
  98 : parsing-regexp ( accum end -- accum )
  99     lexer get [ take-until ] [ parse-noblank-token ] bi
 100     <optioned-regexp> compile-regexp parsed ;
 101
 102 PRIVATE>
 103
 104 : R! CHAR: ! parsing-regexp ; parsing
 105 : R" CHAR: " parsing-regexp ; parsing
 106 : R# CHAR: # parsing-regexp ; parsing
 107 : R' CHAR: ' parsing-regexp ; parsing
 108 : R( CHAR: ) parsing-regexp ; parsing
 109 : R/ CHAR: / parsing-regexp ; parsing
 110 : R@ CHAR: @ parsing-regexp ; parsing
 111 : R[ CHAR: ] parsing-regexp ; parsing
 112 : R` CHAR: ` parsing-regexp ; parsing
 113 : R{ CHAR: } parsing-regexp ; parsing
 114 : R| CHAR: | parsing-regexp ; parsing
 115
 116 M: regexp pprint*
 117     [
 118         [
 119             [ raw>> dup find-regexp-syntax swap % swap % % ]
 120             [ options>> options>string % ] bi
 121         ] "" make
 122     ] keep present-text ;