]> Git — Sourcephile - haskell/symantic.git/blob - symantic-document/Language/Symantic/Document/Term.hs
Rename things such that symantic-document is neater when used with import qualified.
[haskell/symantic.git] / symantic-document / Language / Symantic / Document / Term.hs
1 module Language.Symantic.Document.Term
2 ( module Language.Symantic.Document.Sym
3 , module Language.Symantic.Document.Term
4 ) where
5
6 import Control.Applicative (Applicative(..))
7 import Data.Bool
8 import Data.Function (($), (.), id)
9 import Data.Int (Int)
10 import Data.Monoid (Monoid(..))
11 import Data.Ord (Ord(..))
12 import Data.Semigroup (Semigroup(..))
13 import Data.String (IsString(..))
14 import GHC.Exts (IsList(..))
15 import Prelude ((+), pred)
16 import System.Console.ANSI
17 import Text.Show (Show(..))
18 import qualified Data.List as List
19 import qualified Data.Text as Text
20 import qualified Data.Text.Lazy as TL
21 import qualified Data.Text.Lazy.Builder as TLB
22
23 import Language.Symantic.Document.Sym
24
25 -- * Type 'Reader'
26 data Reader
27 = Reader
28 { reader_indent :: !(Indent Term) -- ^ Current indentation level, used by 'newline'.
29 , reader_newline :: Term -- ^ How to display 'newline'.
30 , reader_wrap_column :: !(Column Term) -- ^ 'Column' after which 'wrap' breaks on a 'breakpoint' or 'breakspace'.
31 , reader_sgr :: ![SGR] -- ^ Active ANSI codes.
32 , reader_colorable :: !Bool -- ^ Whether colors are activated or not.
33 , reader_decorable :: !Bool -- ^ Whether decorations are activated or not.
34 }
35
36 -- | Default 'Reader'.
37 defReader :: Reader
38 defReader = Reader
39 { reader_indent = 0
40 , reader_newline = newlineWithIndent
41 , reader_wrap_column = 80
42 , reader_sgr = []
43 , reader_colorable = True
44 , reader_decorable = True
45 }
46
47 -- * Type 'State'
48 type State = Column Term
49
50 -- | Default 'State'.
51 defState :: State
52 defState = 0
53
54 -- * Type 'Term'
55 newtype Term
56 = Term
57 { unTerm :: Reader ->
58 State ->
59 (State -> TLB.Builder -> TLB.Builder) -> -- normal continuation
60 (State -> TLB.Builder -> TLB.Builder) -> -- should-wrap continuation
61 TLB.Builder }
62
63 type instance Column Term = Int
64 type instance Indent Term = Int
65
66 -- | Render a 'Term' into a 'TL.Text'.
67 textTerm :: Term -> TL.Text
68 textTerm = TLB.toLazyText . buildTerm
69
70 -- | Render a 'Term' into a 'TLB.Builder'.
71 buildTerm :: Term -> TLB.Builder
72 buildTerm (Term t) = t defReader defState oko oko
73 where oko _st = id
74
75 instance IsList Term where
76 type Item Term = Term
77 fromList = mconcat
78 toList = pure
79 instance Semigroup Term where
80 x <> y = Term $ \ro st ok ko ->
81 unTerm x ro st
82 (\sx tx -> unTerm y ro sx
83 (\sy ty -> ok sy (tx<>ty))
84 (\sy ty -> ko sy (tx<>ty)))
85 (\sx tx -> unTerm y ro sx
86 (\sy ty -> ko sy (tx<>ty))
87 (\sy ty -> ko sy (tx<>ty)))
88 instance Monoid Term where
89 mempty = empty
90 mappend = (<>)
91 instance IsString Term where
92 fromString = string
93
94 writeH :: Column Term -> TLB.Builder -> Term
95 writeH len t =
96 Term $ \ro st ok ko ->
97 let newCol = st + len in
98 (if newCol <= reader_wrap_column ro then ok else ko)
99 newCol t
100
101 instance Textable Term where
102 empty = Term $ \_ro st ok _ko -> ok st mempty
103 charH t = writeH 1 $ TLB.singleton t
104 stringH t = writeH (List.length t) (fromString t)
105 textH t = writeH (Text.length t) (TLB.fromText t)
106 ltextH t = writeH (intOfInt64 $ TL.length t) (TLB.fromLazyText t)
107 int = stringH . show
108 integer = stringH . show
109 replicate cnt t | cnt <= 0 = empty
110 | otherwise = t <> replicate (pred cnt) t
111 newline = Term $ \ro -> unTerm (reader_newline ro) ro
112 instance Alignable Term where
113 align t = Term $ \ro st -> unTerm t ro{reader_indent=st} st
114 withNewline nl t = Term $ \ro -> unTerm t ro{reader_newline=nl}
115 withIndent ind t = Term $ \ro -> unTerm t ro{reader_indent=ind}
116 incrIndent ind t = Term $ \ro -> unTerm t ro{reader_indent=reader_indent ro + ind}
117 column f = Term $ \ro st -> unTerm (f st) ro st
118 newlineWithoutIndent = Term $ \_ro _st ok _ko ->
119 ok 0 $ TLB.singleton '\n'
120 newlineWithIndent = Term $ \ro _st ok _ko ->
121 ok (reader_indent ro) $
122 TLB.singleton '\n' <>
123 fromString (List.replicate (reader_indent ro) ' ')
124 instance Wrapable Term where
125 ifWrap y x = Term $ \ro st ok ko ->
126 unTerm x ro st ok (\_sx _tx -> unTerm y ro st ok ko)
127 breakpoint onNoBreak onBreak t = Term $ \ro st ok ko ->
128 unTerm (onNoBreak <> t) ro st ok
129 (\_sp _tp -> unTerm (onBreak <> t) ro st ok ko)
130 withWrapColumn col t = Term $ \ro -> unTerm t ro{reader_wrap_column=col}
131
132 writeSGR :: SGR -> Term -> Term
133 writeSGR s (Term t) =
134 Term $ \ro ->
135 if reader_colorable ro
136 then unTerm (o <> m <> c) ro
137 else t ro
138 where
139 o = Term $ \_ro st ok _ko -> ok st $ fromString $ setSGRCode [s]
140 m = Term $ \ro -> t ro{reader_sgr=s:reader_sgr ro}
141 c = Term $ \ro st ok _ko -> ok st $ fromString $ setSGRCode $ Reset:List.reverse (reader_sgr ro)
142
143 instance Colorable Term where
144 colorable f = Term $ \ro -> unTerm (f (reader_colorable ro)) ro
145 withColorable b t = Term $ \ro -> unTerm t ro{reader_colorable=b}
146 reverse = writeSGR $ SetSwapForegroundBackground True
147 black = writeSGR $ SetColor Foreground Dull Black
148 red = writeSGR $ SetColor Foreground Dull Red
149 green = writeSGR $ SetColor Foreground Dull Green
150 yellow = writeSGR $ SetColor Foreground Dull Yellow
151 blue = writeSGR $ SetColor Foreground Dull Blue
152 magenta = writeSGR $ SetColor Foreground Dull Magenta
153 cyan = writeSGR $ SetColor Foreground Dull Cyan
154 white = writeSGR $ SetColor Foreground Dull White
155 blacker = writeSGR $ SetColor Foreground Vivid Black
156 redder = writeSGR $ SetColor Foreground Vivid Red
157 greener = writeSGR $ SetColor Foreground Vivid Green
158 yellower = writeSGR $ SetColor Foreground Vivid Yellow
159 bluer = writeSGR $ SetColor Foreground Vivid Blue
160 magentaer = writeSGR $ SetColor Foreground Vivid Magenta
161 cyaner = writeSGR $ SetColor Foreground Vivid Cyan
162 whiter = writeSGR $ SetColor Foreground Vivid White
163 onBlack = writeSGR $ SetColor Background Dull Black
164 onRed = writeSGR $ SetColor Background Dull Red
165 onGreen = writeSGR $ SetColor Background Dull Green
166 onYellow = writeSGR $ SetColor Background Dull Yellow
167 onBlue = writeSGR $ SetColor Background Dull Blue
168 onMagenta = writeSGR $ SetColor Background Dull Magenta
169 onCyan = writeSGR $ SetColor Background Dull Cyan
170 onWhite = writeSGR $ SetColor Background Dull White
171 onBlacker = writeSGR $ SetColor Background Vivid Black
172 onRedder = writeSGR $ SetColor Background Vivid Red
173 onGreener = writeSGR $ SetColor Background Vivid Green
174 onYellower = writeSGR $ SetColor Background Vivid Yellow
175 onBluer = writeSGR $ SetColor Background Vivid Blue
176 onMagentaer = writeSGR $ SetColor Background Vivid Magenta
177 onCyaner = writeSGR $ SetColor Background Vivid Cyan
178 onWhiter = writeSGR $ SetColor Background Vivid White
179 instance Decorable Term where
180 decorable f = Term $ \ro -> unTerm (f (reader_decorable ro)) ro
181 withDecorable b t = Term $ \ro -> unTerm t ro{reader_decorable=b}
182 bold = writeSGR $ SetConsoleIntensity BoldIntensity
183 underline = writeSGR $ SetUnderlining SingleUnderline
184 italic = writeSGR $ SetItalicized True