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