1 module Language.Symantic.Document.ANSI where
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
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
19 import Language.Symantic.Document.Sym
22 newtype ANSI = ANSI { unANSI :: [SGR] -> TLB.Builder }
23 instance IsString ANSI where
24 fromString s = ANSI $ const t
25 where t = fromString s
27 ansi :: ANSI -> TLB.Builder
30 pushSGR :: SGR -> ANSI -> ANSI
31 pushSGR c (ANSI d) = ANSI $ \cs ->
32 fromString (setSGRCode [c]) <>
34 fromString (setSGRCode $ Reset:L.reverse cs)
36 instance Semigroup ANSI where
37 ANSI x <> ANSI y = ANSI $ \c -> x c <> y c
38 instance Monoid ANSI where
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
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
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
98 ansiIO :: ANSI_IO -> IO.Handle -> IO ()
99 ansiIO (ANSI_IO d) = d []
101 pushSGR_IO :: SGR -> ANSI_IO -> ANSI_IO
102 pushSGR_IO c (ANSI_IO d) = ANSI_IO $ \cs h -> do
105 hSetSGR h $ Reset:L.reverse cs
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
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
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