1 module Language.Symantic.Document.Term
2 ( module Language.Symantic.Document.Sym
3 , module Language.Symantic.Document.Term
6 import Control.Applicative (Applicative(..))
8 import Data.Function (($), (.), id)
9 import Data.Monoid (Monoid(..))
10 import Data.Ord (Ord(..))
11 import Data.Semigroup (Semigroup(..))
12 import Data.String (IsString(..))
13 import GHC.Exts (IsList(..))
14 import Prelude (pred, fromIntegral, Num(..))
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 import qualified Data.Text.Lazy.Builder as TLB
21 import Language.Symantic.Document.Sym
26 { reader_indent :: !Indent -- ^ Current indentation level, used by 'newline'.
27 , reader_newline :: Term -- ^ How to display 'newline'.
28 , reader_wrap_column :: !Column -- ^ 'Column' after which 'wrap' breaks on a 'breakpoint' or 'breakspace'.
29 , reader_sgr :: ![SGR] -- ^ Active ANSI codes.
30 , reader_colorable :: !Bool -- ^ Whether colors are activated or not.
31 , reader_decorable :: !Bool -- ^ Whether decorations are activated or not.
34 -- | Default 'Reader'.
38 , reader_newline = newlineWithIndent
39 , reader_wrap_column = Nat 80
41 , reader_colorable = True
42 , reader_decorable = True
57 (State -> TLB.Builder -> TLB.Builder) -> -- normal continuation
58 (State -> TLB.Builder -> TLB.Builder) -> -- should-wrap continuation
61 -- | Render a 'Term' into a 'TL.Text'.
62 textTerm :: Term -> TL.Text
63 textTerm = TLB.toLazyText . buildTerm
65 -- | Render a 'Term' into a 'TLB.Builder'.
66 buildTerm :: Term -> TLB.Builder
67 buildTerm (Term t) = t defReader defState oko oko
70 instance IsList Term where
74 instance Semigroup Term where
75 x <> y = Term $ \ro st ok ko ->
77 (\sx tx -> unTerm y ro sx
78 (\sy ty -> ok sy (tx<>ty))
79 (\sy ty -> ko sy (tx<>ty)))
80 (\sx tx -> unTerm y ro sx
81 (\sy ty -> ko sy (tx<>ty))
82 (\sy ty -> ko sy (tx<>ty)))
83 instance Monoid Term where
86 instance IsString Term where
89 writeH :: Column -> TLB.Builder -> Term
91 Term $ \ro st ok ko ->
92 let newCol = st + len in
93 (if newCol <= reader_wrap_column ro then ok else ko)
96 instance Textable Term where
97 empty = Term $ \_ro st ok _ko -> ok st mempty
98 charH t = writeH (Nat 1) (TLB.singleton t)
99 stringH t = writeH (length t) (fromString t)
100 textH t = writeH (length t) (TLB.fromText t)
101 ltextH t = writeH (length t) (TLB.fromLazyText t)
103 integer = stringH . show
104 replicate cnt t | cnt <= 0 = empty
105 | otherwise = t <> replicate (pred cnt) t
106 newline = Term $ \ro -> unTerm (reader_newline ro) ro
107 instance Alignable Term where
108 align t = Term $ \ro st -> unTerm t ro{reader_indent=st} st
109 withNewline nl t = Term $ \ro -> unTerm t ro{reader_newline=nl}
110 withIndent ind t = Term $ \ro -> unTerm t ro{reader_indent=ind}
111 incrIndent ind t = Term $ \ro -> unTerm t ro{reader_indent=reader_indent ro + ind}
112 column f = Term $ \ro st -> unTerm (f st) ro st
113 indent f = Term $ \ro -> unTerm (f (reader_indent ro)) ro
114 newlineWithoutIndent = Term $ \_ro _st ok _ko ->
115 ok 0 $ TLB.singleton '\n'
116 newlineWithIndent = Term $ \ro _st ok _ko ->
117 ok (reader_indent ro) $
118 TLB.singleton '\n' <>
119 fromString (List.replicate (fromIntegral $ reader_indent ro) ' ')
120 instance Wrapable Term where
121 ifWrap y x = Term $ \ro st ok ko ->
122 unTerm x ro st ok (\_sx _tx -> unTerm y ro st ok ko)
123 breakpoint onNoBreak onBreak t = Term $ \ro st ok ko ->
124 unTerm (onNoBreak <> t) ro st ok
125 (\_sp _tp -> unTerm (onBreak <> t) ro st ok ko)
126 withWrapColumn col t = Term $ \ro -> unTerm t ro{reader_wrap_column=col}
128 writeSGR :: (Reader -> Bool) -> SGR -> Term -> Term
129 writeSGR isOn s (Term t) =
132 then unTerm (o <> m <> c) ro
135 o = Term $ \_ro st ok _ko -> ok st $ fromString $ setSGRCode [s]
136 m = Term $ \ro -> t ro{reader_sgr=s:reader_sgr ro}
137 c = Term $ \ro st ok _ko -> ok st $ fromString $ setSGRCode $ Reset:List.reverse (reader_sgr ro)
139 instance Colorable Term where
140 colorable f = Term $ \ro -> unTerm (f (reader_colorable ro)) ro
141 withColorable b t = Term $ \ro -> unTerm t ro{reader_colorable=b}
142 reverse = writeSGR reader_colorable $ SetSwapForegroundBackground True
143 black = writeSGR reader_colorable $ SetColor Foreground Dull Black
144 red = writeSGR reader_colorable $ SetColor Foreground Dull Red
145 green = writeSGR reader_colorable $ SetColor Foreground Dull Green
146 yellow = writeSGR reader_colorable $ SetColor Foreground Dull Yellow
147 blue = writeSGR reader_colorable $ SetColor Foreground Dull Blue
148 magenta = writeSGR reader_colorable $ SetColor Foreground Dull Magenta
149 cyan = writeSGR reader_colorable $ SetColor Foreground Dull Cyan
150 white = writeSGR reader_colorable $ SetColor Foreground Dull White
151 blacker = writeSGR reader_colorable $ SetColor Foreground Vivid Black
152 redder = writeSGR reader_colorable $ SetColor Foreground Vivid Red
153 greener = writeSGR reader_colorable $ SetColor Foreground Vivid Green
154 yellower = writeSGR reader_colorable $ SetColor Foreground Vivid Yellow
155 bluer = writeSGR reader_colorable $ SetColor Foreground Vivid Blue
156 magentaer = writeSGR reader_colorable $ SetColor Foreground Vivid Magenta
157 cyaner = writeSGR reader_colorable $ SetColor Foreground Vivid Cyan
158 whiter = writeSGR reader_colorable $ SetColor Foreground Vivid White
159 onBlack = writeSGR reader_colorable $ SetColor Background Dull Black
160 onRed = writeSGR reader_colorable $ SetColor Background Dull Red
161 onGreen = writeSGR reader_colorable $ SetColor Background Dull Green
162 onYellow = writeSGR reader_colorable $ SetColor Background Dull Yellow
163 onBlue = writeSGR reader_colorable $ SetColor Background Dull Blue
164 onMagenta = writeSGR reader_colorable $ SetColor Background Dull Magenta
165 onCyan = writeSGR reader_colorable $ SetColor Background Dull Cyan
166 onWhite = writeSGR reader_colorable $ SetColor Background Dull White
167 onBlacker = writeSGR reader_colorable $ SetColor Background Vivid Black
168 onRedder = writeSGR reader_colorable $ SetColor Background Vivid Red
169 onGreener = writeSGR reader_colorable $ SetColor Background Vivid Green
170 onYellower = writeSGR reader_colorable $ SetColor Background Vivid Yellow
171 onBluer = writeSGR reader_colorable $ SetColor Background Vivid Blue
172 onMagentaer = writeSGR reader_colorable $ SetColor Background Vivid Magenta
173 onCyaner = writeSGR reader_colorable $ SetColor Background Vivid Cyan
174 onWhiter = writeSGR reader_colorable $ SetColor Background Vivid White
175 instance Decorable Term where
176 decorable f = Term $ \ro -> unTerm (f (reader_decorable ro)) ro
177 withDecorable b t = Term $ \ro -> unTerm t ro{reader_decorable=b}
178 bold = writeSGR reader_decorable $ SetConsoleIntensity BoldIntensity
179 underline = writeSGR reader_decorable $ SetUnderlining SingleUnderline
180 italic = writeSGR reader_decorable $ SetItalicized True