0 | module NCurses.Core.Color
  1 |
  2 | import NCurses.Core
  3 |
  4 | %default total
  5 |
  6 | %foreign libncurses "start_color"
  7 | prim__startColor : PrimIO ()
  8 |
  9 | %foreign libncurses "init_pair"
 10 | prim__initColorPair : Int -> Int -> Int -> PrimIO ()
 11 |
 12 | %foreign libhelper "black_color"
 13 | prim__blackColor : PrimIO Int
 14 |
 15 | %foreign libhelper "red_color"
 16 | prim__redColor : PrimIO Int
 17 |
 18 | %foreign libhelper "green_color"
 19 | prim__greenColor : PrimIO Int
 20 |
 21 | %foreign libhelper "yellow_color"
 22 | prim__yellowColor : PrimIO Int
 23 |
 24 | %foreign libhelper "blue_color"
 25 | prim__blueColor : PrimIO Int
 26 |
 27 | %foreign libhelper "magenta_color"
 28 | prim__magentaColor : PrimIO Int
 29 |
 30 | %foreign libhelper "cyan_color"
 31 | prim__cyanColor : PrimIO Int
 32 |
 33 | %foreign libhelper "white_color"
 34 | prim__whiteColor : PrimIO Int
 35 |
 36 | ||| The default ncurses colors that can be used in constructing
 37 | ||| color pairs.
 38 | public export
 39 | data Color = Black
 40 |            | Red
 41 |            | Green
 42 |            | Yellow
 43 |            | Blue
 44 |            | Magenta
 45 |            | Cyan
 46 |            | White
 47 |
 48 | export
 49 | Eq Color where
 50 |   Black   == Black   = True
 51 |   Red     == Red     = True
 52 |   Green   == Green   = True
 53 |   Yellow  == Yellow  = True
 54 |   Blue    == Blue    = True
 55 |   Magenta == Magenta = True
 56 |   Cyan    == Cyan    = True
 57 |   White   == White   = True
 58 |   _ == _ = False
 59 |
 60 | Show Color where
 61 |   show Black = "Black"
 62 |   show Red = "Red"
 63 |   show Green = "Green"
 64 |   show Yellow = "Yellow"
 65 |   show Blue = "Blue"
 66 |   show Magenta = "Magenta"
 67 |   show Cyan = "Cyan"
 68 |   show White = "White"
 69 |
 70 | getColor : HasIO io => Color -> io Int
 71 | getColor color = case color of
 72 |                       Black   => primIO $ prim__blackColor
 73 |                       Red     => primIO $ prim__redColor
 74 |                       Green   => primIO $ prim__greenColor
 75 |                       Yellow  => primIO $ prim__yellowColor
 76 |                       Blue    => primIO $ prim__blueColor
 77 |                       Magenta => primIO $ prim__magentaColor
 78 |                       Cyan    => primIO $ prim__cyanColor
 79 |                       White   => primIO $ prim__whiteColor
 80 |
 81 | ||| Color pairs represent both a foreground and background
 82 | ||| color.
 83 | export
 84 | data ColorPair = MkColorPair Nat Color Color
 85 |
 86 | export
 87 | Eq ColorPair where
 88 |   (MkColorPair idx1 f1 b1) == (MkColorPair idx2 f2 b2) = idx1 == idx2 && f1 == f2 && b1 == b2
 89 |
 90 | export
 91 | Show ColorPair where
 92 |   show (MkColorPair idx foreground background) = "\{show idx}: \{show foreground}/\{show background}"
 93 |
 94 | ||| Get the index within ncurses where the given color
 95 | ||| pair can be referenced. In almost all situations, this
 96 | ||| can be left as an implementation detail.
 97 | export
 98 | (.idx) : ColorPair -> Nat
 99 | (.idx) (MkColorPair n f b) = n
100 |
101 | export
102 | (.foreground) : ColorPair -> Color
103 | (.foreground) (MkColorPair n f b) = f
104 |
105 | export
106 | (.background) : ColorPair -> Color
107 | (.background) (MkColorPair n f b) = b
108 |
109 | ||| Get the default color pair. Note that unlike with
110 | ||| user defined colors, the `.foreground` and
111 | ||| `.background` of this color pair are not guaranteed
112 | ||| to be accurate in all terminal environments, but this
113 | ||| color pair will definitely result in the default
114 | ||| when displayed nonetheless.
115 | |||
116 | ||| The meaning if this color pair is entirely
117 | ||| determined by its `.idx` property.
118 | export
119 | defaultColorPair : ColorPair
120 | defaultColorPair = MkColorPair 0 White Black
121 |
122 | ||| Create a new color pair. You must tell it the index to create
123 | ||| the color at, which should be a number starting at 0. Some
124 | ||| platforms allow you to redefine a color at a given index but this
125 | ||| is not universally supported.
126 | |||
127 | ||| You might notice that ncurses expects color indices to start at 1 --
128 | ||| this function increments the index it is given so that passing 0 to
129 | ||| it will use the first available user color pair index of 1.
130 | export
131 | initColorPair : HasIO io => Nat -> (fg : Color) -> (bg : Color) -> io ColorPair
132 | initColorPair idx fg bg = 
133 |   do bgColor <- getColor bg
134 |      fgColor <- getColor fg
135 |      let actualIdx = (S idx)
136 |      primIO $ prim__initColorPair (cast actualIdx) fgColor bgColor 
137 |      pure (MkColorPair actualIdx fg bg)
138 |
139 | ||| Begin using color mode.
140 | export
141 | startColor : HasIO io => io ()
142 | startColor = primIO $ prim__startColor
143 |
144 |