basis/documents/documents.factor

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