
   0 | ||| Support for contrib's Prettyprinter rendering
   1 | ||| in the context of an NCurses session.
   2 | module Control.NCurses.Pretty
   3 | 
   4 | import Text.PrettyPrint.Prettyprinter.Render.NCurses
   5 | import Control.NCurses
   6 | import NCurses
   7 | import Control.Monad.State
   8 | import public Text.PrettyPrint.Prettyprinter.Doc
   9 | import Control.Indexed
  10 | import Data.List
  11 | 
  12 | ||| Set the color of upcoming text.
  13 | ||| See also @defaultColor@.
  14 | export
  15 | color : (name : String) -> HasColor name s => Doc (Attribute s) -> Doc (Attribute s)
  16 | color name = annotate (Color (Named name))
  17 | 
  18 | export
  19 | defaultColor : Doc (Attribute s) -> Doc (Attribute s)
  20 | defaultColor = annotate (Color DefaultColors)
  21 | 
  22 | export
  23 | underline : Doc (Attribute s) -> Doc (Attribute s)
  24 | underline = annotate Underline
  25 | 
  26 | export
  27 | standout : Doc (Attribute s) -> Doc (Attribute s)
  28 | standout = annotate Standout
  29 | 
  30 | export
  31 | reverse : Doc (Attribute s) -> Doc (Attribute s)
  32 | reverse = annotate Reverse
  33 | 
  34 | export
  35 | blink : Doc (Attribute s) -> Doc (Attribute s)
  36 | blink = annotate Blink
  37 | 
  38 | export
  39 | dim : Doc (Attribute s) -> Doc (Attribute s)
  40 | dim = annotate Dim
  41 | 
  42 | export
  43 | bold : Doc (Attribute s) -> Doc (Attribute s)
  44 | bold = annotate Bold
  45 | 
  46 | export
  47 | protected : Doc (Attribute s) -> Doc (Attribute s)
  48 | protected = annotate Protected
  49 | 
  50 | export
  51 | invisible : Doc (Attribute s) -> Doc (Attribute s)
  52 | invisible = annotate Invisible
  53 | 
  54 | record Const (s : CursesState) a where
  55 |   constructor C
  56 |   runConst : NCurses a s s
  57 | 
  58 | Functor (Const s) where
  59 |   map f = C . map f . runConst
  60 | 
  61 | Applicative (Const s) where
  62 |   pure = C . pure
  63 |   (C x) <*> (C y) = C (x <<*>> y)
  64 | 
  65 | Monad (Const s) where
  66 |   (C x) >>= f = C $ do
  67 |     x' <- x
  68 |     runConst $ f x'
  69 | 
  70 | Attrs : CursesState -> Type
  71 | Attrs s = List (Attribute s)
  72 | 
  73 | AttrState : CursesState -> Type
  74 | AttrState s = StateT (Attrs s) (Const s) ()
  75 | 
  76 | export
  77 | renderDoc : IsActive s => SimpleDocStream (Attribute s) -> NCurses () s s
  78 | renderDoc = runConst . evalStateT [] . go
  79 |   where
  80 |     go : SimpleDocStream (Attribute s) -> AttrState s
  81 |     go SEmpty = pure ()
  82 |     go (SChar ch rest)      = (lift $ C (putCh ch)) *> go rest
  83 |     go (SText _ text rest)  = (lift $ C (putStr text)) *> go rest
  84 |     go (SLine i rest)       = do
  85 |       (MkPosition row col) <- lift $ C getPos
  86 |       lift . C $ move (MkPosition (S row) (cast i))
  87 |       go rest
  88 |     go (SAnnPop rest)       = do
  89 |       (last :: attrs) <- get
  90 |         | [] => go rest
  91 |       lift . C $ disableAttr last
  92 |       put attrs
  93 |       go rest
  94 |     go (SAnnPush attr rest) = do
  95 |       lift . C $ enableAttr attr
  96 |       modify (attr ::)
  97 |       go rest
  98 | 
  99 | export
 100 | printDoc : IsActive s => {default defaultLayoutOptions layoutOptions : LayoutOptions} -> Doc (Attribute s) -> NCurses () s s
 101 | printDoc {layoutOptions} = renderDoc . layoutPretty layoutOptions
 102 | 
 103 |