symantic-document/Language/Symantic/Document/ANSI.hs

   1 module Language.Symantic.Document.ANSI where
   2
   3 import Control.Monad (Monad(..))
   4 import Data.Bool (Bool(..))
   5 import Data.Function (($), (.))
   6 import Data.Monoid (Monoid(..))
   7 import Data.Semigroup (Semigroup(..))
   8 import Data.String (IsString(..))
   9 import Prelude (fromInteger, toInteger)
  10 import System.Console.ANSI
  11 import System.IO (IO)
  12 import Text.Show (Show(..))
  13 import qualified Data.List as L
  14 import qualified Data.Text.IO as T
  15 import qualified Data.Text.Lazy as TL
  16 import qualified Data.Text.Lazy.Builder as TLB
  17 import qualified Data.Text.Lazy.IO as TL
  18 import qualified System.IO as IO
  19
  20 import Language.Symantic.Document.Sym
  21
  22 -- * Type 'ANSI'
  23 newtype ANSI = ANSI { unANSI :: [SGR] -> TLB.Builder }
  24 instance IsString ANSI where
  25         fromString s = ANSI $ \_c -> t
  26                 where t = fromString s
  27
  28 ansi :: ANSI -> TLB.Builder
  29 ansi (ANSI d) = d []
  30
  31 pushSGR :: SGR -> ANSI -> ANSI
  32 pushSGR c (ANSI d) = ANSI $ \cs ->
  33         fromString (setSGRCode [c]) <>
  34         d (c:cs) <>
  35         fromString (setSGRCode $ Reset:L.reverse cs)
  36
  37 instance Semigroup ANSI where
  38         ANSI x <> ANSI y = ANSI $ \c -> x c <> y c
  39 instance Monoid ANSI where
  40         mempty  = empty
  41         mappend = (<>)
  42 instance Doc_Text ANSI where
  43         spaces  i = ANSI $ \_ -> TLB.fromLazyText $ TL.replicate (int64 i) " "
  44                 where int64 = fromInteger . toInteger
  45         int     i = ANSI $ \_ -> fromString $ show i
  46         integer i = ANSI $ \_ -> fromString $ show i
  47         char    x = ANSI $ \_ -> TLB.singleton    x
  48         string  x = ANSI $ \_ -> fromString       x
  49         text    x = ANSI $ \_ -> TLB.fromText     x
  50         ltext   x = ANSI $ \_ -> TLB.fromLazyText x
  51         charH     = char
  52         stringH   = string
  53         textH     = text
  54         ltextH    = ltext
  55 instance Doc_Color ANSI where
  56         reverse     = pushSGR $ SetSwapForegroundBackground True
  57         black       = pushSGR $ SetColor Foreground Dull  Black
  58         red         = pushSGR $ SetColor Foreground Dull  Red
  59         green       = pushSGR $ SetColor Foreground Dull  Green
  60         yellow      = pushSGR $ SetColor Foreground Dull  Yellow
  61         blue        = pushSGR $ SetColor Foreground Dull  Blue
  62         magenta     = pushSGR $ SetColor Foreground Dull  Magenta
  63         cyan        = pushSGR $ SetColor Foreground Dull  Cyan
  64         white       = pushSGR $ SetColor Foreground Dull  White
  65         blacker     = pushSGR $ SetColor Foreground Vivid Black
  66         redder      = pushSGR $ SetColor Foreground Vivid Red
  67         greener     = pushSGR $ SetColor Foreground Vivid Green
  68         yellower    = pushSGR $ SetColor Foreground Vivid Yellow
  69         bluer       = pushSGR $ SetColor Foreground Vivid Blue
  70         magentaer   = pushSGR $ SetColor Foreground Vivid Magenta
  71         cyaner      = pushSGR $ SetColor Foreground Vivid Cyan
  72         whiter      = pushSGR $ SetColor Foreground Vivid White
  73         onBlack     = pushSGR $ SetColor Background Dull  Black
  74         onRed       = pushSGR $ SetColor Background Dull  Red
  75         onGreen     = pushSGR $ SetColor Background Dull  Green
  76         onYellow    = pushSGR $ SetColor Background Dull  Yellow
  77         onBlue      = pushSGR $ SetColor Background Dull  Blue
  78         onMagenta   = pushSGR $ SetColor Background Dull  Magenta
  79         onCyan      = pushSGR $ SetColor Background Dull  Cyan
  80         onWhite     = pushSGR $ SetColor Background Dull  White
  81         onBlacker   = pushSGR $ SetColor Background Vivid Black
  82         onRedder    = pushSGR $ SetColor Background Vivid Red
  83         onGreener   = pushSGR $ SetColor Background Vivid Green
  84         onYellower  = pushSGR $ SetColor Background Vivid Yellow
  85         onBluer     = pushSGR $ SetColor Background Vivid Blue
  86         onMagentaer = pushSGR $ SetColor Background Vivid Magenta
  87         onCyaner    = pushSGR $ SetColor Background Vivid Cyan
  88         onWhiter    = pushSGR $ SetColor Background Vivid White
  89 instance Doc_Decoration ANSI where
  90         bold        = pushSGR $ SetConsoleIntensity BoldIntensity
  91         underline   = pushSGR $ SetUnderlining SingleUnderline
  92         italic      = pushSGR $ SetItalicized True
  93
  94 -- * Type 'ANSI_IO'
  95 newtype ANSI_IO = ANSI_IO { unANSI_IO :: [SGR] -> IO.Handle -> IO () }
  96 instance IsString ANSI_IO where
  97         fromString s = ANSI_IO $ \_c h -> IO.hPutStr h t
  98                 where t = fromString s
  99
 100 ansiIO :: ANSI_IO -> IO.Handle -> IO ()
 101 ansiIO (ANSI_IO d) = d []
 102
 103 pushSGR_IO :: SGR -> ANSI_IO -> ANSI_IO
 104 pushSGR_IO c (ANSI_IO d) = ANSI_IO $ \cs h -> do
 105         hSetSGR h [c]
 106         d (c:cs) h
 107         hSetSGR h $ Reset:L.reverse cs
 108
 109 instance Semigroup ANSI_IO where
 110         ANSI_IO x <> ANSI_IO y = ANSI_IO $ \c h -> do {x c h; y c h}
 111 instance Monoid ANSI_IO where
 112         mempty  = empty
 113         mappend = (<>)
 114 instance Doc_Text ANSI_IO where
 115         empty       = ANSI_IO $ \_ _ -> return ()
 116         spaces  i   = ANSI_IO $ \_ h -> IO.hPutStr  h (L.replicate i ' ')
 117         int     i   = ANSI_IO $ \_ h -> IO.hPutStr  h (show i)
 118         integer i   = ANSI_IO $ \_ h -> IO.hPutStr  h (show i)
 119         char    x   = ANSI_IO $ \_ h -> IO.hPutChar h x
 120         string  x   = ANSI_IO $ \_ h -> IO.hPutStr  h x
 121         text    x   = ANSI_IO $ \_ h -> T.hPutStr   h x
 122         ltext   x   = ANSI_IO $ \_ h -> TL.hPutStr  h x
 123         charH       = char
 124         stringH     = string
 125         textH       = text
 126         ltextH      = ltext
 127 instance Doc_Color ANSI_IO where
 128         reverse     = pushSGR_IO $ SetSwapForegroundBackground True
 129         black       = pushSGR_IO $ SetColor Foreground Dull  Black
 130         red         = pushSGR_IO $ SetColor Foreground Dull  Red
 131         green       = pushSGR_IO $ SetColor Foreground Dull  Green
 132         yellow      = pushSGR_IO $ SetColor Foreground Dull  Yellow
 133         blue        = pushSGR_IO $ SetColor Foreground Dull  Blue
 134         magenta     = pushSGR_IO $ SetColor Foreground Dull  Magenta
 135         cyan        = pushSGR_IO $ SetColor Foreground Dull  Cyan
 136         white       = pushSGR_IO $ SetColor Foreground Dull  White
 137         blacker     = pushSGR_IO $ SetColor Foreground Vivid Black
 138         redder      = pushSGR_IO $ SetColor Foreground Vivid Red
 139         greener     = pushSGR_IO $ SetColor Foreground Vivid Green
 140         yellower    = pushSGR_IO $ SetColor Foreground Vivid Yellow
 141         bluer       = pushSGR_IO $ SetColor Foreground Vivid Blue
 142         magentaer   = pushSGR_IO $ SetColor Foreground Vivid Magenta
 143         cyaner      = pushSGR_IO $ SetColor Foreground Vivid Cyan
 144         whiter      = pushSGR_IO $ SetColor Foreground Vivid White
 145         onBlack     = pushSGR_IO $ SetColor Background Dull  Black
 146         onRed       = pushSGR_IO $ SetColor Background Dull  Red
 147         onGreen     = pushSGR_IO $ SetColor Background Dull  Green
 148         onYellow    = pushSGR_IO $ SetColor Background Dull  Yellow
 149         onBlue      = pushSGR_IO $ SetColor Background Dull  Blue
 150         onMagenta   = pushSGR_IO $ SetColor Background Dull  Magenta
 151         onCyan      = pushSGR_IO $ SetColor Background Dull  Cyan
 152         onWhite     = pushSGR_IO $ SetColor Background Dull  White
 153         onBlacker   = pushSGR_IO $ SetColor Background Vivid Black
 154         onRedder    = pushSGR_IO $ SetColor Background Vivid Red
 155         onGreener   = pushSGR_IO $ SetColor Background Vivid Green
 156         onYellower  = pushSGR_IO $ SetColor Background Vivid Yellow
 157         onBluer     = pushSGR_IO $ SetColor Background Vivid Blue
 158         onMagentaer = pushSGR_IO $ SetColor Background Vivid Magenta
 159         onCyaner    = pushSGR_IO $ SetColor Background Vivid Cyan
 160         onWhiter    = pushSGR_IO $ SetColor Background Vivid White
 161 instance Doc_Decoration ANSI_IO where
 162         bold        = pushSGR_IO $ SetConsoleIntensity BoldIntensity
 163         underline   = pushSGR_IO $ SetUnderlining SingleUnderline
 164         italic      = pushSGR_IO $ SetItalicized True