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