core/io/encodings/utf8/utf8.factor

   1 ! Copyright (C) 2006, 2008 Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors byte-arrays math math.order kernel sequences
   4 sbufs vectors growable io continuations namespaces io.encodings
   5 combinators strings ;
   6 IN: io.encodings.utf8
   7
   8 ! Decoding UTF-8
   9
  10 SINGLETON: utf8
  11
  12 <PRIVATE
  13
  14 : starts-2? ( char -- ? )
  15     dup [ -6 shift 0b10 number= ] when ; inline
  16
  17 : append-nums ( stream byte -- stream char )
  18     over stream-read1 dup starts-2?
  19     [ [ 6 shift ] dip 0b111111 bitand bitor ]
  20     [ 2drop replacement-char ] if ; inline
  21
  22 : minimum-code-point ( char minimum -- char )
  23     over > [ drop replacement-char ] when ; inline
  24
  25 : maximum-code-point ( char maximum -- char )
  26     over < [ drop replacement-char ] when ; inline
  27
  28 : double ( stream byte -- stream char )
  29     0b11111 bitand append-nums
  30     0x80 minimum-code-point ; inline
  31
  32 : triple ( stream byte -- stream char )
  33     0b1111 bitand append-nums append-nums
  34     0x800 minimum-code-point ; inline
  35
  36 : quadruple ( stream byte -- stream char )
  37     0b111 bitand append-nums append-nums append-nums
  38     0x10000 minimum-code-point
  39     0x10FFFF maximum-code-point ; inline
  40
  41 : begin-utf8 ( stream byte -- stream char )
  42     dup 127 > [
  43         {
  44             { [ dup -5 shift 0b110 = ] [ double ] }
  45             { [ dup -4 shift 0b1110 = ] [ triple ] }
  46             { [ dup -3 shift 0b11110 = ] [ quadruple ] }
  47             [ drop replacement-char ]
  48         } cond
  49     ] when ; inline
  50
  51 : decode-utf8 ( stream -- char/f )
  52     dup stream-read1 dup [ begin-utf8 ] when nip ; inline
  53
  54 M: utf8 decode-char
  55     drop decode-utf8 ; inline
  56
  57 ! Encoding UTF-8
  58
  59 : encoded ( stream char -- )
  60     0b111111 bitand 0b10000000 bitor swap stream-write1 ; inline
  61
  62 : char>utf8 ( char stream -- )
  63     over 127 <= [ stream-write1 ] [
  64         swap {
  65             { [ dup -11 shift zero? ] [
  66                 2dup -6 shift 0b11000000 bitor swap stream-write1
  67                 encoded
  68             ] }
  69             { [ dup -16 shift zero? ] [
  70                 2dup -12 shift 0b11100000 bitor swap stream-write1
  71                 2dup -6 shift encoded
  72                 encoded
  73             ] }
  74             [
  75                 2dup -18 shift 0b11110000 bitor swap stream-write1
  76                 2dup -12 shift encoded
  77                 2dup -6 shift encoded
  78                 encoded
  79             ]
  80         } cond
  81     ] if ; inline
  82
  83 M: utf8 encode-char
  84     drop char>utf8 ;
  85
  86 M: utf8 encode-string
  87     drop
  88     over aux>>
  89     [ [ char>utf8 ] curry each ]
  90     [ [ >byte-array ] dip stream-write ] if ;
  91
  92 PRIVATE>
  93
  94 : code-point-length ( n -- x )
  95     [ 1 ] [
  96         log2 {
  97             { [ dup 0 6 between? ] [ 1 ] }
  98             { [ dup 7 10 between? ] [ 2 ] }
  99             { [ dup 11 15 between? ] [ 3 ] }
 100             { [ dup 16 20 between? ] [ 4 ] }
 101         } cond nip
 102     ] if-zero ;
 103
 104 : code-point-offsets ( string -- indices )
 105     0 [ code-point-length + ] accumulate swap suffix ;
 106
 107 : utf8-index> ( n string -- n' )
 108     code-point-offsets [ <= ] with find drop ;
 109
 110 : >utf8-index ( n string -- n' )
 111     code-point-offsets nth ;