]> Git — Sourcephile - haskell/symantic-plaintext.git/blob - Symantic/Document/AnsiText.hs
plain: fix ANSI escaping with custom indenting
[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.Functor.Identity (Identity(..))
12 import Data.Monoid (Monoid(..))
13 import Data.Semigroup (Semigroup(..))
14 import Data.String (String, IsString(..))
15 import Data.Text (Text)
16 import System.Console.ANSI
17 import Text.Show (Show(..))
18 import qualified Data.List as List
19 import qualified Data.Text.Lazy as TL
20
21 import Symantic.Document.API
22
23 -- * Type 'PlainText'
24 -- | Drop 'Colorable16' and 'Decorable'.
25 newtype PlainText d = PlainText { unPlainText :: d }
26 deriving (Show)
27
28 plainText :: PlainText d -> PlainText d
29 plainText = id
30
31 runPlainText :: PlainText d -> d
32 runPlainText (PlainText d) = d
33
34 instance From Char d => From Char (PlainText d) where
35 from = PlainText . from
36 instance From String d => From String (PlainText d) where
37 from = PlainText . from
38 instance From Text d => From Text (PlainText d) where
39 from = PlainText . from
40 instance From TL.Text d => From TL.Text (PlainText d) where
41 from = PlainText . from
42 instance From s (PlainText d) => From (Line s) (PlainText d) where
43 from = from . unLine
44 instance From s (PlainText d) => From (Word s) (PlainText d) where
45 from = from . unWord
46 instance From String d => IsString (PlainText d) where
47 fromString = from
48 instance Semigroup d => Semigroup (PlainText d) where
49 PlainText x <> PlainText y = PlainText $ (<>) x y
50 instance Monoid d => Monoid (PlainText d) where
51 mempty = PlainText mempty
52 mappend = (<>)
53 instance Lengthable d => Lengthable (PlainText d) where
54 -- NOTE: PlainText's Reader can be run with an empty value
55 -- because all 'SGR' are ignored anyway.
56 width (PlainText ds) = width ds
57 nullWidth (PlainText ds) = nullWidth ds
58 instance Spaceable d => Spaceable (PlainText d) where
59 newline = PlainText $ newline
60 space = PlainText $ space
61 spaces = PlainText . spaces
62 instance Semigroup d => Colorable16 (PlainText d) where
63 reverse = plainTextSGR
64 black = plainTextSGR
65 red = plainTextSGR
66 green = plainTextSGR
67 yellow = plainTextSGR
68 blue = plainTextSGR
69 magenta = plainTextSGR
70 cyan = plainTextSGR
71 white = plainTextSGR
72 blacker = plainTextSGR
73 redder = plainTextSGR
74 greener = plainTextSGR
75 yellower = plainTextSGR
76 bluer = plainTextSGR
77 magentaer = plainTextSGR
78 cyaner = plainTextSGR
79 whiter = plainTextSGR
80 onBlack = plainTextSGR
81 onRed = plainTextSGR
82 onGreen = plainTextSGR
83 onYellow = plainTextSGR
84 onBlue = plainTextSGR
85 onMagenta = plainTextSGR
86 onCyan = plainTextSGR
87 onWhite = plainTextSGR
88 onBlacker = plainTextSGR
89 onRedder = plainTextSGR
90 onGreener = plainTextSGR
91 onYellower = plainTextSGR
92 onBluer = plainTextSGR
93 onMagentaer = plainTextSGR
94 onCyaner = plainTextSGR
95 onWhiter = plainTextSGR
96 instance Semigroup d => Decorable (PlainText d) where
97 bold = plainTextSGR
98 underline = plainTextSGR
99 italic = plainTextSGR
100 instance Justifiable d => Justifiable (PlainText d) where
101 justify (PlainText d) = PlainText $ justify d
102 instance Indentable d => Indentable (PlainText d) where
103 align (PlainText d) = PlainText $ align d
104 setIndent p i (PlainText d) = PlainText $ setIndent (runPlainText p) i d
105 incrIndent p i (PlainText d) = PlainText $ incrIndent (runPlainText p) i d
106 fill w (PlainText d) = PlainText $ fill w d
107 fillOrBreak w (PlainText d) = PlainText $ fillOrBreak w d
108 instance Listable d => Listable (PlainText d) where
109 ul ds = PlainText $ ul $ unPlainText <$> ds
110 ol ds = PlainText $ ol $ unPlainText <$> ds
111 instance Wrappable d => Wrappable (PlainText d) where
112 setWidth w (PlainText d) = PlainText $ setWidth w d
113 breakpoint = PlainText breakpoint
114 breakspace = PlainText breakspace
115 endline = PlainText endline
116 breakalt (PlainText x) (PlainText y) = PlainText $ breakalt x y
117
118 plainTextSGR ::
119 Semigroup d =>
120 PlainText d -> PlainText d
121 plainTextSGR (PlainText d) = PlainText d