0 | module Text.PrettyPrint.Prettyprinter.Render.NCurses
  1 |
  2 | import Control.Monad.State
  3 | import Data.String
  4 | import NCurses.Core
  5 | import NCurses.Core.Attribute
  6 | import NCurses.Core.Color
  7 | import Text.PrettyPrint.Prettyprinter.Doc
  8 | import Text.PrettyPrint.Prettyprinter.Render.Terminal
  9 |
 10 | %default total
 11 |
 12 | export
 13 | color : ColorPair -> Doc Attribute -> Doc Attribute
 14 | color colorPair = annotate (CP colorPair)
 15 |
 16 | export
 17 | underline : Doc Attribute -> Doc Attribute
 18 | underline = annotate Underline
 19 |
 20 | export
 21 | standout : Doc Attribute -> Doc Attribute
 22 | standout = annotate Standout
 23 |
 24 | export
 25 | reverse : Doc Attribute -> Doc Attribute
 26 | reverse = annotate Reverse
 27 |
 28 | export
 29 | blink : Doc Attribute -> Doc Attribute
 30 | blink = annotate Blink
 31 |
 32 | export
 33 | dim : Doc Attribute -> Doc Attribute
 34 | dim = annotate Dim
 35 |
 36 | export
 37 | bold : Doc Attribute -> Doc Attribute
 38 | bold = annotate Bold
 39 |
 40 | export
 41 | protected : Doc Attribute -> Doc Attribute
 42 | protected = annotate Protected
 43 |
 44 | export
 45 | invisible : Doc Attribute -> Doc Attribute
 46 | invisible = annotate Invisible
 47 |
 48 | ||| Map NCurses attributes to ANSI styles.
 49 | ||| This allows a Doc to be written with NCurses styles and
 50 | ||| displayed in a terminal without NCurses as a fallback or
 51 | ||| alternative.
 52 | export
 53 | toANSI : Attribute -> AnsiStyle
 54 | toANSI Normal = [Reset]
 55 | toANSI Underline = [SetStyle SingleUnderline]
 56 | toANSI Standout = [SetStyle DoubleUnderline]
 57 | toANSI Reverse = []
 58 | toANSI Blink = [SetBlink Slow]
 59 | toANSI Dim = [SetStyle Faint]
 60 | toANSI Bold = [SetStyle Bold]
 61 | toANSI Protected = []
 62 | toANSI Invisible = []
 63 | toANSI (CP colorPair) = [ SetForeground (toSgr colorPair.foreground)
 64 |                         , SetBackground (toSgr colorPair.background)
 65 |                         ]
 66 |   where
 67 |     toSgr : Color.Color -> SGR.Color
 68 |     toSgr Black   = Black
 69 |     toSgr Red     = Red
 70 |     toSgr Green   = Green
 71 |     toSgr Yellow  = Yellow
 72 |     toSgr Blue    = Blue
 73 |     toSgr Magenta = Magenta
 74 |     toSgr Cyan    = Cyan
 75 |     toSgr White   = White
 76 |
 77 | AttrState : Type
 78 | AttrState = StateT (List Attribute) IO ()
 79 |
 80 | export
 81 | renderNCurses : HasIO io => SimpleDocStream Attribute -> io ()
 82 | renderNCurses = liftIO . evalStateT [] . go
 83 |   where
 84 |     go : SimpleDocStream Attribute -> AttrState
 85 |     go SEmpty               = pure ()
 86 |     go (SChar ch rest)      = lift (nPutCh ch) *> go rest
 87 |     go (SText _ text rest)  = lift (nPutStr text) *> go rest
 88 |     go (SLine i rest)       = do
 89 |       y <- lift $ getYPos
 90 |       lift $ nMoveCursor (S y) (cast i)
 91 |       go rest
 92 |     go (SAnnPop rest)       = do
 93 |       (last :: attrs) <- get
 94 |         | [] => go rest
 95 |       lift $ nDisableAttr last
 96 |       put attrs
 97 |       go rest
 98 |     go (SAnnPush attr rest) = do
 99 |       lift $ nEnableAttr attr
100 |       modify (attr ::)
101 |       go rest
102 |
103 |