diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,25 +5,46 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/) and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [0.3.0] - 2020-09-20 + +### Added +- Add `Cells` and `Cursor` types +- Export `Termbox.Internal` module that roughly corresponds to the C library + +### Changed +- Add a few arguments to the action provided to `run` +- Make `run` throw `InitError`s as IO exceptions +- Reset output mode to "normal" on shutdown to work around a small bug in termbox.c that retains the output mode across + separate invocations of init/shutdown +- Change type of `set` to construct a `Cells` rather than an `IO ()` +- Change a few keys into pattern synonyms because they overlap + +### Removed +- Remove the alt modifier field from `KeyEvent` +- Remove `setCursor`, `hideCursor`, `clear`, `flush`, `getCells`, `getSize`, `poll`, `run_` +- Remove `InputMode`, `MouseMode`, and `OutputMode`, providing sane defaults instead +- Remove build dependency on `c2hs` +- Remove support for GHC < 8.2 + ## [0.2.0.1] - 2020-06-27 ### Changed -- Bumped `base` upper bound +- Bump `base` upper bound ## [0.2.0] - 2019-06-21 ### Added -- `getCells` function -- `run` function +- Add `getCells` function +- Add `run` function ### Changed -- Renamed `size` to `getSize` -- Renamed `main` to `run_` and return errors as an `Either` instead of throwing. -- Made `Attr`'s `Semigroup` instance right-biased instead of left-biased. -- Made `Attr`'s `Num` instance total. +- 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. ### Removed -- `buffer` function +- Add `buffer` function ## [0.1.0] - 2018-07-18 diff --git a/examples/Colors.hs b/examples/Colors.hs --- a/examples/Colors.hs +++ b/examples/Colors.hs @@ -1,122 +1,42 @@ --- | Something like https://github.com/nsf/termbox/blob/8b72969ff4bba120d8b8e4a29bae07102ed71055/src/demo/output.c - -import Control.Monad -import Data.Foldable - -import qualified Termbox as Tb +import Data.Semigroup ((<>)) +import qualified Termbox -main :: IO (Either Tb.InitError ()) +main :: IO () main = - Tb.run $ do - do - let - rectangles :: [(Int, Int, Int, Int)] - rectangles = do - y0 <- [0, 4 ..] - x0 <- [0, 8 .. 24] - pure (x0, y0, x0+7, y0+3) - - let - colors :: [(String, Tb.Attr, Tb.Attr)] - colors = - [ ("black", Tb.black, Tb.white) - , ("red", Tb.red, Tb.black) - , ("green", Tb.green, Tb.black) - , ("yellow", Tb.yellow, Tb.black) - , ("blue", Tb.blue, Tb.black) - , ("magenta", Tb.magenta, Tb.black) - , ("cyan", Tb.cyan, Tb.black) - , ("white", Tb.white, Tb.black) - ] - - zipWithM_ - (\(x0, y0, x1, y1) (name, bg, fg) -> do - rectangle x0 y0 x1 y1 (Tb.Cell ' ' mempty bg) - string x0 y0 fg bg name) - rectangles - colors - - Tb.flush - _ <- Tb.poll - - clear - Tb.setOutputMode Tb.OutputModeGrayscale - - do - let - rectangles :: [(Int, Int, Int, Int)] - rectangles = do - y0 <- [0, 4 ..] - x0 <- [0, 8 .. 40] - pure (x0, y0, x0+7, y0+3) - - zipWithM_ - (\(x0, y0, x1, y1) n -> do - rectangle x0 y0 x1 y1 (Tb.Cell ' ' mempty (fromInteger n)) - string x0 y0 12 (fromInteger n) (show n)) - rectangles - [1..23] - - Tb.flush - _ <- Tb.poll - - clear - Tb.setOutputMode Tb.OutputMode216 - - do - let - rectangles :: [(Int, Int, Int, Int)] - rectangles = do - y0 <- [0, 2..] - x0 <- [0, 4 .. 40] - pure (x0, y0, x0+3, y0+1) - - zipWithM_ - (\(x0, y0, x1, y1) n -> do - rectangle x0 y0 x1 y1 (Tb.Cell ' ' mempty (fromInteger n)) - string x0 y0 2 (fromInteger n) (show n)) - rectangles - [1..216] - - Tb.flush - _ <- Tb.poll - - clear - Tb.setOutputMode Tb.OutputMode256 - - do - let - rectangles :: [(Int, Int, Int, Int)] + Termbox.run $ \_w _h render poll -> do + let rectangles :: [(Int, Int, Int, Int)] rectangles = do - y0 <- [0, 2..] + y0 <- [0, 2 ..] x0 <- [0, 4 .. 48] - pure (x0, y0, x0+3, y0+1) - - zipWithM_ - (\(x0, y0, x1, y1) n -> do - rectangle x0 y0 x1 y1 (Tb.Cell ' ' mempty (fromInteger n)) - string x0 y0 2 (fromInteger n) (show n)) - rectangles - [1..255] + pure (x0, y0, x0 + 3, y0 + 1) - Tb.flush - _ <- Tb.poll + let cells :: Maybe Termbox.Event -> Termbox.Cells + cells lastEvent = + mconcat + ( zipWith + ( \(x0, y0, x1, y1) n -> + rectangle x0 y0 x1 y1 (Termbox.Cell ' ' mempty (fromInteger n)) + <> string x0 y0 mempty (fromInteger n) (show n) + ) + rectangles + [0 .. 255] + ) + <> string 54 1 mempty mempty "Press Esc to quit." + <> string 54 3 mempty mempty ("Last event: " ++ show lastEvent) - pure () + let loop :: Maybe Termbox.Event -> IO () + loop lastEvent = do + render (cells lastEvent) Termbox.NoCursor + poll >>= \case + Termbox.EventKey Termbox.KeyEsc -> pure () + event -> loop (Just event) -clear :: IO () -clear = do - Tb.setOutputMode Tb.OutputModeNormal - Tb.clear mempty mempty - Tb.flush + loop Nothing -string :: Int -> Int -> Tb.Attr -> Tb.Attr -> [Char] -> IO () +string :: Int -> Int -> Termbox.Attr -> Termbox.Attr -> [Char] -> Termbox.Cells string x0 y fg bg = - zipWithM_ - (\x c -> Tb.set x y (Tb.Cell c fg bg)) - [x0..] + mconcat . zipWith (\x c -> Termbox.set x y (Termbox.Cell c fg bg)) [x0 ..] -rectangle :: Int -> Int -> Int -> Int -> Tb.Cell -> IO () +rectangle :: Int -> Int -> Int -> Int -> Termbox.Cell -> Termbox.Cells rectangle x0 y0 x1 y1 c = - for_ ((,) <$> [x0..x1] <*> [y0..y1]) $ \(x, y) -> - Tb.set x y c + foldMap (\(x, y) -> Termbox.set x y c) ((,) <$> [x0 .. x1] <*> [y0 .. y1]) diff --git a/src/Termbox.hs b/src/Termbox.hs --- a/src/Termbox.hs +++ b/src/Termbox.hs @@ -1,18 +1,10 @@ -{-# language InstanceSigs #-} -{-# language LambdaCase #-} -{-# language RankNTypes #-} - -{-# language ScopedTypeVariables #-} -{-# language TypeFamilies #-} -{-# language UnicodeSyntax #-} +{-# LANGUAGE PatternSynonyms #-} -- | -- A @termbox@ program is typically constructed as an infinite loop that: -- --- 1. 'clear's the terminal backbuffer. --- 2. Renders the program state by 'set'ting individual pixels. --- 3. 'flush'es the backbuffer to the terminal. --- 4. 'poll's for an event to update the program state. +-- 1. Renders a scene. +-- 2. Polls for an event. -- -- For example, this progam simply displays the number of keys pressed, and -- quits on @Esc@: @@ -20,31 +12,23 @@ -- @ -- {-\# LANGUAGE LambdaCase \#-} -- --- import Data.Foldable (for_) -- import qualified Termbox -- -- main :: IO () -- main = --- Termbox.'run_' (loop 0) +-- Termbox.'run' (\\_width _height render poll -> loop render poll 0) -- --- loop :: Int -> IO () --- loop n = do --- Termbox.'clear' mempty mempty --- render n --- Termbox.'flush' +-- loop :: (Termbox.'Cells' -> Termbox.'Cursor' -> IO ()) -> IO Termbox.'Event' -> Int -> IO () +-- loop render poll n = do +-- render (string (show n)) Termbox.'NoCursor' -- --- Termbox.'poll' >>= \\case --- Termbox.'EventKey' Termbox.'KeyEsc' _ -> --- pure () --- _ -> --- loop (n+1) +-- poll >>= \\case +-- Termbox.'EventKey' Termbox.'KeyEsc' -> pure () +-- _ -> loop render poll (n+1) -- --- render :: Int -> IO () --- render n = --- for_ --- (zip [0..] (show n)) --- (\\(i, c) -> --- Termbox.'set' i 0 (Termbox.'Cell' c mempty mempty)) +-- string :: Int -> Int -> String -> Termbox.'Cells' +-- string col row = +-- foldMap (\\(i, c) -> Termbox.'set' (col + i) row (Termbox.'Cell' c 0 0)) . zip [0..] -- @ -- -- Other termbox features include cell attributes (style, color), cursor @@ -53,73 +37,95 @@ -- This module is intended to be imported qualified. module Termbox ( -- * Initialization - run - , run_ - , InitError(..) + run, + InitError (..), + -- * Terminal contents - , set - , getCells - , clear - , flush - , Cell(..) - -- * Terminal size - , getSize - -- * Cursor manipulation - , setCursor - , hideCursor - -- * Event handling - , poll - , Event(..) - , Key(..) - , Mouse(..) - , PollError(..) - -- * Attributes - , black - , red - , green - , yellow - , blue - , magenta - , cyan - , white - , bold - , underline - , reverse - , Attr - -- * Terminal modes - , getInputMode - , setInputMode - , InputMode(..) - , MouseMode(..) - , getOutputMode - , setOutputMode - , OutputMode(..) - ) where + set, + Cells, + Cell (..), + Cursor (..), -import Prelude hiding (mod, reverse) + -- * Event handling + Event (..), + Key (..), + -- $key-aliases + pattern KeyCtrlH, + pattern KeyCtrlLsqBracket, + pattern KeyCtrl2, + pattern KeyCtrl3, + pattern KeyCtrl4, + pattern KeyCtrl5, + pattern KeyCtrl7, + pattern KeyCtrlM, + pattern KeyCtrlI, + pattern KeyCtrlUnderscore, + Mouse (..), + PollError (..), -import qualified Termbox.Internal as Tb + -- * Attributes + Attr, + black, + red, + green, + yellow, + blue, + magenta, + cyan, + white, + bold, + underline, + reverse, + ) +where import Control.Exception -import Control.Monad ((>=>), join) -import Data.Array (Array) -import Data.Bits ((.|.), (.&.)) -import Data.Functor (void) -import Data.Semigroup (Semigroup(..)) -import Data.Word -import Foreign (ForeignPtr, Ptr, newForeignPtr_) -import Foreign.Marshal.Alloc (alloca) -import Foreign.Storable -import GHC.Stack +import Data.Semigroup (Semigroup (..)) +import Termbox.Attr + ( Attr, + black, + blue, + bold, + cyan, + green, + magenta, + red, + reverse, + underline, + white, + yellow, + ) +import Termbox.Cell (Cell (Cell)) +import Termbox.Cells (Cells (Cells), set) +import Termbox.Event (Event (..), PollError (..), poll) +import Termbox.Internal +import Termbox.Key + ( Key (..), + pattern KeyCtrl2, + pattern KeyCtrl3, + pattern KeyCtrl4, + pattern KeyCtrl5, + pattern KeyCtrl7, + pattern KeyCtrlH, + pattern KeyCtrlI, + pattern KeyCtrlLsqBracket, + pattern KeyCtrlM, + pattern KeyCtrlUnderscore, + ) +import Termbox.Mouse (Mouse (..)) +import Prelude hiding (reverse) -import qualified Data.Array.Storable as Array (freeze) -import qualified Data.Array.Storable.Internals as Array +-- | A cursor. +data Cursor + = -- | Column, then row + Cursor !Int !Int + | NoCursor --------------------------------------------------------------------------------- --- Initialization --------------------------------------------------------------------------------- +-- $key-aliases +-- In a few cases, distinct key sequences map to equivalent key events. The pattern synonyms below are provided for an +-- alternate syntax in these cases, if desired. --- | Termbox initialization errors that can be returned by 'run'. +-- | Termbox initialization errors. data InitError = FailedToOpenTTY | PipeTrapError @@ -129,554 +135,50 @@ instance Exception InitError -- | Run a @termbox@ program and restore the terminal state afterwards. -run :: IO a -> IO (Either InitError a) -run action = - mask $ \unmask -> - Tb.init >>= \case - Tb.InitOk -> do - result <- unmask action `onException` Tb.shutdown - Tb.shutdown - pure (Right result) - - Tb.FailedToOpenTTY -> pure (Left FailedToOpenTTY) - Tb.PipeTrapError -> pure (Left PipeTrapError) - Tb.UnsupportedTerminal -> pure (Left UnsupportedTerminal) - --- | Like 'run', but throws 'InitError's as @IO@ exceptions. -run_ :: IO a -> IO a -run_ = - run >=> either throwIO pure - - --------------------------------------------------------------------------------- --- Terminal size --------------------------------------------------------------------------------- - --- | Get the terminal size (width, then height). -getSize :: IO (Int, Int) -getSize = - (,) <$> Tb.width <*> Tb.height - - --------------------------------------------------------------------------------- --- Cursor --------------------------------------------------------------------------------- - --- | Set the cursor coordinates (column, then row). -setCursor :: Int -> Int -> IO () -setCursor = - Tb.setCursor - --- | Hide the cursor. -hideCursor :: IO () -hideCursor = - Tb.setCursor Tb._HIDE_CURSOR Tb._HIDE_CURSOR - - --------------------------------------------------------------------------------- --- Terminal contents --------------------------------------------------------------------------------- - --- | A 'Cell' contains a character, foreground attribute, and background --- attribute. -data Cell - = Cell !Char !Attr !Attr - deriving (Eq) - -instance Show Cell where - show (Cell ch fg bg) = - "Cell " ++ show ch ++ " " ++ show (attrToWord fg) ++ " " ++ - show (attrToWord bg) - -instance Storable Cell where - sizeOf :: Cell -> Int - sizeOf _ = - Tb.sizeofCell - - alignment :: Cell -> Int - alignment _ = - Tb.alignofCell - - peek :: Ptr Cell -> IO Cell - peek ptr = - Cell - <$> Tb.getCellCh ptr - <*> (wordToAttr <$> Tb.getCellFg ptr) - <*> (wordToAttr <$> Tb.getCellBg ptr) - - poke :: Ptr Cell -> Cell -> IO () - poke ptr (Cell ch fg bg) = do - Tb.setCellCh ptr ch - Tb.setCellFg ptr (attrToWord fg) - Tb.setCellBg ptr (attrToWord bg) - --- | Set the cell at the given coordinates (column, then row). -set :: Int -> Int -> Cell -> IO () -set x y (Cell ch fg bg) = - Tb.changeCell x y ch (attrToWord fg) (attrToWord bg) - --- | Get the terminal's two-dimensional array of cells (indexed by row, then --- column). -getCells :: IO (Array (Int, Int) Cell) -getCells = - join - (mkbuffer - <$> (tb_cell_buffer >>= newForeignPtr_) - <*> Tb.width - <*> Tb.height) - where - mkbuffer - :: ForeignPtr Cell - -> Int - -> Int - -> IO (Array (Int, Int) Cell) - mkbuffer buff w h = - Array.freeze =<< - Array.unsafeForeignPtrToStorableArray buff ((0, 0), (h-1, w-1)) - --- | Clear the back buffer with the given foreground and background attributes. -clear :: Attr -> Attr -> IO () -clear fg bg = do - Tb.setClearAttributes (attrToWord fg) (attrToWord bg) - Tb.clear - --- | Synchronize the internal back buffer with the terminal. -flush :: IO () -flush = - Tb.present - --------------------------------------------------------------------------------- --- Terminal mode --------------------------------------------------------------------------------- - --- | The input modes. -- --- * __Esc__. When ESC sequence is in the buffer and it doesn't match any known --- sequence, ESC means 'KeyEsc'. --- --- * __Alt__. When ESC sequence is in the buffer and it doesn't match any known --- sequence, ESC enables the /alt/ modifier for the next keyboard event. -data InputMode - = InputModeEsc MouseMode -- ^ Default. - | InputModeAlt MouseMode - deriving (Eq, Ord, Show) - --- | The mouse mode. --- --- * __No__. Don't handle mouse events. --- --- * __Yes__. Handle mouse events. -data MouseMode - = MouseModeNo -- ^ Default. - | MouseModeYes - deriving (Eq, Ord, Show) - --- | Get the current input mode. -getInputMode :: HasCallStack => IO InputMode -getInputMode = - f <$> Tb.selectInputMode Tb._INPUT_CURRENT - where - f :: Int -> InputMode - f = \case - 1 -> InputModeEsc MouseModeNo - 2 -> InputModeAlt MouseModeNo - 5 -> InputModeEsc MouseModeYes - 6 -> InputModeAlt MouseModeYes - n -> error (show n) - --- | Set the input mode. -setInputMode :: InputMode -> IO () -setInputMode = - void . Tb.selectInputMode . f - where - f :: InputMode -> Int - f = \case - InputModeEsc MouseModeNo -> Tb._INPUT_ESC - InputModeEsc MouseModeYes -> Tb._INPUT_ESC .|. Tb._INPUT_MOUSE - InputModeAlt MouseModeNo -> Tb._INPUT_ALT - InputModeAlt MouseModeYes -> Tb._INPUT_ALT .|. Tb._INPUT_MOUSE - --- | The output modes. --- --- * __Normal__. Supports colors /0..8/, which includes all named color --- attributes exported by this library, e.g. 'red'. --- --- * __Grayscale__. Supports colors /0..23/. --- --- * __216__. Supports colors /0..216/. --- --- * __256__. Supports colors /0..255/. -data OutputMode - = OutputModeNormal -- ^ Default. - | OutputModeGrayscale - | OutputMode216 - | OutputMode256 - deriving (Eq, Ord, Show) - --- | Get the current output mode. -getOutputMode :: HasCallStack => IO OutputMode -getOutputMode = - f <$> Tb.selectOutputMode Tb.OutputModeCurrent - where - f :: Tb.OutputMode -> OutputMode - f = \case - Tb.OutputModeNormal -> OutputModeNormal - Tb.OutputMode256 -> OutputMode256 - Tb.OutputMode216 -> OutputMode216 - Tb.OutputModeGrayscale -> OutputModeGrayscale - Tb.OutputModeCurrent -> error "OutputModeCurrent" - --- | Set the output mode. -setOutputMode :: OutputMode -> IO () -setOutputMode = - void . Tb.selectOutputMode . f - where - f :: OutputMode -> Tb.OutputMode - f = \case - OutputModeNormal -> Tb.OutputModeNormal - OutputMode256 -> Tb.OutputMode256 - OutputMode216 -> Tb.OutputMode216 - OutputModeGrayscale -> Tb.OutputModeGrayscale - --------------------------------------------------------------------------------- --- Event handling --------------------------------------------------------------------------------- - --- | A input event. -data Event - = EventKey !Key !Bool -- ^ Key event. The bool indicates the /alt/ modifier. - | EventResize !Int !Int -- ^ Resize event (width, then height) - | EventMouse !Mouse !Int !Int -- ^ Mouse event (column, then row) - deriving (Eq, Show) - --- | A key event. -data Key - = KeyChar Char - | KeyArrowDown - | KeyArrowLeft - | KeyArrowRight - | KeyArrowUp - | KeyBackspace - | KeyBackspace2 - | KeyCtrl2 - | KeyCtrl3 - | KeyCtrl4 - | KeyCtrl5 - | KeyCtrl6 - | KeyCtrl7 - | KeyCtrl8 - | KeyCtrlA - | KeyCtrlB - | KeyCtrlBackslash - | KeyCtrlC - | KeyCtrlD - | KeyCtrlE - | KeyCtrlF - | KeyCtrlG - | KeyCtrlH - | KeyCtrlI - | KeyCtrlJ - | KeyCtrlK - | KeyCtrlL - | KeyCtrlLsqBracket - | KeyCtrlM - | KeyCtrlN - | KeyCtrlO - | KeyCtrlP - | KeyCtrlQ - | KeyCtrlR - | KeyCtrlRsqBracket - | KeyCtrlS - | KeyCtrlSlash - | KeyCtrlT - | KeyCtrlTilde - | KeyCtrlU - | KeyCtrlUnderscore - | KeyCtrlV - | KeyCtrlW - | KeyCtrlX - | KeyCtrlY - | KeyCtrlZ - | KeyDelete - | KeyEnd - | KeyEnter - | KeyEsc - | KeyF1 - | KeyF10 - | KeyF11 - | KeyF12 - | KeyF2 - | KeyF3 - | KeyF4 - | KeyF5 - | KeyF6 - | KeyF7 - | KeyF8 - | KeyF9 - | KeyHome - | KeyInsert - | KeyPageDn - | KeyPageUp - | KeySpace - | KeyTab - deriving (Eq, Ord, Show) - --- | A mouse event. -data Mouse - = MouseLeft - | MouseMiddle - | MouseRelease - | MouseRight - | MouseWheelDown - | MouseWheelUp - deriving (Eq, Ord, Show) - --- | Block until an 'Event' arrives. --- --- /Note/: @termbox v1.1.2@ does not properly handle OS signals that interrupt --- the underlying @select@ system call, so unfortunately the familiar @Ctrl-C@ --- will not be able to stop a program stuck in 'pollEvent'. --- --- You can work around this issue by polling in a background thread using the --- @threaded@ runtime, or simply writing event-handling code that is responsive --- to intuitive "quit" keys like @q@ and @Esc@. +-- The function provided to @run@ is provided: -- --- /Throws/: 'PollError' -poll :: IO Event -poll = - alloca $ \ptr -> - Tb.pollEvent ptr >>= \case - -1 -> - throwIO PollError - _ -> - parseEvent <$> peek ptr - --- | An error occurred when 'poll'ing, due to mysterious circumstances that are --- not well-documented in the original C codebase. -data PollError - = PollError - deriving Show - -instance Exception PollError - --- | Parse an 'Event' from a 'Tb.Event'. -parseEvent :: Tb.Event -> Event -parseEvent = \case - Tb.Event Tb.EventKey mod key ch _ _ _ _ -> - parseEventKey mod key ch - Tb.Event Tb.EventResize _ _ _ w h _ _ -> - EventResize w h - Tb.Event Tb.EventMouse _ key _ _ _ x y -> - EventMouse (parseMouse key) x y - --- | Parse a key 'Event'. -parseEventKey :: Tb.Mod -> Tb.Key -> Char -> Event -parseEventKey mod key ch = - EventKey key' alt - where - key' :: Key - key' = - case ch of - '\0' -> parseKey key - _ -> KeyChar ch - - alt :: Bool - alt = - case mod of - Tb.ModAlt -> True - _ -> False - --- | Parse a 'Key' from a 'Tb.Key'. -parseKey :: HasCallStack => Tb.Key -> Key -parseKey = \case - Tb.KeyArrowDown -> KeyArrowDown - Tb.KeyArrowLeft -> KeyArrowLeft - Tb.KeyArrowRight -> KeyArrowRight - Tb.KeyArrowUp -> KeyArrowUp - Tb.KeyBackspace -> KeyBackspace - Tb.KeyBackspace2 -> KeyBackspace2 - Tb.KeyCtrl2 -> KeyCtrl2 - Tb.KeyCtrl3 -> KeyCtrl3 - Tb.KeyCtrl4 -> KeyCtrl4 - Tb.KeyCtrl5 -> KeyCtrl5 - Tb.KeyCtrl6 -> KeyCtrl6 - Tb.KeyCtrl7 -> KeyCtrl7 - Tb.KeyCtrl8 -> KeyCtrl8 - Tb.KeyCtrlA -> KeyCtrlA - Tb.KeyCtrlB -> KeyCtrlB - Tb.KeyCtrlBackslash -> KeyCtrlBackslash - Tb.KeyCtrlC -> KeyCtrlC - Tb.KeyCtrlD -> KeyCtrlD - Tb.KeyCtrlE -> KeyCtrlE - Tb.KeyCtrlF -> KeyCtrlF - Tb.KeyCtrlG -> KeyCtrlG - Tb.KeyCtrlH -> KeyCtrlH - Tb.KeyCtrlI -> KeyCtrlI - Tb.KeyCtrlJ -> KeyCtrlJ - Tb.KeyCtrlK -> KeyCtrlK - Tb.KeyCtrlL -> KeyCtrlL - Tb.KeyCtrlLsqBracket -> KeyCtrlLsqBracket - Tb.KeyCtrlM -> KeyCtrlM - Tb.KeyCtrlN -> KeyCtrlN - Tb.KeyCtrlO -> KeyCtrlO - Tb.KeyCtrlP -> KeyCtrlP - Tb.KeyCtrlQ -> KeyCtrlQ - Tb.KeyCtrlR -> KeyCtrlR - Tb.KeyCtrlRsqBracket -> KeyCtrlRsqBracket - Tb.KeyCtrlS -> KeyCtrlS - Tb.KeyCtrlSlash -> KeyCtrlSlash - Tb.KeyCtrlT -> KeyCtrlT - Tb.KeyCtrlTilde -> KeyCtrlTilde - Tb.KeyCtrlU -> KeyCtrlU - Tb.KeyCtrlUnderscore -> KeyCtrlUnderscore - Tb.KeyCtrlV -> KeyCtrlV - Tb.KeyCtrlW -> KeyCtrlW - Tb.KeyCtrlX -> KeyCtrlX - Tb.KeyCtrlY -> KeyCtrlY - Tb.KeyCtrlZ -> KeyCtrlZ - Tb.KeyDelete -> KeyDelete - Tb.KeyEnd -> KeyEnd - Tb.KeyEnter -> KeyEnter - Tb.KeyEsc -> KeyEsc - Tb.KeyF1 -> KeyF1 - Tb.KeyF10 -> KeyF10 - Tb.KeyF11 -> KeyF11 - Tb.KeyF12 -> KeyF12 - Tb.KeyF2 -> KeyF2 - Tb.KeyF3 -> KeyF3 - Tb.KeyF4 -> KeyF4 - Tb.KeyF5 -> KeyF5 - Tb.KeyF6 -> KeyF6 - Tb.KeyF7 -> KeyF7 - Tb.KeyF8 -> KeyF8 - Tb.KeyF9 -> KeyF9 - Tb.KeyHome -> KeyHome - Tb.KeyInsert -> KeyInsert - Tb.KeyPageDn -> KeyPageDn - Tb.KeyPageUp -> KeyPageUp - Tb.KeySpace -> KeySpace - Tb.KeyTab -> KeyTab - key -> error (show key) - --- | Parse a 'Mouse' from a 'Tb.Key'. -parseMouse :: HasCallStack => Tb.Key -> Mouse -parseMouse = \case - Tb.KeyMouseLeft -> MouseLeft - Tb.KeyMouseMiddle -> MouseMiddle - Tb.KeyMouseRelease -> MouseRelease - Tb.KeyMouseRight -> MouseRight - Tb.KeyMouseWheelDown -> MouseWheelDown - Tb.KeyMouseWheelUp -> MouseWheelUp - key -> error (show key) - --------------------------------------------------------------------------------- --- Attributes --------------------------------------------------------------------------------- - --- | A cell attribute, which includes its color, and whether or not it is --- bold, underlined, and/or reversed. +-- * The initial terminal width +-- * The initial terminal height +-- * An action that renders a scene +-- * An action that polls for an event indefinitely -- --- A cell can only have one color, but may be (for example) bold /and/ --- underlined. The 'Monoid' instance combines 'Attr's this way, with a right --- bias. -data Attr - = Attr !Word16 {- color -} !Word16 {- attr -} - deriving (Eq) - -instance Monoid Attr where - mempty :: Attr - mempty = - Attr Tb._DEFAULT 0 - - mappend :: Attr -> Attr -> Attr - mappend = - (<>) - --- | Provided for numeric literals. -instance Num Attr where - fromInteger :: Integer -> Attr - fromInteger n = - Attr (fromIntegral (n `rem` 256)) 0 - - (+) = (<>) - (*) = (<>) - (-) = (<>) - abs = id - signum = id - --- | Left-biased color; attributes are merged. -instance Semigroup Attr where - (<>) :: Attr -> Attr -> Attr - Attr 0 ax <> Attr cy ay = Attr cy (ax .|. ay) - Attr cx ax <> Attr 0 ay = Attr cx (ax .|. ay) - Attr _ ax <> Attr cy ay = Attr cy (ax .|. ay) - -wordToAttr :: Word16 -> Attr -wordToAttr w = - Attr (w .&. 0x00FF) (w .&. 0xFF00) - -attrToWord :: Attr -> Word16 -attrToWord (Attr x y) = - x .|. y - --- | @black = 1@. -black :: Attr -black = - Attr Tb._BLACK 0 - --- | @red = 2@. -red :: Attr -red = - Attr Tb._RED 0 - --- | @green = 3@. -green :: Attr -green = - Attr Tb._GREEN 0 - --- | @yellow = 4@. -yellow :: Attr -yellow = - Attr Tb._YELLOW 0 - --- | @blue = 5@. -blue :: Attr -blue = - Attr Tb._BLUE 0 - --- | @magenta = 6@. -magenta :: Attr -magenta = - Attr Tb._MAGENTA 0 - --- | @cyan = 7@. -cyan :: Attr -cyan = - Attr Tb._CYAN 0 - --- | @white = 8@. -white :: Attr -white = - Attr Tb._WHITE 0 - --- | Bold modifier attribute. -bold :: Attr -bold = - Attr Tb._DEFAULT Tb._BOLD - --- | Underline modifier attribute. -underline :: Attr -underline = - Attr Tb._DEFAULT Tb._UNDERLINE - --- | Reverse modifier attribute. -reverse :: Attr -reverse = - Attr Tb._DEFAULT Tb._REVERSE +-- /Throws/: 'InitError' +run :: (Int -> Int -> (Cells -> Cursor -> IO ()) -> IO Event -> IO a) -> IO a +run action = do + mask $ \unmask -> do + initResult <- tb_init + case () of + _ | initResult == 0 -> do + result <- + unmask + ( do + _ <- tb_select_input_mode tB_INPUT_MOUSE + _ <- tb_select_output_mode tB_OUTPUT_256 + width <- tb_width + height <- tb_height + action width height render poll + ) + `onException` shutdown + shutdown + pure result + _ | initResult == tB_EFAILED_TO_OPEN_TTY -> throwIO FailedToOpenTTY + _ | initResult == tB_EPIPE_TRAP_ERROR -> throwIO PipeTrapError + _ | initResult == tB_EUNSUPPORTED_TERMINAL -> throwIO UnsupportedTerminal + _ -> error ("termbox: unknown tb_init error " ++ show initResult) --------------------------------------------------------------------------------- --- Foreign imports --------------------------------------------------------------------------------- +-- | Render a scene. +render :: Cells -> Cursor -> IO () +render (Cells cells) cursor = do + tb_set_clear_attributes 0 0 + tb_clear + cells + case cursor of + Cursor col row -> tb_set_cursor col row + NoCursor -> tb_set_cursor tB_HIDE_CURSOR tB_HIDE_CURSOR + tb_present -foreign import ccall safe "termbox.h tb_cell_buffer" - tb_cell_buffer :: IO (Ptr Cell) +shutdown :: IO () +shutdown = do + _ <- tb_select_output_mode tB_OUTPUT_NORMAL + tb_shutdown diff --git a/src/Termbox/Attr.hs b/src/Termbox/Attr.hs new file mode 100644 --- /dev/null +++ b/src/Termbox/Attr.hs @@ -0,0 +1,124 @@ +module Termbox.Attr + ( Attr, + black, + blue, + bold, + cyan, + green, + magenta, + red, + reverse, + underline, + white, + yellow, + -- + attrToWord, + wordToAttr, + ) +where + +import Data.Bits ((.&.), (.|.)) +import Data.Semigroup (Semigroup (..)) +import Data.Word (Word16) +import Termbox.Internal +import Prelude hiding (reverse) + +-- | A cell attribute, which includes its color, and whether or not it is +-- bold, underlined, and/or reversed. +-- +-- A cell can only have one color, but may be (for example) bold /and/ +-- underlined. The 'Monoid' instance combines 'Attr's this way, with a right bias. +data Attr + = Attr !Word16 {- color -} !Word16 {- attr -} + deriving (Eq, Show) + +instance Monoid Attr where + mempty :: Attr + mempty = + Attr tB_DEFAULT 0 + + mappend :: Attr -> Attr -> Attr + mappend = + (<>) + +-- | Provided for numeric literals. +instance Num Attr where + fromInteger :: Integer -> Attr + fromInteger n = + Attr (fromIntegral (n `rem` 256)) 0 + + (+) = (<>) + (*) = (<>) + (-) = (<>) + abs = id + signum = id + +-- | Right-biased color; attributes are merged. +instance Semigroup Attr where + (<>) :: Attr -> Attr -> Attr + Attr 0 ax <> Attr cy ay = Attr cy (ax .|. ay) + Attr cx ax <> Attr 0 ay = Attr cx (ax .|. ay) + Attr _ ax <> Attr cy ay = Attr cy (ax .|. ay) + +wordToAttr :: Word16 -> Attr +wordToAttr w = + Attr (w .&. 0x00FF) (w .&. 0xFF00) + +attrToWord :: Attr -> Word16 +attrToWord (Attr x y) = + x .|. y + +-- | @black = 1@. +black :: Attr +black = + Attr tB_BLACK 0 + +-- | @red = 2@. +red :: Attr +red = + Attr tB_RED 0 + +-- | @green = 3@. +green :: Attr +green = + Attr tB_GREEN 0 + +-- | @yellow = 4@. +yellow :: Attr +yellow = + Attr tB_YELLOW 0 + +-- | @blue = 5@. +blue :: Attr +blue = + Attr tB_BLUE 0 + +-- | @magenta = 6@. +magenta :: Attr +magenta = + Attr tB_MAGENTA 0 + +-- | @cyan = 7@. +cyan :: Attr +cyan = + Attr tB_CYAN 0 + +-- | @white = 8@. +white :: Attr +white = + Attr tB_WHITE 0 + +-- | Bold modifier attribute. +bold :: Attr +bold = + Attr tB_DEFAULT tB_BOLD + +-- | Underline modifier attribute. +underline :: Attr +underline = + Attr tB_DEFAULT tB_UNDERLINE + +-- | Reverse modifier attribute. +reverse :: Attr +reverse = + Attr tB_DEFAULT tB_REVERSE diff --git a/src/Termbox/Cell.hs b/src/Termbox/Cell.hs new file mode 100644 --- /dev/null +++ b/src/Termbox/Cell.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE TypeApplications #-} + +module Termbox.Cell + ( Cell (..), + ) +where + +import Data.Char (chr, ord) +import Data.Word (Word32) +import Foreign.Ptr (Ptr) +import Foreign.Storable +import Termbox.Attr (Attr, attrToWord, wordToAttr) + +-- | A cell contains a character, foreground attribute, and background attribute. +data Cell + = Cell !Char !Attr !Attr + deriving (Eq, Show) + +instance Storable Cell where + sizeOf :: Cell -> Int + sizeOf _ = + 8 + + alignment :: Cell -> Int + alignment _ = + 4 + + peek :: Ptr Cell -> IO Cell + peek ptr = do + Cell + <$> (chr . fromIntegral @Word32 @Int <$> peekByteOff ptr 0) + <*> (wordToAttr <$> peekByteOff ptr 4) + <*> (wordToAttr <$> peekByteOff ptr 6) + + poke :: Ptr Cell -> Cell -> IO () + poke ptr (Cell ch fg bg) = do + pokeByteOff ptr 0 (fromIntegral @Int @Word32 (ord ch)) + pokeByteOff ptr 4 (attrToWord fg) + pokeByteOff ptr 6 (attrToWord bg) diff --git a/src/Termbox/Cells.hs b/src/Termbox/Cells.hs new file mode 100644 --- /dev/null +++ b/src/Termbox/Cells.hs @@ -0,0 +1,21 @@ +module Termbox.Cells + ( Cells (..), + set, + ) +where + +import Data.Char (ord) +import Data.Semigroup (Semigroup) +import Termbox.Attr (attrToWord) +import Termbox.Cell (Cell (Cell)) +import Termbox.Internal (tb_change_cell) + +-- | A grid of cells. Create with 'set' and combine with ('<>'). +newtype Cells + = Cells (IO ()) + deriving {- newtype -} (Monoid, Semigroup) + +-- | Set a single cell's value (column, then row). +set :: Int -> Int -> Cell -> Cells +set col row (Cell ch fg bg) = + Cells (tb_change_cell col row (fromIntegral (ord ch)) (attrToWord fg) (attrToWord bg)) diff --git a/src/Termbox/Event.hs b/src/Termbox/Event.hs new file mode 100644 --- /dev/null +++ b/src/Termbox/Event.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE TypeApplications #-} + +module Termbox.Event + ( Event (..), + poll, + PollError (..), + ) +where + +import Control.Exception (Exception, throwIO) +import Data.Char (chr) +import Data.Int (Int32) +import Data.Semigroup (Semigroup (..)) +import Data.Word (Word32) +import Foreign.Marshal.Alloc (alloca) +import Foreign.Storable (peek) +import Termbox.Internal +import Termbox.Key (Key (KeyChar), parseKey) +import Termbox.Mouse (Mouse, parseMouse) +import Prelude hiding (mod) + +-- | A input event. +data Event + = -- | Key event + EventKey !Key + | -- | Resize event (width, then height) + EventResize !Int !Int + | -- | Mouse event (column, then row) + EventMouse !Mouse !Int !Int + deriving (Eq, Show) + +-- | Block until an 'Event' arrives. +-- +-- /Throws/: 'PollError' +poll :: IO Event +poll = + alloca $ \ptr -> + tb_poll_event ptr >>= \case + -1 -> throwIO PollError + _ -> parseEvent <$> peek ptr + +-- | An error occurred when polling, due to mysterious circumstances that are not well-documented in the original C +-- codebase. +data PollError + = PollError + deriving (Show) + +instance Exception PollError + +-- | Parse an 'Event' from a 'TbEvent'. +parseEvent :: TbEvent -> Event +parseEvent (TbEvent typ _mod key ch w h x y) + | typ == tB_EVENT_KEY = + EventKey (if ch == 0 then parseKey key else KeyChar (chr (fromIntegral @Word32 @Int ch))) + | typ == tB_EVENT_RESIZE = EventResize (fromIntegral @Int32 @Int w) (fromIntegral @Int32 @Int h) + | typ == tB_EVENT_MOUSE = EventMouse (parseMouse key) (fromIntegral @Int32 @Int x) (fromIntegral @Int32 @Int y) + | otherwise = error ("termbox: unknown event type " ++ show typ) diff --git a/src/Termbox/Internal.chs b/src/Termbox/Internal.chs deleted file mode 100644 --- a/src/Termbox/Internal.chs +++ /dev/null @@ -1,312 +0,0 @@ --- | Lowest-level termbox bindings. No creativity here, just a 1:1 mapping. --- Some of the enums are hand-written (source copied from generated module) so --- I can insert haddocks. - -{-# language InstanceSigs #-} - -module Termbox.Internal where - -#include - -import Data.Char (ord) -import Data.Word -import Foreign -import Foreign.C -import Prelude hiding (mod) - --------------------------------------------------------------------------------- --- Constants --------------------------------------------------------------------------------- - -_INPUT_CURRENT, _INPUT_ESC, _INPUT_ALT, _INPUT_MOUSE :: Int -_HIDE_CURSOR :: Int -_BOLD, _UNDERLINE, _REVERSE :: Word16 -_DEFAULT, _BLACK, _RED, _GREEN, _YELLOW, _BLUE, _MAGENTA, _CYAN, _WHITE :: Word16 - -_INPUT_CURRENT = {# const TB_INPUT_CURRENT #} -_INPUT_ESC = {# const TB_INPUT_ESC #} -_INPUT_ALT = {# const TB_INPUT_ALT #} -_INPUT_MOUSE = {# const TB_INPUT_MOUSE #} - -_HIDE_CURSOR = {# const TB_HIDE_CURSOR #} - -_BOLD = {# const TB_BOLD #} -_UNDERLINE = {# const TB_UNDERLINE #} -_REVERSE = {# const TB_REVERSE #} - -_DEFAULT = {# const TB_DEFAULT #} -_BLACK = {# const TB_BLACK #} -_RED = {# const TB_RED #} -_GREEN = {# const TB_GREEN #} -_YELLOW = {# const TB_YELLOW #} -_BLUE = {# const TB_BLUE #} -_MAGENTA = {# const TB_MAGENTA #} -_CYAN = {# const TB_CYAN #} -_WHITE = {# const TB_WHITE #} - --------------------------------------------------------------------------------- --- Enums --------------------------------------------------------------------------------- - -{# - enum define EventType - { TB_EVENT_KEY as EventKey - , TB_EVENT_RESIZE as EventResize - , TB_EVENT_MOUSE as EventMouse - } -#} - -{# - enum define InitResult - { 0 as InitOk - , TB_EUNSUPPORTED_TERMINAL as UnsupportedTerminal - , TB_EFAILED_TO_OPEN_TTY as FailedToOpenTTY - , TB_EPIPE_TRAP_ERROR as PipeTrapError - } -#} - -{# - enum define Key - { TB_KEY_F1 as KeyF1 - , TB_KEY_F2 as KeyF2 - , TB_KEY_F3 as KeyF3 - , TB_KEY_F4 as KeyF4 - , TB_KEY_F5 as KeyF5 - , TB_KEY_F6 as KeyF6 - , TB_KEY_F7 as KeyF7 - , TB_KEY_F8 as KeyF8 - , TB_KEY_F9 as KeyF9 - , TB_KEY_F10 as KeyF10 - , TB_KEY_F11 as KeyF11 - , TB_KEY_F12 as KeyF12 - , TB_KEY_INSERT as KeyInsert - , TB_KEY_DELETE as KeyDelete - , TB_KEY_HOME as KeyHome - , TB_KEY_END as KeyEnd - , TB_KEY_PGUP as KeyPageUp - , TB_KEY_PGDN as KeyPageDn - , TB_KEY_ARROW_UP as KeyArrowUp - , TB_KEY_ARROW_DOWN as KeyArrowDown - , TB_KEY_ARROW_LEFT as KeyArrowLeft - , TB_KEY_ARROW_RIGHT as KeyArrowRight - , TB_KEY_MOUSE_LEFT as KeyMouseLeft - , TB_KEY_MOUSE_RIGHT as KeyMouseRight - , TB_KEY_MOUSE_MIDDLE as KeyMouseMiddle - , TB_KEY_MOUSE_RELEASE as KeyMouseRelease - , TB_KEY_MOUSE_WHEEL_UP as KeyMouseWheelUp - , TB_KEY_MOUSE_WHEEL_DOWN as KeyMouseWheelDown - , TB_KEY_CTRL_TILDE as KeyCtrlTilde - , TB_KEY_CTRL_2 as KeyCtrl2 - , TB_KEY_CTRL_A as KeyCtrlA - , TB_KEY_CTRL_B as KeyCtrlB - , TB_KEY_CTRL_C as KeyCtrlC - , TB_KEY_CTRL_D as KeyCtrlD - , TB_KEY_CTRL_E as KeyCtrlE - , TB_KEY_CTRL_F as KeyCtrlF - , TB_KEY_CTRL_G as KeyCtrlG - , TB_KEY_BACKSPACE as KeyBackspace - , TB_KEY_CTRL_H as KeyCtrlH - , TB_KEY_TAB as KeyTab - , TB_KEY_CTRL_I as KeyCtrlI - , TB_KEY_CTRL_J as KeyCtrlJ - , TB_KEY_CTRL_K as KeyCtrlK - , TB_KEY_CTRL_L as KeyCtrlL - , TB_KEY_ENTER as KeyEnter - , TB_KEY_CTRL_M as KeyCtrlM - , TB_KEY_CTRL_N as KeyCtrlN - , TB_KEY_CTRL_O as KeyCtrlO - , TB_KEY_CTRL_P as KeyCtrlP - , TB_KEY_CTRL_Q as KeyCtrlQ - , TB_KEY_CTRL_R as KeyCtrlR - , TB_KEY_CTRL_S as KeyCtrlS - , TB_KEY_CTRL_T as KeyCtrlT - , TB_KEY_CTRL_U as KeyCtrlU - , TB_KEY_CTRL_V as KeyCtrlV - , TB_KEY_CTRL_W as KeyCtrlW - , TB_KEY_CTRL_X as KeyCtrlX - , TB_KEY_CTRL_Y as KeyCtrlY - , TB_KEY_CTRL_Z as KeyCtrlZ - , TB_KEY_ESC as KeyEsc - , TB_KEY_CTRL_LSQ_BRACKET as KeyCtrlLsqBracket - , TB_KEY_CTRL_3 as KeyCtrl3 - , TB_KEY_CTRL_4 as KeyCtrl4 - , TB_KEY_CTRL_BACKSLASH as KeyCtrlBackslash - , TB_KEY_CTRL_5 as KeyCtrl5 - , TB_KEY_CTRL_RSQ_BRACKET as KeyCtrlRsqBracket - , TB_KEY_CTRL_6 as KeyCtrl6 - , TB_KEY_CTRL_7 as KeyCtrl7 - , TB_KEY_CTRL_SLASH as KeyCtrlSlash - , TB_KEY_CTRL_UNDERSCORE as KeyCtrlUnderscore - , TB_KEY_SPACE as KeySpace - , TB_KEY_BACKSPACE2 as KeyBackspace2 - , TB_KEY_CTRL_8 as KeyCtrl8 - } deriving (Show) -#} - -{# - enum define Mod - { 0 as ModNone - , TB_MOD_ALT as ModAlt - } -#} - -{# - enum define OutputMode - { TB_OUTPUT_CURRENT as OutputModeCurrent - , TB_OUTPUT_NORMAL as OutputModeNormal - , TB_OUTPUT_256 as OutputMode256 - , TB_OUTPUT_216 as OutputMode216 - , TB_OUTPUT_GRAYSCALE as OutputModeGrayscale - } - -#} - --------------------------------------------------------------------------------- --- Types --------------------------------------------------------------------------------- - -sizeofCell :: Int -sizeofCell = - {# sizeof tb_cell #} - -alignofCell :: Int -alignofCell = - {# alignof tb_cell #} - -getCellCh :: Ptr a -> IO Char -getCellCh = - fmap (toEnum . fromIntegral) . {# get tb_cell->ch #} - -getCellFg :: Ptr a -> IO Word16 -getCellFg = - fmap fromIntegral . {# get tb_cell->fg #} - -getCellBg :: Ptr a -> IO Word16 -getCellBg = - fmap fromIntegral . {# get tb_cell->bg #} - -setCellCh :: Ptr a -> Char -> IO () -setCellCh p = - {# set tb_cell.ch #} p . fromIntegral . fromEnum - -setCellFg :: Ptr a -> Word16 -> IO () -setCellFg p = - {# set tb_cell.fg #} p . fromIntegral - -setCellBg :: Ptr a -> Word16 -> IO () -setCellBg p = - {# set tb_cell.bg #} p . fromIntegral - -data Event - = Event !EventType Mod Key Char Int Int Int Int - -instance Storable Event where - sizeOf :: Event -> Int - sizeOf _ = - {# sizeof tb_event #} - - alignment :: Event -> Int - alignment _ = - {# alignof tb_event #} - - peek :: Ptr Event -> IO Event - peek p = - Event - <$> ((toEnum . fromIntegral) <$> {# get tb_event->type #} p) - <*> ((toEnum . fromIntegral) <$> {# get tb_event->mod #} p) - <*> ((toEnum . fromIntegral) <$> {# get tb_event->key #} p) - <*> ((toEnum . fromIntegral) <$> {# get tb_event->ch #} p) - <*> (fromIntegral <$> {# get tb_event->w #} p) - <*> (fromIntegral <$> {# get tb_event->h #} p) - <*> (fromIntegral <$> {# get tb_event->x #} p) - <*> (fromIntegral <$> {# get tb_event->y #} p) - - poke :: Ptr Event -> Event -> IO () - poke p (Event typ mod key ch w h x y) = do - {# set tb_event.type #} p (fromIntegral (fromEnum typ)) - {# set tb_event.mod #} p (fromIntegral (fromEnum mod)) - {# set tb_event.key #} p (fromIntegral (fromEnum key)) - {# set tb_event.ch #} p (fromIntegral (fromEnum ch)) - {# set tb_event.w #} p (fromIntegral w) - {# set tb_event.h #} p (fromIntegral h) - {# set tb_event.x #} p (fromIntegral x) - {# set tb_event.y #} p (fromIntegral y) - -{# pointer *tb_event as EventPtr -> Event #} - --------------------------------------------------------------------------------- --- Functions --------------------------------------------------------------------------------- - -{# - fun tb_change_cell as changeCell - { `Int', `Int', charToUInt `Char', `Word16', `Word16' } -> `()' -#} - -{# - fun tb_clear as clear - { } -> `()' -#} - -{# - fun tb_height as height - { } -> `Int' -#} - -{# - fun tb_init as init - { } -> `InitResult' -#} - -{# - fun tb_peek_event as peekEvent - { `EventPtr', `Int' } -> `Int' -#} - -{# - fun tb_poll_event as pollEvent - { `EventPtr' } -> `Int' -#} - -{# - fun tb_present as present - { } -> `()' -#} - -{# - fun tb_select_input_mode as selectInputMode - { `Int' } -> `Int' -#} - -{# - fun tb_select_output_mode as selectOutputMode - { `OutputMode' } -> `OutputMode' -#} - -{# - fun tb_set_clear_attributes as setClearAttributes - { `Word16', `Word16' } -> `()' -#} - -{# - fun tb_set_cursor as setCursor - { `Int', `Int' } -> `()' -#} - -{# - fun tb_shutdown as shutdown - { } -> `()' -#} - -{# - fun tb_width as width - { } -> `Int' -#} - --------------------------------------------------------------------------------- --- Misc. --------------------------------------------------------------------------------- - -charToUInt :: Char -> CUInt -charToUInt = - fromIntegral . ord diff --git a/src/Termbox/Internal.hs b/src/Termbox/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Termbox/Internal.hs @@ -0,0 +1,350 @@ +module Termbox.Internal where + +import Data.Int (Int32) +import Data.Word +import Foreign.Ptr (Ptr) +import Foreign.Storable +import Prelude hiding (mod) + +tB_EUNSUPPORTED_TERMINAL, tB_EFAILED_TO_OPEN_TTY, tB_EPIPE_TRAP_ERROR :: Int +tB_EUNSUPPORTED_TERMINAL = -1 +tB_EFAILED_TO_OPEN_TTY = -2 +tB_EPIPE_TRAP_ERROR = -3 + +tB_INPUT_CURRENT, tB_INPUT_ESC, tB_INPUT_ALT, tB_INPUT_MOUSE :: Int +tB_INPUT_CURRENT = 0 +tB_INPUT_ESC = 1 +tB_INPUT_ALT = 2 +tB_INPUT_MOUSE = 4 + +tB_OUTPUT_CURRENT, tB_OUTPUT_NORMAL, tB_OUTPUT_256, tB_OUTPUT_216, tB_OUTPUT_GRAYSCALE :: Int +tB_OUTPUT_CURRENT = 0 +tB_OUTPUT_NORMAL = 1 +tB_OUTPUT_256 = 2 +tB_OUTPUT_216 = 3 +tB_OUTPUT_GRAYSCALE = 4 + +tB_EVENT_KEY, tB_EVENT_RESIZE, tB_EVENT_MOUSE :: Word8 +tB_EVENT_KEY = 1 +tB_EVENT_RESIZE = 2 +tB_EVENT_MOUSE = 3 + +tB_MOD_ALT :: Word8 +tB_MOD_ALT = 0x01 + +-- #define TB_MOD_MOTION 0x02 + +tB_HIDE_CURSOR :: Int +tB_HIDE_CURSOR = -1 + +tB_BOLD, tB_UNDERLINE, tB_REVERSE :: Word16 +tB_BOLD = 0x0100 +tB_UNDERLINE = 0x0200 +tB_REVERSE = 0x0400 + +tB_DEFAULT, tB_BLACK, tB_RED, tB_GREEN, tB_YELLOW, tB_BLUE, tB_MAGENTA, tB_CYAN, tB_WHITE :: Word16 +tB_DEFAULT = 0x00 +tB_BLACK = 0x01 +tB_RED = 0x02 +tB_GREEN = 0x03 +tB_YELLOW = 0x04 +tB_BLUE = 0x05 +tB_MAGENTA = 0x06 +tB_CYAN = 0x07 +tB_WHITE = 0x08 + +tB_KEY_F1 :: Word16 +tB_KEY_F1 = 0xFFFF - 0 + +tB_KEY_F2 :: Word16 +tB_KEY_F2 = 0xFFFF - 1 + +tB_KEY_F3 :: Word16 +tB_KEY_F3 = 0xFFFF - 2 + +tB_KEY_F4 :: Word16 +tB_KEY_F4 = 0xFFFF - 3 + +tB_KEY_F5 :: Word16 +tB_KEY_F5 = 0xFFFF - 4 + +tB_KEY_F6 :: Word16 +tB_KEY_F6 = 0xFFFF - 5 + +tB_KEY_F7 :: Word16 +tB_KEY_F7 = 0xFFFF - 6 + +tB_KEY_F8 :: Word16 +tB_KEY_F8 = 0xFFFF - 7 + +tB_KEY_F9 :: Word16 +tB_KEY_F9 = 0xFFFF - 8 + +tB_KEY_F10 :: Word16 +tB_KEY_F10 = 0xFFFF - 9 + +tB_KEY_F11 :: Word16 +tB_KEY_F11 = 0xFFFF - 10 + +tB_KEY_F12 :: Word16 +tB_KEY_F12 = 0xFFFF - 11 + +tB_KEY_INSERT :: Word16 +tB_KEY_INSERT = 0xFFFF - 12 + +tB_KEY_DELETE :: Word16 +tB_KEY_DELETE = 0xFFFF - 13 + +tB_KEY_HOME :: Word16 +tB_KEY_HOME = 0xFFFF - 14 + +tB_KEY_END :: Word16 +tB_KEY_END = 0xFFFF - 15 + +tB_KEY_PGUP :: Word16 +tB_KEY_PGUP = 0xFFFF - 16 + +tB_KEY_PGDN :: Word16 +tB_KEY_PGDN = 0xFFFF - 17 + +tB_KEY_ARROW_UP :: Word16 +tB_KEY_ARROW_UP = 0xFFFF - 18 + +tB_KEY_ARROW_DOWN :: Word16 +tB_KEY_ARROW_DOWN = 0xFFFF - 19 + +tB_KEY_ARROW_LEFT :: Word16 +tB_KEY_ARROW_LEFT = 0xFFFF - 20 + +tB_KEY_ARROW_RIGHT :: Word16 +tB_KEY_ARROW_RIGHT = 0xFFFF - 21 + +tB_KEY_MOUSE_LEFT :: Word16 +tB_KEY_MOUSE_LEFT = 0xFFFF - 22 + +tB_KEY_MOUSE_RIGHT :: Word16 +tB_KEY_MOUSE_RIGHT = 0xFFFF - 23 + +tB_KEY_MOUSE_MIDDLE :: Word16 +tB_KEY_MOUSE_MIDDLE = 0xFFFF - 24 + +tB_KEY_MOUSE_RELEASE :: Word16 +tB_KEY_MOUSE_RELEASE = 0xFFFF - 25 + +tB_KEY_MOUSE_WHEEL_UP :: Word16 +tB_KEY_MOUSE_WHEEL_UP = 0xFFFF - 26 + +tB_KEY_MOUSE_WHEEL_DOWN :: Word16 +tB_KEY_MOUSE_WHEEL_DOWN = 0xFFFF - 27 + +tB_KEY_CTRL_TILDE :: Word16 +tB_KEY_CTRL_TILDE = 0x00 + +tB_KEY_CTRL_2 :: Word16 +tB_KEY_CTRL_2 = 0x00 + +tB_KEY_CTRL_A :: Word16 +tB_KEY_CTRL_A = 0x01 + +tB_KEY_CTRL_B :: Word16 +tB_KEY_CTRL_B = 0x02 + +tB_KEY_CTRL_C :: Word16 +tB_KEY_CTRL_C = 0x03 + +tB_KEY_CTRL_D :: Word16 +tB_KEY_CTRL_D = 0x04 + +tB_KEY_CTRL_E :: Word16 +tB_KEY_CTRL_E = 0x05 + +tB_KEY_CTRL_F :: Word16 +tB_KEY_CTRL_F = 0x06 + +tB_KEY_CTRL_G :: Word16 +tB_KEY_CTRL_G = 0x07 + +tB_KEY_BACKSPACE :: Word16 +tB_KEY_BACKSPACE = 0x08 + +tB_KEY_CTRL_H :: Word16 +tB_KEY_CTRL_H = 0x08 + +tB_KEY_TAB :: Word16 +tB_KEY_TAB = 0x09 + +tB_KEY_CTRL_I :: Word16 +tB_KEY_CTRL_I = 0x09 + +tB_KEY_CTRL_J :: Word16 +tB_KEY_CTRL_J = 0x0A + +tB_KEY_CTRL_K :: Word16 +tB_KEY_CTRL_K = 0x0B + +tB_KEY_CTRL_L :: Word16 +tB_KEY_CTRL_L = 0x0C + +tB_KEY_ENTER :: Word16 +tB_KEY_ENTER = 0x0D + +tB_KEY_CTRL_M :: Word16 +tB_KEY_CTRL_M = 0x0D + +tB_KEY_CTRL_N :: Word16 +tB_KEY_CTRL_N = 0x0E + +tB_KEY_CTRL_O :: Word16 +tB_KEY_CTRL_O = 0x0F + +tB_KEY_CTRL_P :: Word16 +tB_KEY_CTRL_P = 0x10 + +tB_KEY_CTRL_Q :: Word16 +tB_KEY_CTRL_Q = 0x11 + +tB_KEY_CTRL_R :: Word16 +tB_KEY_CTRL_R = 0x12 + +tB_KEY_CTRL_S :: Word16 +tB_KEY_CTRL_S = 0x13 + +tB_KEY_CTRL_T :: Word16 +tB_KEY_CTRL_T = 0x14 + +tB_KEY_CTRL_U :: Word16 +tB_KEY_CTRL_U = 0x15 + +tB_KEY_CTRL_V :: Word16 +tB_KEY_CTRL_V = 0x16 + +tB_KEY_CTRL_W :: Word16 +tB_KEY_CTRL_W = 0x17 + +tB_KEY_CTRL_X :: Word16 +tB_KEY_CTRL_X = 0x18 + +tB_KEY_CTRL_Y :: Word16 +tB_KEY_CTRL_Y = 0x19 + +tB_KEY_CTRL_Z :: Word16 +tB_KEY_CTRL_Z = 0x1A + +tB_KEY_ESC :: Word16 +tB_KEY_ESC = 0x1B + +tB_KEY_CTRL_LSQ_BRACKET :: Word16 +tB_KEY_CTRL_LSQ_BRACKET = 0x1B + +tB_KEY_CTRL_3 :: Word16 +tB_KEY_CTRL_3 = 0x1B + +tB_KEY_CTRL_4 :: Word16 +tB_KEY_CTRL_4 = 0x1C + +tB_KEY_CTRL_BACKSLASH :: Word16 +tB_KEY_CTRL_BACKSLASH = 0x1C + +tB_KEY_CTRL_5 :: Word16 +tB_KEY_CTRL_5 = 0x1D + +tB_KEY_CTRL_RSQ_BRACKET :: Word16 +tB_KEY_CTRL_RSQ_BRACKET = 0x1D + +tB_KEY_CTRL_6 :: Word16 +tB_KEY_CTRL_6 = 0x1E + +tB_KEY_CTRL_7 :: Word16 +tB_KEY_CTRL_7 = 0x1F + +tB_KEY_CTRL_SLASH :: Word16 +tB_KEY_CTRL_SLASH = 0x1F + +tB_KEY_CTRL_UNDERSCORE :: Word16 +tB_KEY_CTRL_UNDERSCORE = 0x1F + +tB_KEY_SPACE :: Word16 +tB_KEY_SPACE = 0x20 + +tB_KEY_BACKSPACE2 :: Word16 +tB_KEY_BACKSPACE2 = 0x7F + +tB_KEY_CTRL_8 :: Word16 +tB_KEY_CTRL_8 = 0x7F + +data TbEvent + = TbEvent !Word8 Word8 Word16 Word32 Int32 Int32 Int32 Int32 + +instance Storable TbEvent where + sizeOf :: TbEvent -> Int + sizeOf _ = + 24 + + alignment :: TbEvent -> Int + alignment _ = + 4 + + peek :: Ptr TbEvent -> IO TbEvent + peek ptr = + TbEvent + <$> peekByteOff ptr 0 + <*> peekByteOff ptr 1 + <*> peekByteOff ptr 2 + <*> peekByteOff ptr 4 + <*> peekByteOff ptr 8 + <*> peekByteOff ptr 12 + <*> peekByteOff ptr 16 + <*> peekByteOff ptr 20 + + poke :: Ptr TbEvent -> TbEvent -> IO () + poke ptr (TbEvent typ mod key ch w h x y) = do + pokeByteOff ptr 0 typ + pokeByteOff ptr 1 mod + pokeByteOff ptr 2 key + pokeByteOff ptr 4 ch + pokeByteOff ptr 8 w + pokeByteOff ptr 12 h + pokeByteOff ptr 16 x + pokeByteOff ptr 20 y + +foreign import ccall unsafe "tb_change_cell" + tb_change_cell :: Int -> Int -> Word32 -> Word16 -> Word16 -> IO () + +foreign import ccall unsafe "tb_clear" + tb_clear :: IO () + +foreign import ccall unsafe "tb_height" + tb_height :: IO Int + +foreign import ccall unsafe "tb_init" + tb_init :: IO Int + +foreign import ccall safe "tb_peek_event" + tb_peek_event :: Ptr TbEvent -> Int -> IO Int + +foreign import ccall safe "tb_poll_event" + tb_poll_event :: Ptr TbEvent -> IO Int + +foreign import ccall unsafe "tb_present" + tb_present :: IO () + +foreign import ccall unsafe "tb_select_input_mode" + tb_select_input_mode :: Int -> IO Int + +foreign import ccall unsafe "tb_select_output_mode" + tb_select_output_mode :: Int -> IO Int + +foreign import ccall unsafe "tb_set_clear_attributes" + tb_set_clear_attributes :: Word16 -> Word16 -> IO () + +foreign import ccall unsafe "tb_set_cursor" + tb_set_cursor :: Int -> Int -> IO () + +foreign import ccall unsafe "tb_shutdown" + tb_shutdown :: IO () + +foreign import ccall unsafe "tb_width" + tb_width :: IO Int + +-- foreign import ccall unsafe "tb_cell_buffer" +-- tb_cell_buffer :: IO (Ptr Cell) diff --git a/src/Termbox/Key.hs b/src/Termbox/Key.hs new file mode 100644 --- /dev/null +++ b/src/Termbox/Key.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Termbox.Key + ( Key (..), + parseKey, + pattern KeyCtrlH, + pattern KeyCtrlLsqBracket, + pattern KeyCtrl2, + pattern KeyCtrl3, + pattern KeyCtrl4, + pattern KeyCtrl5, + pattern KeyCtrl7, + pattern KeyCtrlM, + pattern KeyCtrlI, + pattern KeyCtrlUnderscore, + ) +where + +import Data.Word (Word16) +import Termbox.Internal + +-- | A key event. +data Key + = KeyChar Char + | KeyArrowDown + | KeyArrowLeft + | KeyArrowRight + | KeyArrowUp + | KeyBackspace + | -- | Also: @Ctrl+H@ + KeyCtrlBackspace + | KeyCtrl6 + | KeyCtrl8 + | KeyCtrlA + | KeyCtrlB + | -- | Also: @Ctrl-4@ + KeyCtrlBackslash + | KeyCtrlC + | KeyCtrlD + | KeyCtrlE + | KeyCtrlF + | KeyCtrlG + | KeyCtrlJ + | KeyCtrlK + | KeyCtrlL + | KeyCtrlN + | KeyCtrlO + | KeyCtrlP + | KeyCtrlQ + | KeyCtrlR + | -- | Also: @Ctrl-5@ + KeyCtrlRsqBracket + | KeyCtrlS + | -- | Also: @Ctrl-/@, @Ctrl-_@ + KeyCtrlSlash + | -- | Also: @Ctrl+2@ + KeyCtrlTilde + | KeyCtrlT + | KeyCtrlU + | KeyCtrlV + | KeyCtrlW + | KeyCtrlX + | KeyCtrlY + | KeyCtrlZ + | KeyDelete + | KeyEnd + | -- | Also: @Ctrl-M@ + KeyEnter + | -- | Also: @Ctrl-[@, @Ctrl-3@ + KeyEsc + | KeyF1 + | KeyF10 + | KeyF11 + | KeyF12 + | KeyF2 + | KeyF3 + | KeyF4 + | KeyF5 + | KeyF6 + | KeyF7 + | KeyF8 + | KeyF9 + | KeyHome + | KeyInsert + | KeyPageDn + | KeyPageUp + | KeySpace + | -- | Also: @Ctrl+I@ + KeyTab + deriving (Eq, Ord, Show) + +pattern KeyCtrlH :: Key +pattern KeyCtrlH = KeyCtrlBackspace + +pattern KeyCtrlLsqBracket :: Key +pattern KeyCtrlLsqBracket = KeyEsc + +pattern KeyCtrl2 :: Key +pattern KeyCtrl2 = KeyCtrlTilde + +pattern KeyCtrl3 :: Key +pattern KeyCtrl3 = KeyEsc + +pattern KeyCtrl4 :: Key +pattern KeyCtrl4 = KeyCtrlBackslash + +pattern KeyCtrl5 :: Key +pattern KeyCtrl5 = KeyCtrlRsqBracket + +pattern KeyCtrl7 :: Key +pattern KeyCtrl7 = KeyCtrlSlash + +pattern KeyCtrlM :: Key +pattern KeyCtrlM = KeyEnter + +pattern KeyCtrlI :: Key +pattern KeyCtrlI = KeyTab + +pattern KeyCtrlUnderscore :: Key +pattern KeyCtrlUnderscore = KeyCtrlSlash + +parseKey :: Word16 -> Key +parseKey key + | key == tB_KEY_ARROW_DOWN = KeyArrowDown + | key == tB_KEY_ARROW_LEFT = KeyArrowLeft + | key == tB_KEY_ARROW_RIGHT = KeyArrowRight + | key == tB_KEY_ARROW_UP = KeyArrowUp + | key == tB_KEY_BACKSPACE = KeyBackspace + | key == tB_KEY_CTRL_TILDE = KeyCtrlTilde + | key == tB_KEY_CTRL_6 = KeyCtrl6 + | key == tB_KEY_CTRL_8 = KeyCtrl8 + | key == tB_KEY_CTRL_A = KeyCtrlA + | key == tB_KEY_CTRL_B = KeyCtrlB + | key == tB_KEY_CTRL_BACKSLASH = KeyCtrlBackslash + | key == tB_KEY_CTRL_C = KeyCtrlC + | key == tB_KEY_CTRL_D = KeyCtrlD + | key == tB_KEY_CTRL_E = KeyCtrlE + | key == tB_KEY_CTRL_F = KeyCtrlF + | key == tB_KEY_CTRL_G = KeyCtrlG + | key == tB_KEY_CTRL_H = KeyCtrlBackspace + | key == tB_KEY_CTRL_J = KeyCtrlJ + | key == tB_KEY_CTRL_K = KeyCtrlK + | key == tB_KEY_CTRL_L = KeyCtrlL + | key == tB_KEY_CTRL_N = KeyCtrlN + | key == tB_KEY_CTRL_O = KeyCtrlO + | key == tB_KEY_CTRL_P = KeyCtrlP + | key == tB_KEY_CTRL_Q = KeyCtrlQ + | key == tB_KEY_CTRL_R = KeyCtrlR + | key == tB_KEY_CTRL_RSQ_BRACKET = KeyCtrlRsqBracket + | key == tB_KEY_CTRL_S = KeyCtrlS + | key == tB_KEY_CTRL_SLASH = KeyCtrlSlash + | key == tB_KEY_CTRL_T = KeyCtrlT + | key == tB_KEY_CTRL_U = KeyCtrlU + | key == tB_KEY_CTRL_V = KeyCtrlV + | key == tB_KEY_CTRL_W = KeyCtrlW + | key == tB_KEY_CTRL_X = KeyCtrlX + | key == tB_KEY_CTRL_Y = KeyCtrlY + | key == tB_KEY_CTRL_Z = KeyCtrlZ + | key == tB_KEY_DELETE = KeyDelete + | key == tB_KEY_END = KeyEnd + | key == tB_KEY_ENTER = KeyEnter + | key == tB_KEY_ESC = KeyEsc + | key == tB_KEY_F1 = KeyF1 + | key == tB_KEY_F10 = KeyF10 + | key == tB_KEY_F11 = KeyF11 + | key == tB_KEY_F12 = KeyF12 + | key == tB_KEY_F2 = KeyF2 + | key == tB_KEY_F3 = KeyF3 + | key == tB_KEY_F4 = KeyF4 + | key == tB_KEY_F5 = KeyF5 + | key == tB_KEY_F6 = KeyF6 + | key == tB_KEY_F7 = KeyF7 + | key == tB_KEY_F8 = KeyF8 + | key == tB_KEY_F9 = KeyF9 + | key == tB_KEY_HOME = KeyHome + | key == tB_KEY_INSERT = KeyInsert + | key == tB_KEY_PGDN = KeyPageDn + | key == tB_KEY_PGUP = KeyPageUp + | key == tB_KEY_SPACE = KeySpace + | key == tB_KEY_TAB = KeyTab + | otherwise = error ("termbox: unknown key " ++ show key) diff --git a/src/Termbox/Mouse.hs b/src/Termbox/Mouse.hs new file mode 100644 --- /dev/null +++ b/src/Termbox/Mouse.hs @@ -0,0 +1,28 @@ +module Termbox.Mouse + ( Mouse (..), + parseMouse, + ) +where + +import Data.Word (Word16) +import Termbox.Internal + +-- | A mouse event. +data Mouse + = MouseLeft + | MouseMiddle + | MouseRelease + | MouseRight + | MouseWheelDown + | MouseWheelUp + deriving (Eq, Ord, Show) + +parseMouse :: Word16 -> Mouse +parseMouse key + | key == tB_KEY_MOUSE_LEFT = MouseLeft + | key == tB_KEY_MOUSE_MIDDLE = MouseMiddle + | key == tB_KEY_MOUSE_RELEASE = MouseRelease + | key == tB_KEY_MOUSE_RIGHT = MouseRight + | key == tB_KEY_MOUSE_WHEEL_DOWN = MouseWheelDown + | key == tB_KEY_MOUSE_WHEEL_UP = MouseWheelUp + | otherwise = error ("termbox: unknown mouse " ++ show key) diff --git a/termbox.cabal b/termbox.cabal --- a/termbox.cabal +++ b/termbox.cabal @@ -1,11 +1,11 @@ cabal-version: 2.4 name: termbox -version: 0.2.0.1 +version: 0.3.0 category: User Interfaces description: This package provides a thin wrapper around @termbox v1.1.2@, a simple C - library for writing text-based user interfaces: + library for writing text-based user interfaces: . The full source of @termbox v1.1.2@ (1000 lines of C) is bundled; you do not need to install any system packages to use this library. @@ -33,19 +33,12 @@ default: False manual: True -library - build-depends: - array, - base ^>= 4.9 || ^>= 4.10 || ^>= 4.11 || ^>= 4.12 || ^>= 4.13 || ^>= 4.14 - build-tool-depends: - c2hs:c2hs - c-sources: - cbits/termbox.c - cbits/utf8.c - default-language: - Haskell2010 - exposed-modules: - Termbox +common component + default-extensions: + GeneralizedNewtypeDeriving + InstanceSigs + LambdaCase + default-language: Haskell2010 ghc-options: -Weverything -Wno-implicit-prelude @@ -58,26 +51,35 @@ ghc-options: -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module - hs-source-dirs: - src - include-dirs: - include - other-modules: + +library + import: component + build-depends: base ^>= 4.10 || ^>= 4.11 || ^>= 4.12 || ^>= 4.13 || ^>= 4.14 + c-sources: + cbits/termbox.c + cbits/utf8.c + exposed-modules: + Termbox Termbox.Internal + hs-source-dirs: src + include-dirs: include + other-modules: + Termbox.Attr + Termbox.Cell + Termbox.Cells + Termbox.Event + Termbox.Key + Termbox.Mouse executable termbox-example-colors + import: component if !flag(build-examples) buildable: False build-depends: base, termbox, - default-language: - Haskell2010 ghc-options: -rtsopts -threaded - -Wall - hs-source-dirs: - examples - main-is: - Colors.hs + hs-source-dirs: examples + main-is: Colors.hs