basis/documents/documents.factor

   1 ! Copyright (C) 2006, 2008 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 ;
   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: document < model locs ;
  19
  20 : <document> ( -- document )
  21     V{ "" } clone document new-model
  22     V{ } clone >>locs ;
  23
  24 : add-loc ( loc document -- ) locs>> push ;
  25
  26 : remove-loc ( loc document -- ) locs>> delete ;
  27
  28 : update-locs ( loc document -- )
  29     locs>> [ set-model ] with each ;
  30
  31 : doc-line ( n document -- string ) value>> nth ;
  32
  33 : doc-lines ( from to document -- slice )
  34     [ 1+ ] dip value>> <slice> ;
  35
  36 : start-on-line ( document from line# -- n1 )
  37     [ dup first ] dip = [ nip second ] [ 2drop 0 ] if ;
  38
  39 : end-on-line ( document to line# -- n2 )
  40     over first over = [
  41         drop second nip
  42     ] [
  43         nip swap doc-line length
  44     ] if ;
  45
  46 : each-line ( from to quot -- )
  47     2over = [
  48         3drop
  49     ] [
  50         [ [ first ] bi@ [a,b] ] dip each
  51     ] if ; inline
  52
  53 : start/end-on-line ( from to line# -- n1 n2 )
  54     tuck
  55     [ [ document get ] 2dip start-on-line ]
  56     [ [ document get ] 2dip end-on-line ]
  57     2bi* ;
  58
  59 : (doc-range) ( from to line# -- )
  60     [ start/end-on-line ] keep document get doc-line <slice> , ;
  61
  62 : doc-range ( from to document -- string )
  63     [
  64         document set 2dup [
  65             [ 2dup ] dip (doc-range)
  66         ] each-line 2drop
  67     ] { } make "\n" join ;
  68
  69 : text+loc ( lines loc -- loc )
  70     over [
  71         over length 1 = [
  72             nip first2
  73         ] [
  74             first swap length 1- + 0
  75         ] if
  76     ] dip peek length + 2array ;
  77
  78 : prepend-first ( str seq -- )
  79     0 swap [ append ] change-nth ;
  80
  81 : append-last ( str seq -- )
  82     [ length 1- ] keep [ prepend ] change-nth ;
  83
  84 : loc-col/str ( loc document -- str col )
  85     [ first2 swap ] dip nth swap ;
  86
  87 : prepare-insert ( newinput from to lines -- newinput )
  88     tuck [ loc-col/str head-slice ] [ loc-col/str tail-slice ] 2bi*
  89     pick append-last over prepend-first ;
  90
  91 : (set-doc-range) ( newlines from to lines -- )
  92     [ prepare-insert ] 3keep
  93     [ [ first ] bi@ 1+ ] dip
  94     replace-slice ;
  95
  96 : set-doc-range ( string from to document -- )
  97     [
  98         [ [ string-lines ] dip [ text+loc ] 2keep ] 2dip
  99         [ [ (set-doc-range) ] keep ] change-model
 100     ] keep update-locs ;
 101
 102 : remove-doc-range ( from to document -- )
 103     [ "" ] 3dip set-doc-range ;
 104
 105 : last-line# ( document -- line )
 106     value>> length 1- ;
 107
 108 : validate-line ( line document -- line )
 109     last-line# min 0 max ;
 110
 111 : validate-col ( col line document -- col )
 112     doc-line length min 0 max ;
 113
 114 : line-end ( line# document -- loc )
 115     dupd doc-line length 2array ;
 116
 117 : line-end? ( loc document -- ? )
 118     [ first2 swap ] dip doc-line length = ;
 119
 120 : doc-end ( document -- loc )
 121     [ last-line# ] keep line-end ;
 122
 123 : validate-loc ( loc document -- newloc )
 124     over first over value>> length >= [
 125         nip doc-end
 126     ] [
 127         over first 0 < [
 128             2drop { 0 0 }
 129         ] [
 130             [ first2 swap tuck ] dip validate-col 2array
 131         ] if
 132     ] if ;
 133
 134 : doc-string ( document -- str )
 135     value>> "\n" join ;
 136
 137 : set-doc-string ( string document -- )
 138     [ string-lines V{ } like ] dip [ set-model ] keep
 139     [ doc-end ] [ update-locs ] bi ;
 140
 141 : clear-doc ( document -- )
 142     "" swap set-doc-string ;
 143
 144 GENERIC: prev-elt ( loc document elt -- newloc )
 145 GENERIC: next-elt ( loc document elt -- newloc )
 146
 147 : prev/next-elt ( loc document elt -- start end )
 148     [ prev-elt ] [ next-elt ] 3bi ;
 149
 150 : elt-string ( loc document elt -- string )
 151     [ prev/next-elt ] [ drop ] 2bi doc-range ;
 152
 153 TUPLE: char-elt ;
 154
 155 : (prev-char) ( loc document quot -- loc )
 156     {
 157         { [ pick { 0 0 } = ] [ 2drop ] }
 158         { [ pick second zero? ] [ drop [ first 1- ] dip line-end ] }
 159         [ call ]
 160     } cond ; inline
 161
 162 : (next-char) ( loc document quot -- loc )
 163     {
 164         { [ 2over doc-end = ] [ 2drop ] }
 165         { [ 2over line-end? ] [ 2drop first 1+ 0 2array ] }
 166         [ call ]
 167     } cond ; inline
 168
 169 M: char-elt prev-elt
 170     drop [ drop -1 +col ] (prev-char) ;
 171
 172 M: char-elt next-elt
 173     drop [ drop 1 +col ] (next-char) ;
 174
 175 TUPLE: one-char-elt ;
 176
 177 M: one-char-elt prev-elt 2drop ;
 178
 179 M: one-char-elt next-elt 2drop ;
 180
 181 : (word-elt) ( loc document quot -- loc )
 182     pick [
 183         [ [ first2 swap ] dip doc-line ] dip call
 184     ] dip =col ; inline
 185
 186 : ((word-elt)) ( n seq -- ? n seq ) [ ?nth blank? ] 2keep ;
 187
 188 : break-detector ( ? -- quot )
 189     [ [ blank? ] dip xor ] curry ; inline
 190
 191 : (prev-word) ( ? col str -- col )
 192     rot break-detector find-last-from drop ?1+ ;
 193
 194 : (next-word) ( ? col str -- col )
 195     [ rot break-detector find-from drop ] keep
 196     over not [ nip length ] [ drop ] if ;
 197
 198 TUPLE: one-word-elt ;
 199
 200 M: one-word-elt prev-elt
 201     drop
 202     [ [ [ f ] dip 1- ] dip (prev-word) ] (word-elt) ;
 203
 204 M: one-word-elt next-elt
 205     drop
 206     [ [ f ] 2dip (next-word) ] (word-elt) ;
 207
 208 TUPLE: word-elt ;
 209
 210 M: word-elt prev-elt
 211     drop
 212     [ [ [ 1- ] dip ((word-elt)) (prev-word) ] (word-elt) ]
 213     (prev-char) ;
 214
 215 M: word-elt next-elt
 216     drop
 217     [ [ ((word-elt)) (next-word) ] (word-elt) ]
 218     (next-char) ;
 219
 220 TUPLE: one-line-elt ;
 221
 222 M: one-line-elt prev-elt
 223     2drop first 0 2array ;
 224
 225 M: one-line-elt next-elt
 226     drop [ first dup ] dip doc-line length 2array ;
 227
 228 TUPLE: line-elt ;
 229
 230 M: line-elt prev-elt
 231     2drop dup first zero? [ drop { 0 0 } ] [ -1 +line ] if ;
 232
 233 M: line-elt next-elt
 234     drop over first over last-line# number=
 235     [ nip doc-end ] [ drop 1 +line ] if ;
 236
 237 TUPLE: doc-elt ;
 238
 239 M: doc-elt prev-elt 3drop { 0 0 } ;
 240
 241 M: doc-elt next-elt drop nip doc-end ;