extra/io/streams/ansi/ansi.factor

   1 ! Copyright (C) 2014 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors arrays assocs destructors formatting io
   5 io.streams.escape-codes io.streams.string io.styles kernel math
   6 math.functions math.vectors namespaces sequences strings
   7 strings.tables ;
   8
   9 IN: io.streams.ansi
  10 <PRIVATE
  11
  12 CONSTANT: colors H{
  13
  14     ! System colors (8 colors)
  15     { {   0   0   0 } 0 }
  16     { { 170   0   0 } 1 }
  17     { {   0 170   0 } 2 }
  18     { { 170  85   0 } 3 }
  19     { {   0   0 170 } 4 }
  20     { { 170   0 170 } 5 }
  21     { {   0 170 170 } 6 }
  22     { { 170 170 170 } 7 }
  23
  24     ! "Bright" version of 8 colors
  25     { {  85  85  85 } 8 }
  26     { { 255  85  85 } 9 }
  27     { {  85 255  85 } 10 }
  28     { { 255 255  85 } 11 }
  29     { {  85  85 255 } 12 }
  30     { { 255  85 255 } 13 }
  31     { {  85 255 255 } 14 }
  32     { { 255 255 255 } 15 }
  33 }
  34
  35 : color>rgb ( color -- rgb )
  36     [ red>> ] [ green>> ] [ blue>> ] tri
  37     [ 255 * round >integer ] tri@ 3array ;
  38
  39 : color>ansi ( color -- ansi bold? )
  40     color>rgb '[ _ distance ]
  41     colors [ keys swap infimum-by ] [ at ] bi
  42     dup 8 >= [ 8 - t ] [ f ] if ;
  43
  44 MEMO: color>foreground ( color -- string )
  45     color>ansi [ 30 + ] [ "m" ";1m" ? ] bi* "\e[%d%s" sprintf ;
  46
  47 MEMO: color>background ( color -- string )
  48     color>ansi [ 40 + ] [ "m" ";1m" ? ] bi* "\e[%d%s" sprintf ;
  49
  50 TUPLE: ansi < filter-writer ;
  51
  52 C: <ansi> ansi
  53
  54 M:: ansi stream-format ( str style stream -- )
  55     stream stream>> :> out
  56     style foreground of [ color>foreground out stream-write t ] [ f ] if*
  57     style background of [ color>background out stream-write t ] [ f ] if*
  58     style font-style of [ font-styles out stream-write t ] [ f ] if*
  59     or or [ "\e[0m" out stream-write ] unless
  60     str out stream-write ;
  61
  62 M: ansi make-span-stream
  63     swap <style-stream> <ignore-close-stream> ;
  64
  65 M: ansi make-block-stream
  66     swap <style-stream> <ignore-close-stream> ;
  67
  68 ! FIXME: color codes take up formatting space
  69
  70 M: ansi stream-write-table
  71     [
  72         drop
  73         [ [ stream>> >string ] map ] map format-table
  74         [ nl ] [ write ] interleave
  75     ] with-output-stream* ;
  76
  77 M: ansi make-cell-stream
  78      2drop <string-writer> <ansi> ;
  79
  80 M: ansi dispose drop ;
  81
  82 PRIVATE>
  83
  84 : with-ansi ( quot -- )
  85     output-stream get <ansi> swap with-output-stream* ; inline