]> Git — Sourcephile - haskell/symantic-plaintext.git/blob - Symantic/Document/AnsiText.hs
plain: fix flushing in align and ul/ol
[haskell/symantic-plaintext.git] / Symantic / Document / AnsiText.hs
1 {-# LANGUAGE UndecidableInstances #-}
2 module Symantic.Document.AnsiText where
3
4 import Control.Applicative (Applicative(..), liftA2)
5 import Control.Monad (Monad(..), sequence)
6 import Control.Monad.Trans.Reader
7 import Data.Bool
8 import Data.Char (Char)
9 import Data.Function (($), (.), id)
10 import Data.Functor ((<$>))
11 import Data.Monoid (Monoid(..))
12 import Data.Semigroup (Semigroup(..))
13 import Data.String (String, IsString(..))
14 import Data.Text (Text)
15 import System.Console.ANSI
16 import Text.Show (Show(..))
17 import qualified Data.List as List
18 import qualified Data.Text.Lazy as TL
19
20 import Symantic.Document.API
21
22 -- * Type 'AnsiText'
23 newtype AnsiText d = AnsiText { unAnsiText :: Reader [SGR] d }
24 instance Show d => Show (AnsiText d) where
25 show (AnsiText d) = show $ runReader d []
26
27 ansiText :: AnsiText d -> AnsiText d
28 ansiText = id
29
30 runAnsiText :: AnsiText d -> d
31 runAnsiText (AnsiText d) = (`runReader` []) d
32
33 instance From Char d => From Char (AnsiText d) where
34 from = AnsiText . return . from
35 instance From String d => From String (AnsiText d) where
36 from = AnsiText . return . from
37 instance From Text d => From Text (AnsiText d) where
38 from = AnsiText . return . from
39 instance From TL.Text d => From TL.Text (AnsiText d) where
40 from = AnsiText . return . from
41 instance From s (AnsiText d) => From (Line s) (AnsiText d) where
42 from = from . unLine
43 instance From s (AnsiText d) => From (Word s) (AnsiText d) where
44 from = from . unWord
45 instance From String d => IsString (AnsiText d) where
46 fromString = from
47 instance Semigroup d => Semigroup (AnsiText d) where
48 AnsiText x <> AnsiText y = AnsiText $ liftA2 (<>) x y
49 instance Monoid d => Monoid (AnsiText d) where
50 mempty = AnsiText (return mempty)
51 mappend = (<>)
52 instance Lengthable d => Lengthable (AnsiText d) where
53 -- NOTE: AnsiText's Reader can be run with an empty value
54 -- because all 'SGR' are ignored anyway.
55 width (AnsiText ds) = width $ runReader ds mempty
56 nullWidth (AnsiText ds) = nullWidth $ runReader ds mempty
57 instance Spaceable d => Spaceable (AnsiText d) where
58 newline = AnsiText $ return newline
59 space = AnsiText $ return space
60 spaces = AnsiText . return . spaces
61 instance (Semigroup d, From [SGR] d) => Colorable16 (AnsiText d) where
62 reverse = ansiTextSGR $ SetSwapForegroundBackground True
63 black = ansiTextSGR $ SetColor Foreground Dull Black
64 red = ansiTextSGR $ SetColor Foreground Dull Red
65 green = ansiTextSGR $ SetColor Foreground Dull Green
66 yellow = ansiTextSGR $ SetColor Foreground Dull Yellow
67 blue = ansiTextSGR $ SetColor Foreground Dull Blue
68 magenta = ansiTextSGR $ SetColor Foreground Dull Magenta
69 cyan = ansiTextSGR $ SetColor Foreground Dull Cyan
70 white = ansiTextSGR $ SetColor Foreground Dull White
71 blacker = ansiTextSGR $ SetColor Foreground Vivid Black
72 redder = ansiTextSGR $ SetColor Foreground Vivid Red
73 greener = ansiTextSGR $ SetColor Foreground Vivid Green
74 yellower = ansiTextSGR $ SetColor Foreground Vivid Yellow
75 bluer = ansiTextSGR $ SetColor Foreground Vivid Blue
76 magentaer = ansiTextSGR $ SetColor Foreground Vivid Magenta
77 cyaner = ansiTextSGR $ SetColor Foreground Vivid Cyan
78 whiter = ansiTextSGR $ SetColor Foreground Vivid White
79 onBlack = ansiTextSGR $ SetColor Background Dull Black
80 onRed = ansiTextSGR $ SetColor Background Dull Red
81 onGreen = ansiTextSGR $ SetColor Background Dull Green
82 onYellow = ansiTextSGR $ SetColor Background Dull Yellow
83 onBlue = ansiTextSGR $ SetColor Background Dull Blue
84 onMagenta = ansiTextSGR $ SetColor Background Dull Magenta
85 onCyan = ansiTextSGR $ SetColor Background Dull Cyan
86 onWhite = ansiTextSGR $ SetColor Background Dull White
87 onBlacker = ansiTextSGR $ SetColor Background Vivid Black
88 onRedder = ansiTextSGR $ SetColor Background Vivid Red
89 onGreener = ansiTextSGR $ SetColor Background Vivid Green
90 onYellower = ansiTextSGR $ SetColor Background Vivid Yellow
91 onBluer = ansiTextSGR $ SetColor Background Vivid Blue
92 onMagentaer = ansiTextSGR $ SetColor Background Vivid Magenta
93 onCyaner = ansiTextSGR $ SetColor Background Vivid Cyan
94 onWhiter = ansiTextSGR $ SetColor Background Vivid White
95 instance (Semigroup d, From [SGR] d) => Decorable (AnsiText d) where
96 bold = ansiTextSGR $ SetConsoleIntensity BoldIntensity
97 underline = ansiTextSGR $ SetUnderlining SingleUnderline
98 italic = ansiTextSGR $ SetItalicized True
99 instance Justifiable d => Justifiable (AnsiText d) where
100 justify (AnsiText d) = AnsiText $ justify <$> d
101 instance Indentable d => Indentable (AnsiText d) where
102 setIndent i (AnsiText d) = AnsiText $ setIndent i <$> d
103 incrIndent i (AnsiText d) = AnsiText $ incrIndent i <$> d
104 fill w (AnsiText d) = AnsiText $ fill w <$> d
105 breakfill w (AnsiText d) = AnsiText $ breakfill w <$> d
106 align (AnsiText d) = AnsiText $ align <$> d
107 instance Listable d => Listable (AnsiText d) where
108 ul ds = AnsiText $ (ul <$>) $ sequence $ unAnsiText <$> ds
109 ol ds = AnsiText $ (ol <$>) $ sequence $ unAnsiText <$> ds
110 instance Wrappable d => Wrappable (AnsiText d) where
111 setWidth w (AnsiText d) = AnsiText $ setWidth w <$> d
112 breakpoint = AnsiText $ return breakpoint
113 breakspace = AnsiText $ return breakspace
114 breakalt (AnsiText x) (AnsiText y) = AnsiText $ liftA2 breakalt x y
115
116 ansiTextSGR ::
117 Semigroup d => From [SGR] d =>
118 SGR -> AnsiText d -> AnsiText d
119 ansiTextSGR newSGR (AnsiText d) = AnsiText $ do
120 oldSGR <- ask
121 (\m -> from [newSGR] <> m <> from (Reset:List.reverse oldSGR))
122 <$> local (newSGR :) d
123
124 -- * Type 'PlainText'
125 -- | Drop 'Colorable16' and 'Decorable'.
126 newtype PlainText d = PlainText { unPlainText :: d }
127 deriving (Show)
128
129 plainText :: PlainText d -> PlainText d
130 plainText = id
131
132 runPlainText :: PlainText d -> d
133 runPlainText (PlainText d) = d
134
135 instance From Char d => From Char (PlainText d) where
136 from = PlainText . from
137 instance From String d => From String (PlainText d) where
138 from = PlainText . from
139 instance From Text d => From Text (PlainText d) where
140 from = PlainText . from
141 instance From TL.Text d => From TL.Text (PlainText d) where
142 from = PlainText . from
143 instance From s (PlainText d) => From (Line s) (PlainText d) where
144 from = from . unLine
145 instance From s (PlainText d) => From (Word s) (PlainText d) where
146 from = from . unWord
147 instance From String d => IsString (PlainText d) where
148 fromString = from
149 instance Semigroup d => Semigroup (PlainText d) where
150 PlainText x <> PlainText y = PlainText $ (<>) x y
151 instance Monoid d => Monoid (PlainText d) where
152 mempty = PlainText mempty
153 mappend = (<>)
154 instance Lengthable d => Lengthable (PlainText d) where
155 -- NOTE: PlainText's Reader can be run with an empty value
156 -- because all 'SGR' are ignored anyway.
157 width (PlainText ds) = width ds
158 nullWidth (PlainText ds) = nullWidth ds
159 instance Spaceable d => Spaceable (PlainText d) where
160 newline = PlainText $ newline
161 space = PlainText $ space
162 spaces = PlainText . spaces
163 instance Semigroup d => Colorable16 (PlainText d) where
164 reverse = plainTextSGR
165 black = plainTextSGR
166 red = plainTextSGR
167 green = plainTextSGR
168 yellow = plainTextSGR
169 blue = plainTextSGR
170 magenta = plainTextSGR
171 cyan = plainTextSGR
172 white = plainTextSGR
173 blacker = plainTextSGR
174 redder = plainTextSGR
175 greener = plainTextSGR
176 yellower = plainTextSGR
177 bluer = plainTextSGR
178 magentaer = plainTextSGR
179 cyaner = plainTextSGR
180 whiter = plainTextSGR
181 onBlack = plainTextSGR
182 onRed = plainTextSGR
183 onGreen = plainTextSGR
184 onYellow = plainTextSGR
185 onBlue = plainTextSGR
186 onMagenta = plainTextSGR
187 onCyan = plainTextSGR
188 onWhite = plainTextSGR
189 onBlacker = plainTextSGR
190 onRedder = plainTextSGR
191 onGreener = plainTextSGR
192 onYellower = plainTextSGR
193 onBluer = plainTextSGR
194 onMagentaer = plainTextSGR
195 onCyaner = plainTextSGR
196 onWhiter = plainTextSGR
197 instance Semigroup d => Decorable (PlainText d) where
198 bold = plainTextSGR
199 underline = plainTextSGR
200 italic = plainTextSGR
201 instance Justifiable d => Justifiable (PlainText d) where
202 justify (PlainText d) = PlainText $ justify d
203 instance Indentable d => Indentable (PlainText d) where
204 setIndent i (PlainText d) = PlainText $ setIndent i d
205 incrIndent i (PlainText d) = PlainText $ incrIndent i d
206 fill w (PlainText d) = PlainText $ fill w d
207 breakfill w (PlainText d) = PlainText $ breakfill w d
208 align (PlainText d) = PlainText $ align d
209 instance Listable d => Listable (PlainText d) where
210 ul ds = PlainText $ ul $ unPlainText <$> ds
211 ol ds = PlainText $ ol $ unPlainText <$> ds
212 instance Wrappable d => Wrappable (PlainText d) where
213 setWidth w (PlainText d) = PlainText $ setWidth w d
214 breakpoint = PlainText breakpoint
215 breakspace = PlainText breakspace
216 breakalt (PlainText x) (PlainText y) = PlainText $ breakalt x y
217
218 plainTextSGR ::
219 Semigroup d =>
220 PlainText d -> PlainText d
221 plainTextSGR (PlainText d) = PlainText d