diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,61 @@ +# HLint configuration file +# https://github.com/ndmitchell/hlint +########################## + +# This file contains a template configuration file, which is typically +# placed as .hlint.yaml in the root of your project + + +# Specify additional command line arguments +# +# - arguments: [--color, --cpp-simple, -XQuasiQuotes] + + +# Control which extensions/flags/modules/functions can be used +# +# - extensions: +# - default: false # all extension are banned by default +# - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used +# - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module +# +# - flags: +# - {name: -w, within: []} # -w is allowed nowhere +# +# - modules: +# - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' +# - {name: Control.Arrow, within: []} # Certain modules are banned entirely +# +# - functions: +# - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules + + +# Add custom hints for this project +# +# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" +# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} + + +# Turn on hints that are off by default +# +# Ban "module X(module X) where", to require a real export list +# - warn: {name: Use explicit module export list} +# +# Replace a $ b $ c with a . b $ c +# - group: {name: dollar, enabled: true} +# +# Generalise map to fmap, ++ to <> +# - group: {name: generalise, enabled: true} + + +# Ignore some builtin hints +# - ignore: {name: Use let} +# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules +- ignore: {name: Use String} + + +# Define some custom infix operators +# - fixity: infixr 3 ~^#^~ + + +# To generate a suitable file for HLint do: +# $ hlint --default > .hlint.yaml diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -1,94 +1,141 @@ # This Travis job script has been generated by a script via # -# runghc make_travis_yml_2.hs 'cabal.project' +# haskell-ci 'termbox.cabal' # -# For more information, see https://github.com/hvr/multi-ghc-travis +# For more information, see https://github.com/haskell-CI/haskell-ci # +# version: 0.3.20190521 +# language: c -sudo: false - +dist: xenial git: - submodules: false # whether to recursively clone submodules - + # whether to recursively clone submodules + submodules: false cache: directories: - $HOME/.cabal/packages - $HOME/.cabal/store - before_cache: - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log + - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log # remove files that are regenerated by 'cabal update' - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx - - - rm -rfv $HOME/.cabal/packages/head.hackage - + - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* + - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json + - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache + - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar + - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx + - rm -rfv $CABALHOME/packages/head.hackage matrix: include: - - compiler: "ghc-8.0.2" - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}} - - compiler: "ghc-8.2.2" - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.2], sources: [hvr-ghc]}} - - compiler: "ghc-8.4.3" - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.4.3], sources: [hvr-ghc]}} - + - compiler: ghc-8.6.5 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-2.4"]}} + - compiler: ghc-8.4.4 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-2.4"]}} + - compiler: ghc-8.2.2 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-2.4"]}} + - compiler: ghc-8.0.2 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-2.4"]}} before_install: - - HC=${CC} - - HCPKG=${HC/ghc/ghc-pkg} + - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') + - HCPKG="$HC-pkg" - unset CC - - ROOTDIR=$(pwd) - - mkdir -p $HOME/.local/bin - - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH" + - CABAL=/opt/ghc/bin/cabal + - CABALHOME=$HOME/.cabal + - export PATH="$CABALHOME/bin:$PATH" + - TOP=$(pwd) - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) - echo $HCNUMVER - + - CABAL="$CABAL -vnormal+nowrap+markoutput" + - set -o pipefail + - | + echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk + echo 'BEGIN { state = "output"; }' >> .colorful.awk + echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk + echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk + echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk + echo ' if (state == "cabal") {' >> .colorful.awk + echo ' print blue($0)' >> .colorful.awk + echo ' } else {' >> .colorful.awk + echo ' print $0' >> .colorful.awk + echo ' }' >> .colorful.awk + echo '}' >> .colorful.awk + - cat .colorful.awk + - | + color_cabal_output () { + awk -f $TOP/.colorful.awk + } + - echo text | color_cabal_output install: - - cabal --version + - ${CABAL} --version - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - - BENCH=${BENCH---enable-benchmarks} - - TEST=${TEST---enable-tests} - - HADDOCK=${HADDOCK-true} - - INSTALLED=${INSTALLED-true} + - TEST=--enable-tests + - BENCH=--enable-benchmarks - GHCHEAD=${GHCHEAD-false} - - travis_retry cabal update -v - - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config" - - rm -fv cabal.project cabal.project.local - - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' - - "printf 'packages: \".\"\\n' > cabal.project" - - cat cabal.project - - if [ -f "./configure.ac" ]; then - (cd "." && autoreconf -i); - fi - - rm -f cabal.project.freeze - - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 - - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 - - rm -rf .ghc.environment.* "."/dist - - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) - -# Here starts the actual work to be performed for the package under test; -# any command which exits with a non-zero exit code causes the build to fail. + - rm -f $CABALHOME/config + - | + echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config + echo "remote-build-reporting: anonymous" >> $CABALHOME/config + echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config + echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config + echo "world-file: $CABALHOME/world" >> $CABALHOME/config + echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config + echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config + echo "installdir: $CABALHOME/bin" >> $CABALHOME/config + echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config + echo "store-dir: $CABALHOME/store" >> $CABALHOME/config + echo "install-dirs user" >> $CABALHOME/config + echo " prefix: $CABALHOME" >> $CABALHOME/config + echo "repository hackage.haskell.org" >> $CABALHOME/config + echo " url: http://hackage.haskell.org/" >> $CABALHOME/config + - cat $CABALHOME/config + - rm -fv cabal.project cabal.project.local cabal.project.freeze + - travis_retry ${CABAL} v2-update -v + # Generate cabal.project + - rm -rf cabal.project cabal.project.local cabal.project.freeze + - touch cabal.project + - | + echo 'packages: "."' >> cabal.project + - | + echo "write-ghc-environment-files: always" >> cabal.project + - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(termbox)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" + - cat cabal.project || true + - cat cabal.project.local || true + - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi + - ${CABAL} v2-freeze -w ${HC} ${TEST} ${BENCH} | color_cabal_output + - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" + - rm cabal.project.freeze + - ${CABAL} v2-build -w ${HC} ${TEST} ${BENCH} --dep -j2 all | color_cabal_output + - ${CABAL} v2-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output script: - # test that source-distributions can be generated - - (cd "." && cabal sdist) - - mv "."/dist/termbox-*.tar.gz ${DISTDIR}/ + - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) + # Packaging... + - ${CABAL} v2-sdist all | color_cabal_output + # Unpacking... + - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ - cd ${DISTDIR} || false - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; - - "printf 'packages: termbox-*/*.cabal\\n' > cabal.project" - - cat cabal.project + # Generate cabal.project + - rm -rf cabal.project cabal.project.local cabal.project.freeze + - touch cabal.project + - | + echo 'packages: "termbox-*/*.cabal"' >> cabal.project + - | + echo "write-ghc-environment-files: always" >> cabal.project + - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(termbox)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" + - cat cabal.project || true + - cat cabal.project.local || true + # Building... # this builds all libraries and executables (without tests/benchmarks) - - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all - - # Build with installed constraints for packages in global-db - - if $INSTALLED; then echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks $(${HCPKG} list --global --simple-output --names-only | sed 's/\([a-zA-Z0-9-]\{1,\}\) */--constraint="\1 installed" /g') all | sh; else echo "Not building with installed constraints"; fi - + - ${CABAL} v2-build -w ${HC} --disable-tests --disable-benchmarks all | color_cabal_output + # Building with tests and benchmarks... # build & run tests, build benchmarks - - cabal new-build -w ${HC} ${TEST} ${BENCH} all - - # cabal check - - (cd termbox-* && cabal check) + - ${CABAL} v2-build -w ${HC} ${TEST} ${BENCH} all | color_cabal_output + # cabal check... + - (cd termbox-* && ${CABAL} -vnormal check) + # haddock... + - ${CABAL} v2-haddock -w ${HC} ${TEST} ${BENCH} all | color_cabal_output + # Building without installed constraints for packages in global-db... + - rm -f cabal.project.local + - ${CABAL} v2-build -w ${HC} --disable-tests --disable-benchmarks all | color_cabal_output -# REGENDATA ["cabal.project"] +# REGENDATA ["termbox.cabal"] # EOF diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,21 @@ 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.2.0] - 2019-06-21 + +### Added +- `getCells` function +- `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. + +### Removed +- `buffer` function + ## [0.1.0] - 2018-07-18 ### Added diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +# `termbox` + +[![Build Status](https://travis-ci.org/mitchellwrosen/termbox.svg?branch=master)](https://travis-ci.org/mitchellwrosen/termbox) +![Hackage](https://img.shields.io/hackage/v/termbox.svg) diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/examples/Colors.hs b/examples/Colors.hs --- a/examples/Colors.hs +++ b/examples/Colors.hs @@ -1,17 +1,13 @@ -- | Something like https://github.com/nsf/termbox/blob/8b72969ff4bba120d8b8e4a29bae07102ed71055/src/demo/output.c -{-# language LambdaCase #-} - import Control.Monad import Data.Foldable import qualified Termbox as Tb -main :: IO () -main = do - Tb.main $ do - clear - +main :: IO (Either Tb.InitError ()) +main = + Tb.run $ do do let rectangles :: [(Int, Int, Int, Int)] @@ -85,22 +81,40 @@ Tb.flush _ <- Tb.poll + clear + Tb.setOutputMode Tb.OutputMode256 + + do + let + rectangles :: [(Int, Int, Int, Int)] + rectangles = do + 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] + + Tb.flush + _ <- Tb.poll + pure () clear :: IO () clear = do - mode <- Tb.getOutputMode Tb.setOutputMode Tb.OutputModeNormal Tb.clear mempty mempty Tb.flush - Tb.setOutputMode mode string :: Int -> Int -> Tb.Attr -> Tb.Attr -> [Char] -> IO () -string x0 y fg bg cs = +string x0 y fg bg = zipWithM_ (\x c -> Tb.set x y (Tb.Cell c fg bg)) [x0..] - cs rectangle :: Int -> Int -> Int -> Int -> Tb.Cell -> IO () rectangle x0 y0 x1 y1 c = diff --git a/src/Termbox.hs b/src/Termbox.hs --- a/src/Termbox.hs +++ b/src/Termbox.hs @@ -1,36 +1,79 @@ {-# language InstanceSigs #-} {-# language LambdaCase #-} {-# language RankNTypes #-} -{-# language RecordWildCards #-} + {-# language ScopedTypeVariables #-} {-# language TypeFamilies #-} {-# language UnicodeSyntax #-} +-- | +-- 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. +-- +-- For example, this progam simply displays the number of keys pressed, and +-- quits on @Esc@: +-- +-- @ +-- {-\# LANGUAGE LambdaCase \#-} +-- +-- import Data.Foldable (for_) +-- import qualified Termbox +-- +-- main :: IO () +-- main = +-- Termbox.'run_' (loop 0) +-- +-- loop :: Int -> IO () +-- loop n = do +-- Termbox.'clear' mempty mempty +-- render n +-- Termbox.'flush' +-- +-- Termbox.'poll' >>= \\case +-- Termbox.'EventKey' Termbox.'KeyEsc' _ -> +-- pure () +-- _ -> +-- loop (n+1) +-- +-- render :: Int -> IO () +-- render n = +-- for_ +-- (zip [0..] (show n)) +-- (\\(i, c) -> +-- Termbox.'set' i 0 (Termbox.'Cell' c mempty mempty)) +-- @ +-- +-- Other termbox features include cell attributes (style, color), cursor +-- display, and mouse click handling. +-- +-- This module is intended to be imported qualified. module Termbox - ( -- $intro - - -- * Initialization - main + ( -- * Initialization + run + , run_ , InitError(..) -- * Terminal contents - , Cell(..) , set - , buffer + , getCells , clear , flush + , Cell(..) -- * Terminal size - , size + , getSize -- * Cursor manipulation , setCursor , hideCursor -- * Event handling + , poll , Event(..) , Key(..) , Mouse(..) - , poll , PollError(..) -- * Attributes - , Attr , black , red , green @@ -42,14 +85,15 @@ , bold , underline , reverse + , Attr -- * Terminal modes - , InputMode(..) - , MouseMode(..) , getInputMode , setInputMode - , OutputMode(..) + , InputMode(..) + , MouseMode(..) , getOutputMode , setOutputMode + , OutputMode(..) ) where import Prelude hiding (mod, reverse) @@ -57,8 +101,8 @@ import qualified Termbox.Internal as Tb import Control.Exception -import Control.Monad (join) -import Data.Array.Storable +import Control.Monad ((>=>), join) +import Data.Array (Array) import Data.Bits ((.|.), (.&.)) import Data.Functor (void) import Data.Semigroup (Semigroup(..)) @@ -66,21 +110,16 @@ import Foreign (ForeignPtr, Ptr, newForeignPtr_) import Foreign.Marshal.Alloc (alloca) import Foreign.Storable +import GHC.Stack +import qualified Data.Array.Storable as Array (freeze) import qualified Data.Array.Storable.Internals as Array --- $intro --- This module is intended to be imported qualified. --- --- @ --- import qualified Termbox --- @ - -------------------------------------------------------------------------------- -- Initialization -------------------------------------------------------------------------------- --- | Initialization errors that can be thrown by 'main'. +-- | Termbox initialization errors that can be returned by 'run'. data InitError = FailedToOpenTTY | PipeTrapError @@ -89,33 +128,42 @@ instance Exception InitError --- | Run a @termbox@ program and restore the terminal state afterwards. May --- throw an 'InitError' exception. -main :: IO a -> IO a -main = - bracket_ - (Tb.init >>= \case - Tb.InitOk -> pure () - Tb.FailedToOpenTTY -> throwIO FailedToOpenTTY - Tb.PipeTrapError -> throwIO PipeTrapError - Tb.UnsupportedTerminal -> throwIO UnsupportedTerminal) - Tb.shutdown +-- | 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 width and height. -size :: (width ~ Int, height ~ Int) => IO (width, height) -size = +-- | Get the terminal size (width, then height). +getSize :: IO (Int, Int) +getSize = (,) <$> Tb.width <*> Tb.height + -------------------------------------------------------------------------------- -- Cursor -------------------------------------------------------------------------------- --- | Set the cursor coordinates. -setCursor :: (col ~ Int, row ~ Int) => col -> row -> IO () +-- | Set the cursor coordinates (column, then row). +setCursor :: Int -> Int -> IO () setCursor = Tb.setCursor @@ -124,6 +172,7 @@ hideCursor = Tb.setCursor Tb._HIDE_CURSOR Tb._HIDE_CURSOR + -------------------------------------------------------------------------------- -- Terminal contents -------------------------------------------------------------------------------- @@ -161,34 +210,32 @@ Tb.setCellFg ptr (attrToWord fg) Tb.setCellBg ptr (attrToWord bg) --- | Set the 'Cell' at the given coordinates. -set :: (col ~ Int, row ~ Int) => col -> row -> Cell -> IO () +-- | 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 internal back buffer as a two-dimensional array of --- 'Cell's indexed by their coordinates. --- --- /Warning/: the data is only valid until the next call to 'clear' or --- 'flush'. -buffer :: (row ~ Int, col ~ Int) => IO (StorableArray (row, col) Cell) -buffer = +-- | 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 (StorableArray (Int, Int) Cell) - mkbuffer buff w h = - Array.unsafeForeignPtrToStorableArray buff ((0, 0), (h-1, w-1)) + 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 :: (fg ~ Attr, bg ~ Attr) => fg -> bg -> IO () +clear :: Attr -> Attr -> IO () clear fg bg = do Tb.setClearAttributes (attrToWord fg) (attrToWord bg) Tb.clear @@ -225,29 +272,29 @@ deriving (Eq, Ord, Show) -- | Get the current input mode. -getInputMode :: IO InputMode +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 ("getInputMode: " ++ show n) + 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 + 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. -- @@ -267,29 +314,29 @@ deriving (Eq, Ord, Show) -- | Get the current output mode. -getOutputMode :: IO OutputMode +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 "getOutputMode: 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 + where + f :: OutputMode -> Tb.OutputMode + f = \case + OutputModeNormal -> Tb.OutputModeNormal + OutputMode256 -> Tb.OutputMode256 + OutputMode216 -> Tb.OutputMode216 + OutputModeGrayscale -> Tb.OutputModeGrayscale -------------------------------------------------------------------------------- -- Event handling @@ -394,8 +441,7 @@ -- @threaded@ runtime, or simply writing event-handling code that is responsive -- to intuitive "quit" keys like @q@ and @Esc@. -- --- This function may throw a 'PollError' exception under mysterious --- circumstances that are not well-documented in the original C codebase. +-- /Throws/: 'PollError' poll :: IO Event poll = alloca $ \ptr -> @@ -405,7 +451,8 @@ _ -> parseEvent <$> peek ptr --- | An error occurred when 'poll'ing. +-- | 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 @@ -426,21 +473,21 @@ 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 + where + key' :: Key + key' = + case ch of + '\0' -> parseKey key + _ -> KeyChar ch - alt :: Bool - alt = - case mod of - Tb.ModAlt -> True - _ -> False + alt :: Bool + alt = + case mod of + Tb.ModAlt -> True + _ -> False -- | Parse a 'Key' from a 'Tb.Key'. -parseKey :: Tb.Key -> Key +parseKey :: HasCallStack => Tb.Key -> Key parseKey = \case Tb.KeyArrowDown -> KeyArrowDown Tb.KeyArrowLeft -> KeyArrowLeft @@ -509,10 +556,10 @@ Tb.KeyPageUp -> KeyPageUp Tb.KeySpace -> KeySpace Tb.KeyTab -> KeyTab - key -> error ("parseKey: " ++ show key) + key -> error (show key) -- | Parse a 'Mouse' from a 'Tb.Key'. -parseMouse :: Tb.Key -> Mouse +parseMouse :: HasCallStack => Tb.Key -> Mouse parseMouse = \case Tb.KeyMouseLeft -> MouseLeft Tb.KeyMouseMiddle -> MouseMiddle @@ -520,7 +567,7 @@ Tb.KeyMouseRight -> MouseRight Tb.KeyMouseWheelDown -> MouseWheelDown Tb.KeyMouseWheelUp -> MouseWheelUp - key -> error ("parseMouse: " ++ show key) + key -> error (show key) -------------------------------------------------------------------------------- -- Attributes @@ -530,15 +577,8 @@ -- 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 left --- bias. That is, --- --- @ --- red <> bold <> black <> underline = red <> bold <> underline --- @ --- --- /Warning/: the 'Num' instance is /very partial/! It only includes an --- implementation of 'fromInteger', for numeric literals. +-- underlined. The 'Monoid' instance combines 'Attr's this way, with a right +-- bias. data Attr = Attr !Word16 {- color -} !Word16 {- attr -} deriving (Eq) @@ -552,27 +592,24 @@ mappend = (<>) --- | Only 'fromInteger' is defined. +-- | Provided for numeric literals. instance Num Attr where fromInteger :: Integer -> Attr - fromInteger n - | n >= 0 && n < 256 = - Attr (fromIntegral n) 0 - | otherwise = - error ("Attr.fromInteger: " ++ show n ++ " out of range [0..255]") + fromInteger n = + Attr (fromIntegral (n `rem` 256)) 0 - (+) = error ("Attr.(+): not defined") - (*) = error ("Attr.(*): not defined") - (-) = error ("Attr.(-): not defined") - abs = error ("Attr.abs: not defined") - signum = error ("Attr.signum: not defined") + (+) = (<>) + (*) = (<>) + (-) = (<>) + 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 cx ax <> Attr _ ay = Attr cx (ax .|. ay) + Attr _ ax <> Attr cy ay = Attr cy (ax .|. ay) wordToAttr :: Word16 -> Attr wordToAttr w = diff --git a/termbox.cabal b/termbox.cabal --- a/termbox.cabal +++ b/termbox.cabal @@ -1,7 +1,7 @@ -cabal-version: 2.0 +cabal-version: 2.4 name: termbox -version: 0.1.0 +version: 0.2.0 category: User Interfaces description: This package provides a thin wrapper around @termbox v1.1.2@, a simple C @@ -14,22 +14,32 @@ maintainer: Mitchell Rosen homepage: https://github.com/mitchellwrosen/termbox bug-reports: https://github.com/mitchellwrosen/termbox/issues -copyright: (c) 2018, Mitchell Rosen -license: BSD3 +copyright: (c) 2018-2019, Mitchell Rosen +license: BSD-3-Clause license-file: LICENSE build-type: Simple -tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3 +tested-with: + GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 extra-source-files: + .hlint.yaml .travis.yml cbits/LICENSE CHANGELOG.md include/termbox.h + README.md +source-repository head + type: git + location: git://github.com/mitchellwrosen/termbox.git + library build-depends: array - , base ^>= 4.9 || ^>= 4.10 || ^>= 4.11 + , base ^>= 4.9 || ^>= 4.10 || ^>= 4.11 || ^>= 4.12 build-tool-depends: c2hs:c2hs c-sources: