1 ! Copyright (C) 2006, 2009 Slava Pestov
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays kernel math math.order math.ranges
4 models sequences splitting ;
7 : +col ( loc n -- newloc ) [ first2 ] dip + 2array ;
9 : +line ( loc n -- newloc ) [ first2 swap ] dip + swap 2array ;
11 : =col ( n loc -- newloc ) first swap 2array ;
13 : =line ( n loc -- newloc ) second 2array ;
15 : lines-equal? ( loc1 loc2 -- ? ) [ first ] bi@ number= ;
17 TUPLE: edit old-string new-string from old-to new-to ;
21 TUPLE: document < model locs undos redos inside-undo? ;
23 : clear-undo ( document -- )
28 : <document> ( -- document )
29 { "" } document new-model
33 : add-loc ( loc document -- ) locs>> push ;
35 : remove-loc ( loc document -- ) locs>> remove! drop ;
37 : update-locs ( loc document -- )
38 locs>> [ set-model ] with each ;
40 : doc-line ( n document -- string ) value>> nth ;
42 : line-end ( line# document -- loc )
43 [ drop ] [ doc-line length ] 2bi 2array ;
45 : doc-lines ( from to document -- slice )
46 [ 1 + ] [ value>> ] bi* <slice> ;
48 : start-on-line ( from line# document -- n1 )
50 [ second ] [ drop 0 ] if ;
52 :: end-on-line ( to line# document -- n2 )
54 [ to second ] [ line# document doc-line length ] if ;
56 : each-line ( ... from to quot: ( ... line -- ... ) -- ... )
58 [ [ first ] bi@ [a,b] ] dip each
61 : map-lines ( ... from to quot: ( ... line -- ... result ) -- ... results )
62 collector [ each-line ] dip ; inline
64 : start/end-on-line ( from to line# document -- n1 n2 )
65 [ start-on-line ] [ end-on-line ] bi-curry bi-curry bi* ;
67 : last-line# ( document -- line )
70 CONSTANT: doc-start { 0 0 }
72 : doc-end ( document -- loc )
73 [ last-line# ] keep line-end ;
77 : (doc-range) ( from to line# document -- slice )
78 [ start/end-on-line ] 2keep doc-line <slice> ;
80 :: text+loc ( lines loc -- loc )
84 loc first lines length 1 - + 0
85 ] if lines last length + 2array ;
87 : prepend-first ( str seq -- )
88 0 swap [ append ] change-nth ;
90 : append-last ( str seq -- )
91 [ length 1 - ] keep [ prepend ] change-nth ;
93 : loc-col/str ( loc document -- str col )
94 [ first2 swap ] dip nth swap ;
96 : prepare-insert ( new-lines from to lines -- new-lines )
97 [ loc-col/str head-slice ] [ loc-col/str tail-slice ] bi-curry bi*
98 pick append-last over prepend-first ;
100 : (set-doc-range) ( doc-lines from to lines -- changed-lines )
101 [ prepare-insert ] 3keep
102 [ [ first ] bi@ 1 + ] dip
105 : entire-doc ( document -- start end document )
106 [ [ doc-start ] dip doc-end ] keep ;
108 : with-undo ( ..a document quot: ( ..a document -- ..b ) -- ..b )
109 [ t >>inside-undo? ] dip keep f >>inside-undo? drop ; inline
111 : split-lines ( str -- seq )
113 [ "\r\n" member? ] [ t ] if*
118 :: doc-range ( from to document -- string )
119 from to [ [ from to ] dip document (doc-range) ] map-lines
122 : add-undo ( edit document -- )
123 dup inside-undo?>> [ 2drop ] [
124 [ undos>> push ] keep
128 :: set-doc-range ( string from to document -- )
129 from to = string empty? and [
130 string split-lines :> new-lines
131 new-lines from text+loc :> new-to
132 from to document doc-range :> old-string
133 old-string string from to new-to <edit> document add-undo
134 new-lines from to document [ (set-doc-range) ] models:change-model
135 new-to document update-locs
138 :: set-doc-range* ( string from to document -- )
139 from to = string empty? and [
140 string split-lines :> new-lines
141 new-lines from text+loc :> new-to
142 new-lines from to document [ (set-doc-range) ] models:change-model
143 new-to document update-locs
146 : change-doc-range ( from to document quot -- )
147 '[ doc-range @ ] 3keep set-doc-range ; inline
149 : remove-doc-range ( from to document -- )
150 [ "" ] 3dip set-doc-range ;
152 : validate-line ( line document -- line )
153 last-line# min 0 max ;
155 : validate-col ( col line document -- col )
156 doc-line length min 0 max ;
158 : line-end? ( loc document -- ? )
159 [ first2 swap ] dip doc-line length = ;
161 : validate-loc ( loc document -- newloc )
162 2dup [ first ] [ value>> length ] bi* >= [
168 [ first2 over ] dip validate-col 2array
172 : doc-string ( document -- str )
173 entire-doc doc-range ;
175 : set-doc-string ( string document -- )
176 entire-doc set-doc-range ;
178 : clear-doc ( document -- )
179 [ "" ] dip set-doc-string ;
183 : undo/redo-edit ( edit document string-quot to-quot -- )
184 '[ [ _ [ from>> ] _ tri ] dip set-doc-range ] with-undo ; inline
186 : undo-edit ( edit document -- )
187 [ old-string>> ] [ new-to>> ] undo/redo-edit ;
189 : redo-edit ( edit document -- )
190 [ new-string>> ] [ old-to>> ] undo/redo-edit ;
192 : undo/redo ( document source-quot dest-quot do-quot -- )
193 [ dupd call [ drop ] ] 2dip
194 '[ pop swap [ @ push ] _ 2bi ] if-empty ; inline
198 : undo ( document -- )
199 [ undos>> ] [ redos>> ] [ undo-edit ] undo/redo ;
201 : redo ( document -- )
202 [ redos>> ] [ undos>> ] [ redo-edit ] undo/redo ;