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