basis/io/encodings/8-bit/8-bit.factor

   1 ! Copyright (C) 2008 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: math.parser arrays io.encodings sequences kernel assocs
   4 hashtables io.encodings.ascii generic parser classes.tuple words
   5 io io.files splitting namespaces math compiler.units accessors ;
   6 IN: io.encodings.8-bit
   7
   8 <PRIVATE
   9
  10 : mappings {
  11     { "latin1" "8859-1" }
  12     { "latin2" "8859-2" }
  13     { "latin3" "8859-3" }
  14     { "latin4" "8859-4" }
  15     { "latin/cyrillic" "8859-5" }
  16     { "latin/arabic" "8859-6" }
  17     { "latin/greek" "8859-7" }
  18     { "latin/hebrew" "8859-8" }
  19     { "latin5" "8859-9" }
  20     { "latin6" "8859-10" }
  21     { "latin/thai" "8859-11" }
  22     { "latin7" "8859-13" }
  23     { "latin8" "8859-14" }
  24     { "latin9" "8859-15" }
  25     { "latin10" "8859-16" }
  26     { "koi8-r" "KOI8-R" }
  27     { "windows-1252" "CP1252" }
  28     { "ebcdic" "CP037" }
  29     { "mac-roman" "ROMAN" }
  30 } ;
  31
  32 : encoding-file ( file-name -- stream )
  33     "resource:basis/io/encodings/8-bit/" swap ".TXT"
  34     3append ascii <file-reader> ;
  35
  36 : process-contents ( lines -- assoc )
  37     [ "#" split1 drop ] map harvest
  38     [ "\t" split 2 head [ 2 short tail hex> ] map ] map ;
  39
  40 : byte>ch ( assoc -- array )
  41     256 replacement-char <array>
  42     [ [ swapd set-nth ] curry assoc-each ] keep ;
  43
  44 : ch>byte ( assoc -- newassoc )
  45     [ swap ] assoc-map >hashtable ;
  46
  47 : parse-file ( path -- byte>ch ch>byte )
  48     lines process-contents
  49     [ byte>ch ] [ ch>byte ] bi ;
  50
  51 SYMBOL: 8-bit-encodings
  52
  53 TUPLE: 8-bit decode encode ;
  54
  55 : encode-8-bit ( char stream assoc -- )
  56     swapd at*
  57     [ swap stream-write1 ] [ nip encode-error ] if ; inline
  58
  59 M: 8-bit encode-char encode>> encode-8-bit ;
  60
  61 : decode-8-bit ( stream array -- char/f )
  62     swap stream-read1 dup
  63     [ swap nth [ replacement-char ] unless* ] [ 2drop f ] if ; inline
  64
  65 M: 8-bit decode-char decode>> decode-8-bit ;
  66
  67 PREDICATE: 8-bit-encoding < word
  68     8-bit-encodings get-global key? ;
  69
  70 M: 8-bit-encoding <encoder>
  71     8-bit-encodings get-global at <encoder> ;
  72
  73 M: 8-bit-encoding <decoder>
  74     8-bit-encodings get-global at <decoder> ;
  75
  76 PRIVATE>
  77
  78 [
  79     mappings [
  80         [ "io.encodings.8-bit" create ]
  81         [ encoding-file parse-file 8-bit boa ]
  82         bi*
  83     ] assoc-map
  84     [ keys [ define-symbol ] each ]
  85     [ 8-bit-encodings set-global ]
  86     bi
  87 ] with-compilation-unit