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