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