basis/escape-strings/escape-strings.factor

   1 ! Copyright (C) 2017 John Benediktsson, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: ascii assocs checksums checksums.sha combinators
   4 kernel math math.functions math.parser ranges
   5 math.statistics sequences sets sorting splitting strings uuid ;
   6 IN: escape-strings
   7
   8 : find-escapes ( str -- set )
   9     [ HS{ } clone 0 0 ] dip
  10     [
  11         {
  12             { CHAR: ] [ 1 + dup 2 = [ drop over adjoin 0 1 ] when ] }
  13             { CHAR: = [ dup 1 = [ [ 1 + ] dip ] when ] }
  14             [ 3drop 0 0 ]
  15         } case
  16     ] each 0 > [ over adjoin ] [ drop ] if ;
  17
  18 : find-number-escapes ( str -- set )
  19     [ HS{ } clone SBUF" " clone 0 ] dip
  20     [
  21         {
  22             { [ dup CHAR: ] = ] [
  23                 drop 1 + dup 2 = [
  24                     drop dup >string pick adjoin
  25                     0 over set-length 1
  26                 ] when
  27             ] }
  28             { [ dup digit? ] [ [ dup 1 = ] dip '[ [ _ over push ] dip ] [ ] if ] }
  29             [ 2drop 0 over set-length 0 ]
  30         } cond
  31     ] each 0 > [ >string over adjoin ] [ drop ] if ;
  32
  33 : lowest-missing-number ( string-set -- min )
  34     members dup
  35     [ length ] histogram-by
  36     dup keys length [0..b]
  37     [ [ of ] keep over [ 10^ < ] [ nip ] if ] with find nip
  38     [ '[ length _ = ] filter natural-sort ] keep ! remove natural-sort here
  39     [
  40         [ drop "" ] [
  41             10^ <iota> [
  42                 [ swap ?nth dup [ string>number ] when ] keep = not
  43             ] with find nip number>string
  44         ] if-zero
  45     ] keep CHAR: 0 pad-head ;
  46
  47 : lowest-missing ( set -- min )
  48     members dup [ = not ] find-index
  49     [ nip ] [ drop length ] if ;
  50
  51 : surround-by-brackets ( str delim -- str' )
  52     [ "[" 1surround ] [ "]" 1surround ] bi surround ;
  53
  54 : surround-by-equals-brackets ( str n -- str' )
  55     CHAR: = <repetition> surround-by-brackets ;
  56
  57 : escape-string ( str -- str' )
  58     dup find-escapes lowest-missing surround-by-equals-brackets ;
  59
  60 : escape-strings ( strs -- str )
  61     [ escape-string ] map concat escape-string ;
  62
  63 : number-escape-string ( str -- str' )
  64     dup find-number-escapes lowest-missing-number surround-by-brackets ;
  65
  66 : number-escape-strings ( strs -- str )
  67     [ number-escape-string ] map concat number-escape-string ;
  68
  69 : tag-payload ( str tag -- str' )
  70     [ escape-string ] dip prepend ;
  71
  72 : escape-simplest ( str -- str' )
  73     dup histogram {
  74         ! { [ dup { CHAR: ' CHAR: \r CHAR: \n CHAR: \s } values-of sum 0 = ] [ drop "'" prepend ] }
  75         { [ dup CHAR: " of not ] [ drop "\"" "\"" surround ] }
  76         [ drop escape-string ]
  77     } cond ;
  78
  79 : uuid1-escape-string ( str -- str' ) uuid1 surround-by-brackets ;
  80 : uuid4-escape-string ( str -- str' ) uuid4 surround-by-brackets ;
  81
  82 : sha1-escape-string ( str -- str' )
  83     [ ] [ sha1 checksum-bytes bytes>hex-string ] bi surround-by-brackets ;
  84
  85 : sha256-escape-string ( str -- str' )
  86     [ ] [ sha-256 checksum-bytes bytes>hex-string ] bi surround-by-brackets ;
  87
  88 GENERIC: sha1-escape-strings ( obj -- strs )
  89
  90 M: sequence sha1-escape-strings ( seq -- strs )
  91     [ sha1-escape-string ] { } map-as ;
  92
  93 M: string sha1-escape-strings ( str -- strs )
  94     split-lines sha1-escape-strings ;