basis/documents/documents.factor

   1 ! Copyright (C) 2006, 2009 Slava Pestov
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays fry kernel locals math math.order
   4 math.ranges models sequences splitting ;
   5 IN: documents
   6
   7 : +col ( loc n -- newloc ) [ first2 ] dip + 2array ;
   8
   9 : +line ( loc n -- newloc ) [ first2 swap ] dip + swap 2array ;
  10
  11 : =col ( n loc -- newloc ) first swap 2array ;
  12
  13 : =line ( n loc -- newloc ) second 2array ;
  14
  15 : lines-equal? ( loc1 loc2 -- ? ) [ first ] bi@ number= ;
  16
  17 TUPLE: edit old-string new-string from old-to new-to ;
  18
  19 C: <edit> edit
  20
  21 TUPLE: document < model locs undos redos inside-undo? ;
  22
  23 : clear-undo ( document -- )
  24     V{ } clone >>undos
  25     V{ } clone >>redos
  26     drop ;
  27
  28 : <document> ( -- document )
  29     { "" } document new-model
  30     V{ } clone >>locs
  31     dup clear-undo ;
  32
  33 : add-loc ( loc document -- ) locs>> push ;
  34
  35 : remove-loc ( loc document -- ) locs>> remove! drop ;
  36
  37 : update-locs ( loc document -- )
  38     locs>> [ set-model ] with each ;
  39
  40 : doc-line ( n document -- string ) value>> nth ;
  41
  42 : line-end ( line# document -- loc )
  43     [ drop ] [ doc-line length ] 2bi 2array ;
  44
  45 : doc-lines ( from to document -- slice )
  46     [ 1 + ] [ value>> ] bi* <slice> ;
  47
  48 : start-on-line ( from line# document -- n1 )
  49     drop over first =
  50     [ second ] [ drop 0 ] if ;
  51
  52 :: end-on-line ( to line# document -- n2 )
  53     to first line# =
  54     [ to second ] [ line# document doc-line length ] if ;
  55
  56 : each-line ( ... from to quot: ( ... line -- ... ) -- ... )
  57     2over = [ 3drop ] [
  58         [ [ first ] bi@ [a,b] ] dip each
  59     ] if ; inline
  60
  61 : map-lines ( ... from to quot: ( ... line -- ... result ) -- ... results )
  62     collector [ each-line ] dip ; inline
  63
  64 : start/end-on-line ( from to line# document -- n1 n2 )
  65     [ start-on-line ] [ end-on-line ] bi-curry bi-curry bi* ;
  66
  67 : last-line# ( document -- line )
  68     value>> length 1 - ;
  69
  70 CONSTANT: doc-start { 0 0 }
  71
  72 : doc-end ( document -- loc )
  73     [ last-line# ] keep line-end ;
  74
  75 <PRIVATE
  76
  77 : (doc-range) ( from to line# document -- slice )
  78     [ start/end-on-line ] 2keep doc-line <slice> ;
  79
  80 : text+loc ( lines loc -- loc )
  81     over [
  82         over length 1 = [
  83             nip first2
  84         ] [
  85             first swap length 1 - + 0
  86         ] if
  87     ] dip last length + 2array ;
  88
  89 : prepend-first ( str seq -- )
  90     0 swap [ append ] change-nth ;
  91
  92 : append-last ( str seq -- )
  93     [ length 1 - ] keep [ prepend ] change-nth ;
  94
  95 : loc-col/str ( loc document -- str col )
  96     [ first2 swap ] dip nth swap ;
  97
  98 : prepare-insert ( new-lines from to lines -- new-lines )
  99     [ loc-col/str head-slice ] [ loc-col/str tail-slice ] bi-curry bi*
 100     pick append-last over prepend-first ;
 101
 102 : (set-doc-range) ( doc-lines from to lines -- changed-lines )
 103     [ prepare-insert ] 3keep
 104     [ [ first ] bi@ 1 + ] dip
 105     replace-slice ;
 106
 107 : entire-doc ( document -- start end document )
 108     [ [ doc-start ] dip doc-end ] keep ;
 109
 110 : with-undo ( ..a document quot: ( ..a document -- ..b ) -- ..b )
 111     [ t >>inside-undo? ] dip keep f >>inside-undo? drop ; inline
 112
 113 ! XXX: This is the old string-lines behavior, it would be nice
 114 ! if we could update documents to work with the new string-lines
 115 ! behavior.
 116 : split-lines ( str -- seq )
 117     dup [ "\r\n" member? ] any? [
 118         "\n" split
 119         [
 120             but-last-slice [
 121                 "\r" ?tail drop "\r" split
 122             ] map! drop
 123         ] [
 124             [ length 1 - ] keep [ "\r" split ] change-nth
 125         ]
 126         [ concat ]
 127         tri
 128     ] [
 129         1array
 130     ] if ;
 131
 132 PRIVATE>
 133
 134 :: doc-range ( from to document -- string )
 135     from to [ [ from to ] dip document (doc-range) ] map-lines
 136     "\n" join ;
 137
 138 : add-undo ( edit document -- )
 139     dup inside-undo?>> [ 2drop ] [
 140         [ undos>> push ] keep
 141         redos>> delete-all
 142     ] if ;
 143
 144 :: set-doc-range ( string from to document -- )
 145     from to = string empty? and [
 146         string split-lines :> new-lines
 147         new-lines from text+loc :> new-to
 148         from to document doc-range :> old-string
 149         old-string string from to new-to <edit> document add-undo
 150         new-lines from to document [ (set-doc-range) ] models:change-model
 151         new-to document update-locs
 152     ] unless ;
 153
 154 : change-doc-range ( from to document quot -- )
 155     '[ doc-range @ ] 3keep set-doc-range ; inline
 156
 157 : remove-doc-range ( from to document -- )
 158     [ "" ] 3dip set-doc-range ;
 159
 160 : validate-line ( line document -- line )
 161     last-line# min 0 max ;
 162
 163 : validate-col ( col line document -- col )
 164     doc-line length min 0 max ;
 165
 166 : line-end? ( loc document -- ? )
 167     [ first2 swap ] dip doc-line length = ;
 168
 169 : validate-loc ( loc document -- newloc )
 170     2dup [ first ] [ value>> length ] bi* >= [
 171         nip doc-end
 172     ] [
 173         over first 0 < [
 174             2drop { 0 0 }
 175         ] [
 176             [ first2 over ] dip validate-col 2array
 177         ] if
 178     ] if ;
 179
 180 : doc-string ( document -- str )
 181     entire-doc doc-range ;
 182
 183 : set-doc-string ( string document -- )
 184     entire-doc set-doc-range ;
 185
 186 : clear-doc ( document -- )
 187     [ "" ] dip set-doc-string ;
 188
 189 <PRIVATE
 190
 191 : undo/redo-edit ( edit document string-quot to-quot -- )
 192     '[ [ _ [ from>> ] _ tri ] dip set-doc-range ] with-undo ; inline
 193
 194 : undo-edit ( edit document -- )
 195     [ old-string>> ] [ new-to>> ] undo/redo-edit ;
 196
 197 : redo-edit ( edit document -- )
 198     [ new-string>> ] [ old-to>> ] undo/redo-edit ;
 199
 200 : undo/redo ( document source-quot dest-quot do-quot -- )
 201     [ dupd call [ drop ] ] 2dip
 202     '[ pop swap [ @ push ] _ 2bi ] if-empty ; inline
 203
 204 PRIVATE>
 205
 206 : undo ( document -- )
 207     [ undos>> ] [ redos>> ] [ undo-edit ] undo/redo ;
 208
 209 : redo ( document -- )
 210     [ redos>> ] [ undos>> ] [ redo-edit ] undo/redo ;