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

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