xmode.marker: faster update-match-group

[factor.git] / basis / xmode / marker / marker.factor

diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor
index d29623820875d5758aaa1e940c077b9ca1c33bb1..2b09ffdd5536b4bb1aa2dc3a26eeb839378a9697 100644 (file)
--- a/basis/xmode/marker/marker.factor
+++ b/basis/xmode/marker/marker.factor
@@ -102,7 +102,7 @@ M: regexp text-matches?
 : match-group-regexp ( regexp n -- skip-regexp match-regexp )
     [ [ options>> options>string ] [ raw>> ] bi ] dip
     CHAR: ( pick nth-index cut CHAR: ) over index 1 + head
-    rot '[ _ <optioned-regexp> ] bi@ ;
+    rot '[ _ H{ } [ <optioned-regexp> ] 2cache ] bi@ ;
 
 : skip-first-match ( match regexp -- tailseq )
     first-match [ seq>> ] [ to>> ] bi tail ;
@@ -110,11 +110,13 @@ M: regexp text-matches?
 : nth-match ( match regexp n -- slice/f )
     match-group-regexp [ skip-first-match ] [ first-match ] bi* ;
 
-: update-match-group ( str match regexp n -- str' )
-    [ nth-match ] [ CHAR: 1 + "$%c" sprintf ] bi swap replace ;
+:: update-match-group ( str match regexp n -- str' )
+    n H{ } [ 1 + CHAR: $ swap "" 2sequence ] cache :> x
+    x str subseq? [
+        x match "" like regexp n nth-match str replace
+    ] [ str ] if ;
 
 : update-match-groups ( str match regexp -- str' )
-    [ >string ] dip
     dup #match-groups [ update-match-group ] 2with each-integer ;
 
 GENERIC: fixup-end ( match regexp end -- end' )
@@ -123,12 +125,15 @@ M: string-matcher fixup-end
     [ string>> -rot update-match-groups ]
     [ ignore-case?>> ] bi <string-matcher> ;
 
-M: regexp fixup-end
-    [ raw>> [ -rot update-match-groups ] keep swap ]
-    [ options>> options>string ] bi <optioned-regexp> {
+MEMO: <fixup-regexp> ( raw matched options -- regexp )
+    <optioned-regexp> {
         [ parse-tree>> ] [ options>> ] [ dfa>> ] [ next-match>> ]
     } cleave regexp boa ;
 
+M: regexp fixup-end
+    [ raw>> [ -rot update-match-groups ] keep swap ]
+    [ options>> options>string ] bi <fixup-regexp> ;
+
 : fixup-end? ( text -- ? )
     { [ regexp? ] [ #match-groups ] } 1&& ;
 
@@ -168,14 +173,14 @@ PRIVATE>
 
 DEFER: get-rules
 
-: get-always-rules ( vector/f ruleset -- vector/f )
-    f swap rules>> at ?push-all ;
+: get-always-rules ( ruleset -- vector/f )
+    f swap rules>> at ;
 
-: get-char-rules ( vector/f char ruleset -- vector/f )
-    [ ch>upper ] dip rules>> at ?push-all ;
+: get-char-rules ( char ruleset -- vector/f )
+    [ ch>upper ] dip rules>> at ;
 
 : get-rules ( char ruleset -- seq )
-    [ f ] 2dip [ get-char-rules ] keep get-always-rules ;
+    [ get-char-rules ] [ get-always-rules ] bi [ append ] when* ;
 
 GENERIC: handle-rule-start ( match-count rule -- )