extra/modern/slices/slices.factor

   1 ! Copyright (C) 2016 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs fry kernel locals math sequences
   4 sequences.deep sequences.extras sequences.private strings
   5 unicode ;
   6 IN: modern.slices
   7
   8 : >strings ( seq -- str )
   9     [ dup slice? [ >string ] when ] deep-map ;
  10
  11 : matching-delimiter ( ch -- ch' )
  12     H{
  13         { CHAR: ( CHAR: ) }
  14         { CHAR: [ CHAR: ] }
  15         { CHAR: { CHAR: } }
  16         { CHAR: < CHAR: > }
  17         { CHAR: : CHAR: ; }
  18     } ?at drop ;
  19
  20 : matching-delimiter-string ( string -- string' )
  21     [ matching-delimiter ] map ;
  22
  23 : matching-section-delimiter ( string -- string' )
  24     dup ":" tail? [
  25         rest but-last ";" ">" surround
  26     ] [
  27         rest ">" append
  28     ] if ;
  29
  30 : accept1 ( n string quot: ( ch -- ? ) -- n/n' string ch/f )
  31     [ 2dup nth ] dip keep swap [ [ 1 + ] 2dip ] [ drop f ] if ; inline
  32
  33 ERROR: unexpected-end n string ;
  34 : nth-check-eof ( n string -- nth )
  35     2dup ?nth [ 2nip ] [ unexpected-end ] if* ;
  36
  37 : peek1-from ( n/f string -- ch )
  38     over [ ?nth ] [ 2drop f ] if ;
  39
  40 : peek-from ( n/f string m -- string )
  41     over [ [ swap tail-slice ] dip head-slice ] [ 3drop f ] if ;
  42
  43 : previous-from ( n/f string -- ch )
  44     over [ [ 1 - ] dip ?nth ] [ 2drop f ] if ;
  45
  46 ! Allow eof
  47 : next-char-from ( n/f string -- n'/f string ch/f )
  48     over [
  49         2dup ?nth [ [ 1 + ] 2dip ] [ f ] if*
  50     ] [
  51         [ 2drop f ] [ nip ] 2bi f
  52     ] if ;
  53
  54 : prev-char-from-slice-end ( slice -- ch/f )
  55     [ to>> 2 - ] [ seq>> ] bi ?nth ;
  56
  57 : prev-char-from-slice ( slice -- ch/f )
  58     [ from>> 1 - ] [ seq>> ] bi ?nth ;
  59
  60 : next-char-from-slice ( slice -- ch/f )
  61     [ to>> ] [ seq>> ] bi ?nth ;
  62
  63 : char-before-slice ( slice -- ch/f )
  64     [ from>> 1 - ] [ seq>> ] bi ?nth ;
  65
  66 : char-after-slice ( slice -- ch/f )
  67     [ to>> ] [ seq>> ] bi ?nth ;
  68
  69 : find-from* ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt ? )
  70     [ find-from ] keepd
  71     pick [ drop t ] [ length -rot nip f ] if ; inline
  72
  73 : skip-blank-from ( n string -- n' string )
  74     over [
  75         [ [ blank? not ] find-from* 2drop ] keep
  76     ] when ; inline
  77
  78 : skip-til-eol-from ( n string -- n' string )
  79     [ [ "\r\n" member? ] find-from* 2drop ] keep ; inline
  80
  81 ERROR: take-slice-error n string count ;
  82 :: take-slice ( n string count -- n'/f string slice )
  83     n [ n string count take-slice-error ] unless
  84     n count + :> to
  85     to
  86     string
  87     n to string <slice> ;
  88
  89 ERROR: expected-sequence-error expected actual ;
  90 : check-sequence ( expected actual -- actual/* )
  91     2dup sequence= [ nip ] [ expected-sequence-error ] if ;
  92
  93 : check-sequence-insensitive ( expected actual -- actual/* )
  94     2dup [ >lower ] bi@ sequence= [ nip ] [ expected-sequence-error ] if ;
  95
  96 : expect-and-span ( n string slice expected-string -- n' string slice' )
  97     dup length '[ _ take-slice ] 2dip
  98     rot check-sequence span-slices ;
  99
 100 : expect-and-span-insensitive ( n string slice expected-string -- n' string slice' )
 101     dup length '[ _ take-slice ] 2dip
 102     rot check-sequence-insensitive span-slices ;
 103
 104 :: split-slice-back ( slice n -- slice1 slice2 )
 105     slice [ from>> ] [ to>> ] [ seq>> ] tri :> ( from to seq )
 106     from to n - seq <slice>
 107     to n - to seq <slice> ;
 108
 109 ! Don't include the whitespace in the slice
 110 :: slice-til-whitespace ( n string -- n' string slice/f ch/f )
 111     n [
 112         n string [ "\s\r\n" member? ] find-from :> ( n' ch )
 113         n' string
 114         n n' string ?<slice>
 115         ch
 116     ] [
 117         f string f f
 118     ] if ; inline
 119
 120 :: (slice-until) ( n string quot -- n' string slice/f ch/f )
 121     n string quot find-from :> ( n' ch )
 122     n' string
 123     n n' string ?<slice>
 124     ch ; inline
 125
 126 : slice-until ( n string quot -- n' string slice/f )
 127     (slice-until) drop ; inline
 128
 129 :: slice-til-not-whitespace ( n string -- n' string slice/f ch/f )
 130     n [
 131         n string [ "\s\r\n\t" member? not ] find-from :> ( n' ch )
 132         n' string
 133         n n' string ?<slice>
 134         ch
 135     ] [
 136         n string f f
 137     ] if ; inline
 138
 139 : skip-whitespace ( n/f string -- n'/f string )
 140     slice-til-not-whitespace 2drop ;
 141
 142 : empty-slice-end ( seq -- slice )
 143     [ length dup ] [ ] bi <slice> ; inline
 144
 145 : empty-slice-from ( n seq -- slice )
 146     dupd <slice> ; inline
 147
 148 :: slice-til-eol ( n string -- n' string slice/f ch/f )
 149     n [
 150         n string '[ "\r\n" member? ] find-from :> ( n' ch )
 151         n' string
 152         n n' string ?<slice>
 153         ch
 154     ] [
 155         n string string empty-slice-end f
 156     ] if ; inline
 157
 158 :: merge-slice-til-eol-slash'' ( n string -- n' string slice/f ch/f )
 159     n [
 160         n string '[ "\r\n\\" member? ] find-from :> ( n' ch )
 161         n' string
 162         n n' string ?<slice>
 163         ch
 164     ] [
 165         n string string empty-slice-end f
 166     ] if ; inline
 167
 168 : merge-slice-til-whitespace ( n string slice --  n' string slice' )
 169     pick [
 170         [ slice-til-whitespace drop ] dip merge-slices
 171     ] when ;
 172
 173 : merge-slice-til-eol ( n string slice --  n' string slice' )
 174     [ slice-til-eol drop ] dip merge-slices ;
 175
 176 : slice-between ( slice1 slice2 -- slice )
 177     ! ensure-same-underlying
 178     slice-order-by-from
 179     [ to>> ]
 180     [ [ from>> 2dup < [ swap ] unless ] [ seq>> ] bi ] bi* <slice> ;
 181
 182 : slice-before ( slice -- slice' )
 183     [ drop 0 ] [ from>> ] [ seq>> ] tri <slice> ;
 184
 185 : (?nth) ( n/f string/f -- obj/f )
 186     over [ (?nth) ] [ 2drop f ] if ;
 187
 188 :: merge-slice-til-eol-slash' ( n string slice -- n' string slice/f ch/f )
 189     n string merge-slice-til-eol-slash'' :> ( n' string' slice' ch' )
 190     ch' CHAR: \\ = [
 191         n' 1 + string' (?nth) "\r\n" member? [
 192             n' 2 + string' slice slice' span-slices merge-slice-til-eol-slash'
 193         ] [
 194             "omg" throw
 195         ] if
 196     ] [
 197         n' string' slice slice' span-slices ch'
 198     ] if ;
 199
 200 ! Supports \ at eol (with no space after it)
 201 : slice-til-eol-slash ( n string -- n' string slice/f ch/f )
 202     2dup empty-slice-from merge-slice-til-eol-slash' ;
 203
 204 :: slice-til-separator-inclusive ( n string tokens -- n' string slice/f ch/f )
 205     n string '[ tokens member? ] find-from [ dup [ 1 + ] when ] dip  :> ( n' ch )
 206     n' string
 207     n n' string ?<slice>
 208     ch ; inline
 209
 210 : slice-til-separator-exclusive ( n string tokens -- n' string slice/f ch/f )
 211     slice-til-separator-inclusive dup [
 212         [ [ 1 - ] change-to ] dip
 213     ] when ;
 214
 215 ! Takes at least one character if not whitespace
 216 :: slice-til-either ( n string tokens -- n'/f string slice/f ch/f )
 217     n [
 218         n string '[ tokens member? ] find-from
 219         dup "\s\r\n" member? [
 220             :> ( n' ch )
 221             n' string
 222             n n' string ?<slice>
 223             ch
 224         ] [
 225             [ dup [ 1 + ] when ] dip :> ( n' ch )
 226             n' string
 227             n n' string ?<slice>
 228             ch
 229         ] if
 230     ] [
 231         f string f f
 232     ] if ; inline
 233
 234 ERROR: subseq-expected-but-got-eof n string expected ;
 235
 236 :: slice-til-string ( n string search --  n' string payload end-string )
 237     search string n subseq-start-from :> n'
 238     n' [ n string search subseq-expected-but-got-eof ] unless
 239     n' search length + string
 240     n n' string ?<slice>
 241     n' dup search length + string ?<slice> ;
 242
 243 : modify-from ( slice n -- slice' )
 244     '[ from>> _ + ] [ to>> ] [ seq>> ] tri <slice> ;
 245
 246 : modify-to ( slice n -- slice' )
 247     [ [ from>> ] [ to>> ] [ seq>> ] tri ] dip
 248     swap [ + ] dip <slice> ;
 249
 250 ! { CHAR: \] [ read-closing ] }
 251 ! { CHAR: \} [ read-closing ] }
 252 ! { CHAR: \) [ read-closing ] }
 253 : read-closing ( n string tok -- n string tok )
 254     dup length 1 = [
 255         -1 modify-to [ 1 - ] 2dip
 256     ] unless ;
 257
 258 : rewind-slice ( n string slice -- n' string )
 259     pick [
 260         length swap [ - ] dip
 261     ] [
 262         [ nip ] dip [ [ length ] bi@ - ] keepd
 263     ] if ; inline
 264
 265 :: take-from? ( n seq subseq -- n'/f seq  ? )
 266     subseq seq n pick length (subseq-start-from) 2nip [
 267         n subseq length +
 268         seq
 269         t
 270     ] [
 271         n seq f
 272     ] if ;
 273
 274 : check-slice? ( from to seq -- from to seq ? )
 275     pick 0 < [
 276         f
 277     ] [
 278         2dup length > [
 279             f
 280         ] [
 281             t
 282         ] if
 283     ] if ; inline
 284
 285 :: take-from-insensitive? ( n seq str -- n'/f seq ? )
 286     n str length over + seq check-slice? [
 287         subseq str [ >lower ] bi@ sequence= [
 288             n str length + seq t
 289         ] [
 290             n seq f
 291         ] if
 292     ] [
 293         3drop n seq f
 294     ] if ;