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 fry io
   5 io.streams.string io.styles kernel math math.functions
   6 math.vectors namespaces sequences strings strings.tables ;
   7
   8 IN: io.streams.ansi
   9
  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 : color>foreground ( color -- string )
  45     color>ansi [ 30 + ] [ "m" ";1m" ? ] bi* "\e[%d%s" sprintf ;
  46
  47 : color>background ( color -- string )
  48     color>ansi [ 40 + ] [ "m" ";1m" ? ] bi* "\e[%d%s" sprintf ;
  49
  50 : font-styles ( font-style -- string )
  51     H{
  52         { bold "\e[1m" }
  53         { italic "\e[3m" }
  54         { bold-italic "\e[1m\e[3m" }
  55     } at "" or ;
  56
  57 TUPLE: ansi stream ;
  58
  59 C: <ansi> ansi
  60
  61 M: ansi stream-write1 stream>> stream-write1 ;
  62 M: ansi stream-write stream>> stream-write ;
  63 M: ansi stream-flush stream>> stream-flush ;
  64 M: ansi stream-nl stream>> stream-nl ;
  65
  66 M: ansi stream-format
  67     [
  68         [ foreground of [ color>foreground ] [ "" ] if* ]
  69         [ background of [ color>background ] [ "" ] if* ]
  70         [ font-style of [ font-styles ] [ "" ] if* ]
  71         tri 3append [ "\e[0m" surround ] unless-empty
  72     ] dip stream>> stream-write ;
  73
  74 M: ansi make-span-stream
  75     swap <style-stream> <ignore-close-stream> ;
  76
  77 M: ansi make-block-stream
  78     swap <style-stream> <ignore-close-stream> ;
  79
  80 ! FIXME: color codes take up formatting space
  81
  82 M: ansi stream-write-table
  83     [
  84         drop
  85         [ [ stream>> >string ] map ] map format-table
  86         [ nl ] [ write ] interleave
  87     ] with-output-stream* ;
  88
  89 M: ansi make-cell-stream
  90      2drop <string-writer> <ansi> ;
  91
  92 M: ansi dispose drop ;
  93
  94 PRIVATE>
  95
  96 : with-ansi ( quot -- )
  97     output-stream get <ansi> swap with-output-stream* ; inline