0 | module Text.PrettyPrint.Prettyprinter.Render.Terminal
 1 |
 2 | import Data.Maybe
 3 | import Data.String
 4 | import public Control.ANSI
 5 | import Control.Monad.ST
 6 | import Text.PrettyPrint.Prettyprinter.Doc
 7 |
 8 | %default covering
 9 |
10 | public export
11 | AnsiStyle : Type
12 | AnsiStyle = List SGR
13 |
14 | export
15 | color : Color -> AnsiStyle
16 | color c = pure $ SetForeground c
17 |
18 | export
19 | bgColor : Color -> AnsiStyle
20 | bgColor c = pure $ SetBackground c
21 |
22 | export
23 | bold : AnsiStyle
24 | bold = pure $ SetStyle Bold
25 |
26 | export
27 | italic : AnsiStyle
28 | italic = pure $ SetStyle Italic
29 |
30 | export
31 | underline : AnsiStyle
32 | underline = pure $ SetStyle SingleUnderline
33 |
34 | export
35 | strike : AnsiStyle
36 | strike = pure $ SetStyle Striked
37 |
38 | export
39 | renderString : SimpleDocStream AnsiStyle -> String
40 | renderString sdoc = fromMaybe "<internal pretty printing error>" $ runST $ do
41 |     styleStackRef <- newSTRef {a = List AnsiStyle} [neutral]
42 |     outputRef <- newSTRef {a = String} neutral
43 |     go styleStackRef outputRef sdoc
44 |     readSTRef styleStackRef >>= \case
45 |       [] => pure Nothing
46 |       [_] => Just <$> readSTRef outputRef
47 |       _ => pure Nothing
48 |   where
49 |     push : STRef s (List AnsiStyle) -> List SGR -> ST s ()
50 |     push stack x = modifySTRef stack (x ::)
51 |
52 |     peek : STRef s (List AnsiStyle) -> ST s (Maybe AnsiStyle)
53 |     peek stack = do
54 |       (x :: _) <- readSTRef stack | [] => pure Nothing
55 |       pure (Just x)
56 |
57 |     pop : STRef s (List AnsiStyle) -> ST s (Maybe AnsiStyle)
58 |     pop stack = do
59 |       (x :: xs) <- readSTRef stack | [] => pure Nothing
60 |       writeSTRef stack xs
61 |       pure (Just x)
62 |
63 |     writeOutput : STRef s String -> String -> ST s ()
64 |     writeOutput out x = modifySTRef out (<+> x)
65 |
66 |     go : STRef s (List AnsiStyle) -> STRef s String -> SimpleDocStream AnsiStyle -> ST s ()
67 |     go stack out SEmpty = pure ()
68 |     go stack out (SChar c rest) = do
69 |       writeOutput out (singleton c)
70 |       go stack out rest
71 |     go stack out (SText l t rest) = do
72 |       writeOutput out t
73 |       go stack out rest
74 |     go stack out (SLine l rest) = do
75 |       writeOutput out (singleton '\n' <+> textSpaces l)
76 |       go stack out rest
77 |     go stack out (SAnnPush style rest) = do
78 |       Just currentStyle <- peek stack
79 |         | Nothing => writeSTRef stack []
80 |       let newStyle = style <+> currentStyle
81 |       push stack newStyle
82 |       writeOutput out (escapeSGR newStyle)
83 |       go stack out rest
84 |     go stack out (SAnnPop rest) = do
85 |       _ <- pop stack
86 |       Just newStyle <- peek stack
87 |         | Nothing => writeSTRef stack []
88 |       writeOutput out (escapeSGR (Reset :: newStyle))
89 |       go stack out rest
90 |
91 | export
92 | renderIO : SimpleDocStream AnsiStyle -> IO ()
93 | renderIO = putStrLn . renderString
94 |
95 | export
96 | putDoc : Doc AnsiStyle -> IO ()
97 | putDoc = renderIO . layoutPretty defaultLayoutOptions
98 |