diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,17 +1,24 @@ -## [1.1.0.2] - 2023-10-15 +## [2.0.0] - November 5, 2023 +- Overhaul `Cell`+`Scene` API; now it's `Image`+`Scene` +- Add `Eq` instance for `Color` +- Add `Semigroup`/`Monoid` instances for `Pos` +- Fix bug that left cursor shown when it should be hidden + +## [1.1.0.2] - October 15, 2023 + - Support GHC 9.8.1 -## [1.1.0.1] - 2022-12-01 +## [1.1.0.1] - December 1, 2022 - Make `char` applied to a wide character result in a space instead of nothing -## [1.1.0] - 2022-11-03 +## [1.1.0] - November 3, 2022 -- Split off Elm Architecture wrapper into `termbox-tea` package, and expose `run`/`initialize`/`finalize` instead. +- Split off Elm Architecture wrapper into `termbox-tea` package, and expose `run`/`initialize`/`finalize` instead - Rename `Mouse` to `MouseButton`, rename its constructors, and add `Mouse` type (`MouseButton` + `Pos`) -## [1.0.0] - 2022-10-25 +## [1.0.0] - October 25, 2022 - Rework `run`; add `Program` record of callbacks - Add user events to `Event` type @@ -27,7 +34,7 @@ - Support GHC 9.4 - Drop support for GHC < 8.8 -## [0.3.0] - 2020-09-20 +## [0.3.0] - September 20, 2020 - Add `Cells` and `Cursor` types - Export `Termbox.Internal` module that roughly corresponds to the C library @@ -43,20 +50,20 @@ - Remove build dependency on `c2hs` - Remove support for GHC < 8.2 -## [0.2.0.1] - 2020-06-27 +## [0.2.0.1] - June 27, 2020 - Bump `base` upper bound -## [0.2.0] - 2019-06-21 +## [0.2.0] - June 21, 2019 - Add `getCells` function - Add `run` function - Rename `size` to `getSize` -- Rename `main` to `run_` and return errors as an `Either` instead of throwing. -- Make `Attr`'s `Semigroup` instance right-biased instead of left-biased. -- Make `Attr`'s `Num` instance total. +- Rename `main` to `run_` and return errors as an `Either` instead of throwing +- Make `Attr`'s `Semigroup` instance right-biased instead of left-biased +- Make `Attr`'s `Num` instance total - Remove `buffer` function -## [0.1.0] - 2018-07-18 +## [0.1.0] - July 18, 2018 - Initial release diff --git a/src/Termbox.hs b/src/Termbox.hs --- a/src/Termbox.hs +++ b/src/Termbox.hs @@ -6,8 +6,6 @@ -- -- * @@, a @reactive-banana@ FRP interface. -- * @@, an Elm Architecture interface. --- --- This module is intended to be imported qualified. module Termbox ( -- * Main run, @@ -19,20 +17,29 @@ -- ** Scene Scene, - render, - cell, + image, fill, cursor, + render, - -- ** Cell - Cell, + -- ** Image + Image, char, + + -- *** Color fg, bg, + + -- *** Style bold, underline, blink, + -- *** Translation + at, + atRow, + atCol, + -- ** Colors Color, @@ -83,7 +90,6 @@ ) where -import Termbox.Internal.Cell (Cell, bg, blink, bold, char, fg, underline) import Termbox.Internal.Color ( Color, blue, @@ -99,6 +105,7 @@ yellow, ) import Termbox.Internal.Event (Event (..), poll) +import Termbox.Internal.Image (Image, at, atCol, atRow, bg, blink, bold, char, fg, underline) import Termbox.Internal.Key ( Key (..), pattern KeyCtrl2, @@ -125,5 +132,5 @@ ), ) import Termbox.Internal.Pos (Pos (..), posDown, posLeft, posRight, posUp) -import Termbox.Internal.Scene (Scene, cell, cursor, fill, render) +import Termbox.Internal.Scene (Scene, cursor, fill, image, render) import Termbox.Internal.Size (Size (..), getSize) diff --git a/src/Termbox/Internal/Cell.hs b/src/Termbox/Internal/Cell.hs deleted file mode 100644 --- a/src/Termbox/Internal/Cell.hs +++ /dev/null @@ -1,106 +0,0 @@ -module Termbox.Internal.Cell - ( -- * Cell - Cell, - drawCell, - char, - - -- ** Color - fg, - bg, - - -- ** Style - bold, - underline, - blink, - ) -where - -import qualified Data.Char as Char -import Data.String (IsString (..)) -import Foreign.C.Types (CInt (CInt), CWchar (CWchar)) -import qualified Termbox.Bindings.Hs -import Termbox.Internal.Color (Color (Color)) - --- | A single cell. --- --- * Create a cell with 'char', or with a string literal. --- * Set a cell's color with 'fg', 'bg'. --- * Style a cell with 'bold', 'underline', 'blink'. -data Cell - = CellFg - {-# UNPACK #-} !Char -- invariant: char is width 1 - {-# UNPACK #-} !Termbox.Bindings.Hs.Tb_color -- fg - | CellFgBlink - {-# UNPACK #-} !Char -- invariant: char is width 1 - {-# UNPACK #-} !Termbox.Bindings.Hs.Tb_color -- fg - | CellFgBg - {-# UNPACK #-} !Char -- invariant: char is width 1 - {-# UNPACK #-} !Termbox.Bindings.Hs.Tb_color -- fg - {-# UNPACK #-} !Termbox.Bindings.Hs.Tb_color -- bg - -instance {-# OVERLAPS #-} IsString [Cell] where - fromString = - map char - -drawCell :: Termbox.Bindings.Hs.Tb_color -> Int -> Int -> Cell -> IO () -drawCell bg0 col row = \case - CellFg ch fg_ -> Termbox.Bindings.Hs.tb_change_cell col row ch fg_ bg0 - CellFgBlink ch fg_ -> Termbox.Bindings.Hs.tb_change_cell col row ch fg_ (makeBold bg0) -- bold background = blink - CellFgBg ch fg_ bg_ -> Termbox.Bindings.Hs.tb_change_cell col row ch fg_ bg_ - --- | Create a cell from a character. --- --- If the character is not 1 character wide, it will not be displayed. -char :: Char -> Cell -char ch = - CellFg (if wcwidth (charToCWchar ch) == 1 then ch else ' ') Termbox.Bindings.Hs.TB_DEFAULT - --- | Set the foreground color of a cell. -fg :: Color -> Cell -> Cell -fg (Color color) = \case - CellFg ch _ -> CellFg ch color - CellFgBlink ch _ -> CellFgBlink ch color - CellFgBg ch _ bg_ -> CellFgBg ch color bg_ - --- | Set the background color of a cell. -bg :: Color -> Cell -> Cell -bg (Color color) = \case - CellFg ch fg_ -> CellFgBg ch fg_ color - CellFgBlink ch fg_ -> CellFgBg ch fg_ (makeBold color) -- bold background = blink - CellFgBg ch fg_ _ -> CellFgBg ch fg_ color - --- | Make a cell bold. -bold :: Cell -> Cell -bold = \case - CellFg ch fg_ -> CellFg ch (makeBold fg_) - CellFgBlink ch fg_ -> CellFgBlink ch (makeBold fg_) - CellFgBg ch fg_ bg_ -> CellFgBg ch (makeBold fg_) bg_ - --- | Make a cell underlined. -underline :: Cell -> Cell -underline = \case - CellFg ch fg_ -> CellFg ch (makeUnderline fg_) - CellFgBlink ch fg_ -> CellFgBlink ch (makeUnderline fg_) - CellFgBg ch fg_ bg_ -> CellFgBg ch (makeUnderline fg_) bg_ - --- | Make a cell blink. -blink :: Cell -> Cell -blink = \case - CellFg ch fg_ -> CellFgBlink ch fg_ - CellFgBlink ch fg_ -> CellFgBlink ch fg_ - CellFgBg ch fg_ bg_ -> CellFgBg ch fg_ (makeBold bg_) -- bold background = blink - -makeBold :: Termbox.Bindings.Hs.Tb_color -> Termbox.Bindings.Hs.Tb_color -makeBold = - Termbox.Bindings.Hs.tb_attr Termbox.Bindings.Hs.TB_BOLD - -makeUnderline :: Termbox.Bindings.Hs.Tb_color -> Termbox.Bindings.Hs.Tb_color -makeUnderline = - Termbox.Bindings.Hs.tb_attr Termbox.Bindings.Hs.TB_UNDERLINE - -charToCWchar :: Char -> CWchar -charToCWchar = - fromIntegral @Int @CWchar . Char.ord - -foreign import capi unsafe "wchar.h wcwidth" - wcwidth :: CWchar -> CInt diff --git a/src/Termbox/Internal/Color.hs b/src/Termbox/Internal/Color.hs --- a/src/Termbox/Internal/Color.hs +++ b/src/Termbox/Internal/Color.hs @@ -1,5 +1,6 @@ module Termbox.Internal.Color - ( Color (..), + ( -- * Color + Color (..), defaultColor, red, green, @@ -11,12 +12,18 @@ bright, color, gray, + + -- * MaybeColor + MaybeColor, + unMaybeColor, + nothingColor, + justColor, ) where import Data.Coerce (coerce) import Data.Word (Word16) -import qualified Termbox.Bindings.Hs +import Termbox.Bindings.Hs -- | A color. -- @@ -26,7 +33,8 @@ -- * Miscellaneous colors, such as @'color' 33@. -- * Monochrome colors that range from black (@'gray' 0@) to white (@'gray' 23@). newtype Color - = Color Termbox.Bindings.Hs.Tb_color + = Color Tb_color + deriving newtype (Eq) defaultColor :: Color defaultColor = @@ -60,12 +68,12 @@ white = Color 7 --- | Make a basic color brighter. +-- | Make a basic color bright. bright :: Color -> Color bright = coerce bright_ -bright_ :: Termbox.Bindings.Hs.Tb_color -> Termbox.Bindings.Hs.Tb_color +bright_ :: Tb_color -> Tb_color bright_ c | c <= 7 = c + 8 | otherwise = c @@ -83,3 +91,21 @@ gray :: Int -> Color gray = coerce (fromIntegral @Int @Word16 . (+ 232) . max 0 . min 23) + +-- This is a more efficient `Maybe Color`; we represent Nothing by WORD_MAX (which isn't a valid termbox color) +newtype MaybeColor + = MaybeColor Color + deriving stock (Eq) + +unMaybeColor :: MaybeColor -> Tb_color +unMaybeColor (MaybeColor (Color (Tb_color c))) + | c == maxBound = TB_DEFAULT + | otherwise = Tb_color c + +nothingColor :: MaybeColor +nothingColor = + MaybeColor (Color (Tb_color maxBound)) + +justColor :: Color -> MaybeColor +justColor = + MaybeColor diff --git a/src/Termbox/Internal/Image.hs b/src/Termbox/Internal/Image.hs new file mode 100644 --- /dev/null +++ b/src/Termbox/Internal/Image.hs @@ -0,0 +1,104 @@ +module Termbox.Internal.Image + ( Image (..), + char, + at, + atRow, + atCol, + fg, + bg, + bold, + underline, + blink, + ) +where + +import qualified Data.Char as Char +import Foreign.C (CInt (..), CWchar (..)) +import Termbox.Bindings.Hs (tb_change_cell) +import Termbox.Internal.Color (Color) +import Termbox.Internal.Pos (Pos (..)) +import Termbox.Internal.Style (Style) +import qualified Termbox.Internal.Style as Style + +-- | An image. +-- +-- * Create an image with 'char'. +-- * Set an image's color with 'fg' \/ 'bg'. +-- * Style an image with 'bold' \/ 'underline' \/ 'blink'. +-- * Translate an image with 'at' \/ 'atRow' \/ 'atCol'. +-- * Overlay an image atop another with @(<>)@. +newtype Image + = Image (Pos -> Style -> IO ()) + +instance Monoid Image where + mempty = Image mempty + +instance Semigroup Image where + Image f <> Image g = + Image \pos style -> do + f pos style + g pos style + +-- | Create an image from a character. +-- +-- If the character is not 1 character wide, it will not be displayed. +char :: Char -> Image +char ch = + Image \Pos {row, col} style -> + tb_change_cell + col + row + (if wcwidth (charToCWchar ch) == 1 then ch else ' ') + (Style.asForeground style) + (Style.asBackground style) + +-- | Translate an image. +at :: Pos -> Image -> Image +at offset (Image draw) = + Image \pos -> draw (pos <> offset) + +-- | Translate an image by a number of rows. +atRow :: Int -> Image -> Image +atRow row = + at (Pos row 0) + +-- | Translate an image by a number of columns. +atCol :: Int -> Image -> Image +atCol col = + at (Pos 0 col) + +styled :: Style -> Image -> Image +styled overrides (Image draw) = + Image \pos style -> draw pos (overrides <> style) + +-- | Set the foreground color of an image. +fg :: Color -> Image -> Image +fg = + styled . Style.fg + +-- | Set the background color of an image. +bg :: Color -> Image -> Image +bg = + styled . Style.bg + +-- | Make an image bold. +bold :: Image -> Image +bold = + styled Style.bold + +-- | Make an image underlined. +underline :: Image -> Image +underline = + styled Style.underline + +-- | Make an image blink. +blink :: Image -> Image +blink = + styled Style.blink + +charToCWchar :: Char -> CWchar +charToCWchar = + fromIntegral @Int @CWchar . Char.ord + +foreign import capi unsafe "wchar.h wcwidth" + wcwidth :: CWchar -> CInt diff --git a/src/Termbox/Internal/Key.hs b/src/Termbox/Internal/Key.hs --- a/src/Termbox/Internal/Key.hs +++ b/src/Termbox/Internal/Key.hs @@ -22,7 +22,7 @@ -- indistinguishable from @Ctrl+M@. Pattern synonyms below are provided for an alternate syntax in these cases, if -- desired. data Key - = KeyChar Char + = KeyChar !Char | KeyArrowDown | KeyArrowLeft | KeyArrowRight diff --git a/src/Termbox/Internal/Pos.hs b/src/Termbox/Internal/Pos.hs --- a/src/Termbox/Internal/Pos.hs +++ b/src/Termbox/Internal/Pos.hs @@ -9,12 +9,19 @@ import GHC.Generics (Generic) --- | A terminal position. +-- | A relative terminal position. data Pos = Pos { row :: {-# UNPACK #-} !Int, col :: {-# UNPACK #-} !Int } deriving stock (Eq, Generic, Ord, Show) + +instance Monoid Pos where + mempty = Pos 0 0 + +instance Semigroup Pos where + Pos row1 col1 <> Pos row2 col2 = + Pos (row1 + row2) (col1 + col2) -- | Move a position up. posUp :: Int -> Pos -> Pos diff --git a/src/Termbox/Internal/Scene.hs b/src/Termbox/Internal/Scene.hs --- a/src/Termbox/Internal/Scene.hs +++ b/src/Termbox/Internal/Scene.hs @@ -1,71 +1,55 @@ module Termbox.Internal.Scene ( Scene, render, - cell, + image, fill, cursor, ) where -import qualified Termbox.Bindings.Hs -import Termbox.Internal.Cell (Cell, drawCell) -import Termbox.Internal.Color (Color (Color)) +import Termbox.Bindings.Hs hiding (bg) +import Termbox.Internal.Color (Color, MaybeColor, justColor, nothingColor, unMaybeColor) +import Termbox.Internal.Image (Image (..)) import Termbox.Internal.Pos (Pos (..)) +import qualified Termbox.Internal.Style as Style --- | A scene. +-- | A scene, which contains an image, an optional background fill color, and an optional cursor. -- --- * Set individual cells with 'cell'. --- * Set the background fill color with 'fill'. --- * Set the cursor position with 'cursor'. --- * Combine scenes together with @<>@. +-- * Create a scene with 'image'. +-- * Set a scene\'s background fill color with 'fill'. +-- * Set a scene\'s cursor position with 'cursor'. data Scene = Scene - { sceneFill :: Maybe Termbox.Bindings.Hs.Tb_color, - sceneDraw :: Termbox.Bindings.Hs.Tb_color -> IO () + { sceneDraw :: !(MaybeColor -> IO ()), + sceneFill :: {-# UNPACK #-} !MaybeColor } -instance Monoid Scene where - mempty = - Scene - { sceneFill = Nothing, - sceneDraw = \_ -> pure () - } - -instance Semigroup Scene where - Scene fill0 draw0 <> Scene fill1 draw1 = - Scene - { sceneFill = - case fill1 of - Nothing -> fill0 - Just _ -> fill1, - sceneDraw = - \color -> do - draw0 color - draw1 color - } - -- | Render a scene. render :: Scene -> IO () render Scene {sceneFill, sceneDraw} = do - let background = - case sceneFill of - Nothing -> Termbox.Bindings.Hs.TB_DEFAULT - Just color -> color - Termbox.Bindings.Hs.tb_set_clear_attributes Termbox.Bindings.Hs.TB_DEFAULT background - Termbox.Bindings.Hs.tb_clear - sceneDraw background - Termbox.Bindings.Hs.tb_present + tb_set_cursor Nothing + tb_set_clear_attributes TB_DEFAULT (unMaybeColor sceneFill) + tb_clear + sceneDraw sceneFill + tb_present --- | Set the background fill color. -fill :: Color -> Scene -fill (Color color) = - mempty {sceneFill = Just color} +-- | Create a scene from an image. +image :: Image -> Scene +image (Image draw) = + Scene + { sceneDraw = draw mempty . Style.maybeFill, + sceneFill = nothingColor + } --- | Set a single cell. -cell :: Pos -> Cell -> Scene -cell Pos {col, row} img = - mempty {sceneDraw = \bg -> drawCell bg col row img} +-- | Set a scene's background fill color. +fill :: Color -> Scene -> Scene +fill color scene = + scene {sceneFill = justColor color} --- | Set the cursor position. -cursor :: Pos -> Scene -cursor Pos {col, row} = - mempty {sceneDraw = \_ -> Termbox.Bindings.Hs.tb_set_cursor (Just (col, row))} +-- | Set a scene's cursor position. +cursor :: Pos -> Scene -> Scene +cursor Pos {col, row} scene = + scene + { sceneDraw = \background -> do + sceneDraw scene background + tb_set_cursor (Just (col, row)) + } diff --git a/src/Termbox/Internal/Style.hs b/src/Termbox/Internal/Style.hs new file mode 100644 --- /dev/null +++ b/src/Termbox/Internal/Style.hs @@ -0,0 +1,99 @@ +module Termbox.Internal.Style + ( Style, + asForeground, + asBackground, + maybeFill, + fg, + bg, + bold, + underline, + blink, + ) +where + +import Termbox.Bindings.Hs hiding (bg, fg) +import Termbox.Internal.Color (Color, MaybeColor, justColor, nothingColor, unMaybeColor) + +data Style = Style + { foreground :: {-# UNPACK #-} !ColorAndAttr, + background :: {-# UNPACK #-} !ColorAndAttr + } + +instance Monoid Style where + mempty = + Style mempty mempty + +-- right-biased +instance Semigroup Style where + Style a1 b1 <> Style a2 b2 = + Style (a2 <> a1) (b2 <> b1) + +-- Render a style as a foreground `tb_color`. +asForeground :: Style -> Tb_color +asForeground Style {foreground} = + renderColorAndAttr foreground + +-- Render a style as a background `tb_color`. +asBackground :: Style -> Tb_color +asBackground Style {background} = + renderColorAndAttr background + +onlyForeground :: ColorAndAttr -> Style +onlyForeground style = + mempty {foreground = style} + +onlyBackground :: ColorAndAttr -> Style +onlyBackground style = + mempty {background = style} + +maybeFill :: MaybeColor -> Style +maybeFill color = + onlyBackground ColorAndAttr {color, attr = mempty} + +fg :: Color -> Style +fg = + onlyForeground . onlyColor + +bg :: Color -> Style +bg = + onlyBackground . onlyColor + +bold :: Style +bold = + onlyForeground (onlyAttr TB_BOLD) + +underline :: Style +underline = + onlyForeground (onlyAttr TB_UNDERLINE) + +blink :: Style +blink = + onlyBackground (onlyAttr TB_BOLD) + +data ColorAndAttr = ColorAndAttr + { color :: {-# UNPACK #-} !MaybeColor, + attr :: {-# UNPACK #-} !Tb_attr + } + +instance Monoid ColorAndAttr where + mempty = + ColorAndAttr nothingColor mempty + +-- right-biased +instance Semigroup ColorAndAttr where + ColorAndAttr color1 attr1 <> ColorAndAttr color2 attr2 = + ColorAndAttr + (if color2 == nothingColor then color1 else color2) + (attr1 <> attr2) + +renderColorAndAttr :: ColorAndAttr -> Tb_color +renderColorAndAttr ColorAndAttr {color, attr} = + tb_attr attr (unMaybeColor color) + +onlyColor :: Color -> ColorAndAttr +onlyColor color = + mempty {color = justColor color} + +onlyAttr :: Tb_attr -> ColorAndAttr +onlyAttr attr = + mempty {attr} diff --git a/termbox.cabal b/termbox.cabal --- a/termbox.cabal +++ b/termbox.cabal @@ -9,12 +9,15 @@ This package provides a high-level wrapper around @termbox@, a simple C library for writing text-based user interfaces: . - See also: + See also the higher-level interfaces: . - * @@ for a @reactive-banana@ FRP interface. - * @@ for an Elm Architecture interface. - * @@ for lower-level bindings. - * @@ for even lower-level bindings. + * @@, a @reactive-banana@ FRP interface. + * @@, an Elm Architecture interface. + . + And the lower-level interfaces: + . + * @@, direct Haskell-flavored bindings. + * @@, direct C-flavored bindings. homepage: https://github.com/termbox/termbox-haskell license: BSD-3-Clause license-file: LICENSE @@ -22,9 +25,9 @@ name: termbox synopsis: termbox tested-with: GHC == 9.4.7, GHC == 9.6.3, GHC == 9.8.1 -version: 1.1.0.2 +version: 2.0.0 -extra-source-files: +extra-doc-files: CHANGELOG.md source-repository head @@ -77,16 +80,17 @@ import: component build-depends: base ^>= 4.13 || ^>= 4.14 || ^>= 4.15 || ^>= 4.16 || ^>= 4.17 || ^>= 4.18 || ^>= 4.19, - termbox-bindings-hs ^>= 0.1, + termbox-bindings-hs ^>= 0.1.1, exposed-modules: Termbox hs-source-dirs: src other-modules: - Termbox.Internal.Cell Termbox.Internal.Color Termbox.Internal.Event + Termbox.Internal.Image Termbox.Internal.Key Termbox.Internal.Main Termbox.Internal.Mouse Termbox.Internal.Pos Termbox.Internal.Size Termbox.Internal.Scene + Termbox.Internal.Style