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 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 ERROR: unexpected-end n string ;
  30 : nth-check-eof ( n string -- nth )
  31     2dup ?nth [ 2nip ] [ unexpected-end ] if* ;
  32
  33 : peek-from ( n/f string -- ch )
  34     over [ ?nth ] [ 2drop f ] if ;
  35
  36 : previous-from ( n/f string -- ch )
  37     over [ [ 1 - ] dip ?nth ] [ 2drop f ] if ;
  38
  39 ! Allow eof
  40 : next-char-from ( n/f string -- n'/f string ch/f )
  41     over [
  42         2dup ?nth [ [ 1 + ] 2dip ] [ f ] if*
  43     ] [
  44         [ 2drop f ] [ nip ] 2bi f
  45     ] if ;
  46
  47 : prev-char-from-slice-end ( slice -- ch/f )
  48     [ to>> 2 - ] [ seq>> ] bi ?nth ;
  49
  50 : prev-char-from-slice ( slice -- ch/f )
  51     [ from>> 1 - ] [ seq>> ] bi ?nth ;
  52
  53 : next-char-from-slice ( slice -- ch/f )
  54     [ to>> ] [ seq>> ] bi ?nth ;
  55
  56 : char-before-slice ( slice -- ch/f )
  57     [ from>> 1 - ] [ seq>> ] bi ?nth ;
  58
  59 : char-after-slice ( slice -- ch/f )
  60     [ to>> ] [ seq>> ] bi ?nth ;
  61
  62 : find-from* ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt ? )
  63     [ find-from ] 2keep drop
  64     pick [ drop t ] [ length -rot nip f ] if ; inline
  65
  66 : skip-blank-from ( n string -- n' string )
  67     over [
  68         [ [ blank? not ] find-from* 2drop ] keep
  69     ] when ; inline
  70
  71 : skip-til-eol-from ( n string -- n' string )
  72     [ [ "\r\n" member? ] find-from* 2drop ] keep ; inline
  73
  74 ! Don't include the whitespace in the slice
  75 :: slice-til-whitespace ( n string -- n' string slice/f ch/f )
  76     n [
  77         n string [ "\s\r\n" member? ] find-from :> ( n' ch )
  78         n' string
  79         n n' string ?<slice>
  80         ch
  81     ] [
  82         f string f f
  83     ] if ; inline
  84
  85 :: (slice-until) ( n string quot -- n' string slice/f ch/f )
  86     n string quot find-from :> ( n' ch )
  87     n' string
  88     n n' string ?<slice>
  89     ch ; inline
  90
  91 : slice-until ( n string quot -- n' string slice/f )
  92     (slice-until) drop ; inline
  93
  94 :: slice-til-not-whitespace ( n string -- n' string slice/f ch/f )
  95     n [
  96         n string [ "\s\r\n" member? not ] find-from :> ( n' ch )
  97         n' string
  98         n n' string ?<slice>
  99         ch
 100     ] [
 101         n string f f
 102     ] if ; inline
 103
 104 : skip-whitespace ( n/f string -- n'/f string )
 105     slice-til-not-whitespace 2drop ;
 106
 107 : empty-slice-end ( seq -- slice )
 108     [ length dup ] [ ] bi <slice> ; inline
 109
 110 : empty-slice-from ( n seq -- slice )
 111     dupd <slice> ; inline
 112
 113 :: slice-til-eol ( n string -- n' string slice/f ch/f )
 114     n [
 115         n string '[ "\r\n" member? ] find-from :> ( n' ch )
 116         n' string
 117         n n' string ?<slice>
 118         ch
 119     ] [
 120         n string string empty-slice-end f
 121     ] if ; inline
 122
 123 :: merge-slice-til-eol-slash'' ( n string -- n' string slice/f ch/f )
 124     n [
 125         n string '[ "\r\n\\" member? ] find-from :> ( n' ch )
 126         n' string
 127         n n' string ?<slice>
 128         ch
 129     ] [
 130         n string string empty-slice-end f
 131     ] if ; inline
 132
 133 : merge-slice-til-whitespace ( n string slice --  n' string slice' )
 134     pick [
 135         [ slice-til-whitespace drop ] dip merge-slices
 136     ] when ;
 137
 138 : merge-slice-til-eol ( n string slice --  n' string slice' )
 139     [ slice-til-eol drop ] dip merge-slices ;
 140
 141 : slice-between ( slice1 slice2 -- slice )
 142     ! ensure-same-underlying
 143     slice-order-by-from
 144     [ to>> ]
 145     [ [ from>> 2dup < [ swap ] unless ] [ seq>> ] bi ] bi* <slice> ;
 146
 147 : slice-before ( slice -- slice' )
 148     [ drop 0 ] [ from>> ] [ seq>> ] tri <slice> ;
 149
 150 : (?nth) ( n/f string/f -- obj/f )
 151     over [ (?nth) ] [ 2drop f ] if ;
 152
 153 :: merge-slice-til-eol-slash' ( n string slice -- n' string slice/f ch/f )
 154     n string merge-slice-til-eol-slash'' :> ( n' string' slice' ch' )
 155     ch' CHAR: \\ = [
 156         n' 1 + string' (?nth) "\r\n" member? [
 157             n' 2 + string' slice slice' span-slices merge-slice-til-eol-slash'
 158         ] [
 159             "omg" throw
 160         ] if
 161     ] [
 162         n' string' slice slice' span-slices ch'
 163     ] if ;
 164
 165 ! Supports \ at eol (with no space after it)
 166 : slice-til-eol-slash ( n string -- n' string slice/f ch/f )
 167     2dup empty-slice-from merge-slice-til-eol-slash' ;
 168
 169 :: slice-til-separator-inclusive ( n string tokens -- n' string slice/f ch/f )
 170     n string '[ tokens member? ] find-from [ dup [ 1 + ] when ] dip  :> ( n' ch )
 171     n' string
 172     n n' string ?<slice>
 173     ch ; inline
 174
 175 : slice-til-separator-exclusive ( n string tokens -- n' string slice/f ch/f )
 176     slice-til-separator-inclusive dup [
 177         [ [ 1 - ] change-to ] dip
 178     ] when ;
 179
 180 ! Takes at least one character if not whitespace
 181 :: slice-til-either ( n string tokens -- n'/f string slice/f ch/f )
 182     n [
 183         n string '[ tokens member? ] find-from
 184         dup "\s\r\n" member? [
 185             :> ( n' ch )
 186             n' string
 187             n n' string ?<slice>
 188             ch
 189         ] [
 190             [ dup [ 1 + ] when ] dip :> ( n' ch )
 191             n' string
 192             n n' string ?<slice>
 193             ch
 194         ] if
 195     ] [
 196         f string f f
 197     ] if ; inline
 198
 199 ERROR: subseq-expected-but-got-eof n string expected ;
 200
 201 :: slice-til-string ( n string search --  n' string payload end-string )
 202     search string n subseq-start-from :> n'
 203     n' [ n string search subseq-expected-but-got-eof ] unless
 204     n' search length +  string
 205     n n' string ?<slice>
 206     n' dup search length + string ?<slice> ;
 207
 208 : modify-from ( slice n -- slice' )
 209     '[ from>> _ + ] [ to>> ] [ seq>> ] tri <slice> ;
 210
 211 : modify-to ( slice n -- slice' )
 212     [ [ from>> ] [ to>> ] [ seq>> ] tri ] dip
 213     swap [ + ] dip <slice> ;
 214
 215 ! { CHAR: \] [ read-closing ] }
 216 ! { CHAR: \} [ read-closing ] }
 217 ! { CHAR: \) [ read-closing ] }
 218 : read-closing ( n string tok -- n string tok )
 219     dup length 1 = [
 220         -1 modify-to [ 1 - ] 2dip
 221     ] unless ;
 222
 223 : rewind-slice ( n string slice -- n' string )
 224     pick [
 225         length swap [ - ] dip
 226     ] [
 227         [ nip ] dip [ [ length ] bi@ - ] 2keep drop
 228     ] if ; inline