diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,25 +1,27 @@ -# Changelog - -All notable changes to this project will be documented in this file. - -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/). +## [1.0.0] - Unreleased +- Rework `run`; add `Program` record of callbacks +- Add user events to `Event` type +- Overhaul `Attr`+`Cell`+`Cells`+`Cursor` API; now it's `Cell`+`Color`+`Scene` +- Rename `set` to `cell` +- Add combinator to brighten basic colors (`bright`) +- Add combinator for miscellaneous colors (`color`) +- Add combinator for monochrome colors (`gray`) +- Add `Pos` type +- Add `Size` type +- Remove `Termbox.Internal` module (see packages `termbox-bindings-hs` or `termbox-bindings-c` instead) +- Fix off-by-one error in named colors (black, etc) (thanks @seagreen) +- Support GHC 9.4 +- Drop support for GHC < 8.8 ## [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 @@ -27,26 +29,16 @@ - Remove support for GHC < 8.2 ## [0.2.0.1] - 2020-06-27 - -### Changed - Bump `base` upper bound ## [0.2.0] - 2019-06-21 - -### Added - Add `getCells` function - Add `run` function - -### Changed - 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 -- Add `buffer` function +- Remove `buffer` function ## [0.1.0] - 2018-07-18 - -### Added - Initial release diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright 2018 Mitchell Rosen +Copyright 2018-2022 Mitchell Rosen Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -1,7 +0,0 @@ -# `termbox` - -[![GitHub CI](https://github.com/mitchellwrosen/termbox/workflows/CI/badge.svg)](https://github.com/mitchellwrosen/termbox/actions) -[![Hackage](https://img.shields.io/hackage/v/termbox.svg)](https://hackage.haskell.org/package/termbox) -[![Stackage LTS](https://stackage.org/package/termbox/badge/lts)](https://www.stackage.org/lts/package/termbox) -[![Stackage Nightly](https://stackage.org/package/termbox/badge/nightly)](https://www.stackage.org/nightly/package/termbox) -[![Dependencies](https://img.shields.io/hackage-deps/v/termbox)](https://packdeps.haskellers.com/reverse/termbox) diff --git a/cbits/LICENSE b/cbits/LICENSE deleted file mode 100644 --- a/cbits/LICENSE +++ /dev/null @@ -1,19 +0,0 @@ -Copyright (C) 2010-2013 nsf - -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in -all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN -THE SOFTWARE. diff --git a/cbits/termbox.c b/cbits/termbox.c deleted file mode 100644 --- a/cbits/termbox.c +++ /dev/null @@ -1,1284 +0,0 @@ -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#include "termbox.h" - -struct bytebuffer { - char *buf; - int len; - int cap; -}; - -static void bytebuffer_reserve(struct bytebuffer *b, int cap) { - if (b->cap >= cap) { - return; - } - - // prefer doubling capacity - if (b->cap * 2 >= cap) { - cap = b->cap * 2; - } - - char *newbuf = realloc(b->buf, cap); - b->buf = newbuf; - b->cap = cap; -} - -static void bytebuffer_init(struct bytebuffer *b, int cap) { - b->cap = 0; - b->len = 0; - b->buf = 0; - - if (cap > 0) { - b->cap = cap; - b->buf = malloc(cap); // just assume malloc works always - } -} - -static void bytebuffer_free(struct bytebuffer *b) { - if (b->buf) - free(b->buf); -} - -static void bytebuffer_clear(struct bytebuffer *b) { - b->len = 0; -} - -static void bytebuffer_append(struct bytebuffer *b, const char *data, int len) { - bytebuffer_reserve(b, b->len + len); - memcpy(b->buf + b->len, data, len); - b->len += len; -} - -static void bytebuffer_puts(struct bytebuffer *b, const char *str) { - bytebuffer_append(b, str, strlen(str)); -} - -static void bytebuffer_resize(struct bytebuffer *b, int len) { - bytebuffer_reserve(b, len); - b->len = len; -} - -static void bytebuffer_flush(struct bytebuffer *b, int fd) { - write(fd, b->buf, b->len); - bytebuffer_clear(b); -} - -static void bytebuffer_truncate(struct bytebuffer *b, int n) { - if (n <= 0) - return; - if (n > b->len) - n = b->len; - const int nmove = b->len - n; - memmove(b->buf, b->buf+n, nmove); - b->len -= n; -} - -enum { - T_ENTER_CA, - T_EXIT_CA, - T_SHOW_CURSOR, - T_HIDE_CURSOR, - T_CLEAR_SCREEN, - T_SGR0, - T_UNDERLINE, - T_BOLD, - T_BLINK, - T_REVERSE, - T_ENTER_KEYPAD, - T_EXIT_KEYPAD, - T_ENTER_MOUSE, - T_EXIT_MOUSE, - T_FUNCS_NUM, -}; - -#define ENTER_MOUSE_SEQ "\x1b[?1000h\x1b[?1002h\x1b[?1015h\x1b[?1006h" -#define EXIT_MOUSE_SEQ "\x1b[?1006l\x1b[?1015l\x1b[?1002l\x1b[?1000l" - -#define EUNSUPPORTED_TERM -1 - -// rxvt-256color -static const char *rxvt_256color_keys[] = { - "\033[11~","\033[12~","\033[13~","\033[14~","\033[15~","\033[17~","\033[18~","\033[19~","\033[20~","\033[21~","\033[23~","\033[24~","\033[2~","\033[3~","\033[7~","\033[8~","\033[5~","\033[6~","\033[A","\033[B","\033[D","\033[C", 0 -}; -static const char *rxvt_256color_funcs[] = { - "\0337\033[?47h", "\033[2J\033[?47l\0338", "\033[?25h", "\033[?25l", "\033[H\033[2J", "\033[m", "\033[4m", "\033[1m", "\033[5m", "\033[7m", "\033=", "\033>", ENTER_MOUSE_SEQ, EXIT_MOUSE_SEQ, -}; - -// Eterm -static const char *eterm_keys[] = { - "\033[11~","\033[12~","\033[13~","\033[14~","\033[15~","\033[17~","\033[18~","\033[19~","\033[20~","\033[21~","\033[23~","\033[24~","\033[2~","\033[3~","\033[7~","\033[8~","\033[5~","\033[6~","\033[A","\033[B","\033[D","\033[C", 0 -}; -static const char *eterm_funcs[] = { - "\0337\033[?47h", "\033[2J\033[?47l\0338", "\033[?25h", "\033[?25l", "\033[H\033[2J", "\033[m", "\033[4m", "\033[1m", "\033[5m", "\033[7m", "", "", "", "", -}; - -// screen -static const char *screen_keys[] = { - "\033OP","\033OQ","\033OR","\033OS","\033[15~","\033[17~","\033[18~","\033[19~","\033[20~","\033[21~","\033[23~","\033[24~","\033[2~","\033[3~","\033[1~","\033[4~","\033[5~","\033[6~","\033OA","\033OB","\033OD","\033OC", 0 -}; -static const char *screen_funcs[] = { - "\033[?1049h", "\033[?1049l", "\033[34h\033[?25h", "\033[?25l", "\033[H\033[J", "\033[m", "\033[4m", "\033[1m", "\033[5m", "\033[7m", "\033[?1h\033=", "\033[?1l\033>", ENTER_MOUSE_SEQ, EXIT_MOUSE_SEQ, -}; - -// rxvt-unicode -static const char *rxvt_unicode_keys[] = { - "\033[11~","\033[12~","\033[13~","\033[14~","\033[15~","\033[17~","\033[18~","\033[19~","\033[20~","\033[21~","\033[23~","\033[24~","\033[2~","\033[3~","\033[7~","\033[8~","\033[5~","\033[6~","\033[A","\033[B","\033[D","\033[C", 0 -}; -static const char *rxvt_unicode_funcs[] = { - "\033[?1049h", "\033[r\033[?1049l", "\033[?25h", "\033[?25l", "\033[H\033[2J", "\033[m\033(B", "\033[4m", "\033[1m", "\033[5m", "\033[7m", "\033=", "\033>", ENTER_MOUSE_SEQ, EXIT_MOUSE_SEQ, -}; - -// linux -static const char *linux_keys[] = { - "\033[[A","\033[[B","\033[[C","\033[[D","\033[[E","\033[17~","\033[18~","\033[19~","\033[20~","\033[21~","\033[23~","\033[24~","\033[2~","\033[3~","\033[1~","\033[4~","\033[5~","\033[6~","\033[A","\033[B","\033[D","\033[C", 0 -}; -static const char *linux_funcs[] = { - "", "", "\033[?25h\033[?0c", "\033[?25l\033[?1c", "\033[H\033[J", "\033[0;10m", "\033[4m", "\033[1m", "\033[5m", "\033[7m", "", "", "", "", -}; - -// xterm -static const char *xterm_keys[] = { - "\033OP","\033OQ","\033OR","\033OS","\033[15~","\033[17~","\033[18~","\033[19~","\033[20~","\033[21~","\033[23~","\033[24~","\033[2~","\033[3~","\033OH","\033OF","\033[5~","\033[6~","\033OA","\033OB","\033OD","\033OC", 0 -}; -static const char *xterm_funcs[] = { - "\033[?1049h", "\033[?1049l", "\033[?12l\033[?25h", "\033[?25l", "\033[H\033[2J", "\033(B\033[m", "\033[4m", "\033[1m", "\033[5m", "\033[7m", "\033[?1h\033=", "\033[?1l\033>", ENTER_MOUSE_SEQ, EXIT_MOUSE_SEQ, -}; - -static struct term { - const char *name; - const char **keys; - const char **funcs; -} terms[] = { - {"rxvt-256color", rxvt_256color_keys, rxvt_256color_funcs}, - {"Eterm", eterm_keys, eterm_funcs}, - {"screen", screen_keys, screen_funcs}, - {"rxvt-unicode", rxvt_unicode_keys, rxvt_unicode_funcs}, - {"linux", linux_keys, linux_funcs}, - {"xterm", xterm_keys, xterm_funcs}, - {0, 0, 0}, -}; - -static bool init_from_terminfo = false; -static const char **keys; -static const char **funcs; - -static int try_compatible(const char *term, const char *name, - const char **tkeys, const char **tfuncs) -{ - if (strstr(term, name)) { - keys = tkeys; - funcs = tfuncs; - return 0; - } - - return EUNSUPPORTED_TERM; -} - -static int init_term_builtin(void) -{ - int i; - const char *term = getenv("TERM"); - - if (term) { - for (i = 0; terms[i].name; i++) { - if (!strcmp(terms[i].name, term)) { - keys = terms[i].keys; - funcs = terms[i].funcs; - return 0; - } - } - - /* let's do some heuristic, maybe it's a compatible terminal */ - if (try_compatible(term, "xterm", xterm_keys, xterm_funcs) == 0) - return 0; - if (try_compatible(term, "rxvt", rxvt_unicode_keys, rxvt_unicode_funcs) == 0) - return 0; - if (try_compatible(term, "linux", linux_keys, linux_funcs) == 0) - return 0; - if (try_compatible(term, "Eterm", eterm_keys, eterm_funcs) == 0) - return 0; - if (try_compatible(term, "screen", screen_keys, screen_funcs) == 0) - return 0; - /* let's assume that 'cygwin' is xterm compatible */ - if (try_compatible(term, "cygwin", xterm_keys, xterm_funcs) == 0) - return 0; - } - - return EUNSUPPORTED_TERM; -} - -//---------------------------------------------------------------------- -// terminfo -//---------------------------------------------------------------------- - -static char *read_file(const char *file) { - FILE *f = fopen(file, "rb"); - if (!f) - return 0; - - struct stat st; - if (fstat(fileno(f), &st) != 0) { - fclose(f); - return 0; - } - - char *data = malloc(st.st_size); - if (!data) { - fclose(f); - return 0; - } - - if (fread(data, 1, st.st_size, f) != (size_t)st.st_size) { - fclose(f); - free(data); - return 0; - } - - fclose(f); - return data; -} - -static char *terminfo_try_path(const char *path, const char *term) { - char tmp[4096]; - snprintf(tmp, sizeof(tmp), "%s/%c/%s", path, term[0], term); - tmp[sizeof(tmp)-1] = '\0'; - char *data = read_file(tmp); - if (data) { - return data; - } - - // fallback to darwin specific dirs structure - snprintf(tmp, sizeof(tmp), "%s/%x/%s", path, term[0], term); - tmp[sizeof(tmp)-1] = '\0'; - return read_file(tmp); -} - -static char *load_terminfo(void) { - char tmp[4096]; - const char *term = getenv("TERM"); - if (!term) { - return 0; - } - - // if TERMINFO is set, no other directory should be searched - const char *terminfo = getenv("TERMINFO"); - if (terminfo) { - return terminfo_try_path(terminfo, term); - } - - // next, consider ~/.terminfo - const char *home = getenv("HOME"); - if (home) { - snprintf(tmp, sizeof(tmp), "%s/.terminfo", home); - tmp[sizeof(tmp)-1] = '\0'; - char *data = terminfo_try_path(tmp, term); - if (data) - return data; - } - - // next, TERMINFO_DIRS - const char *dirs = getenv("TERMINFO_DIRS"); - if (dirs) { - snprintf(tmp, sizeof(tmp), "%s", dirs); - tmp[sizeof(tmp)-1] = '\0'; - char *dir = strtok(tmp, ":"); - while (dir) { - const char *cdir = dir; - if (strcmp(cdir, "") == 0) { - cdir = "/usr/share/terminfo"; - } - char *data = terminfo_try_path(cdir, term); - if (data) - return data; - dir = strtok(0, ":"); - } - } - - // fallback to /usr/share/terminfo - return terminfo_try_path("/usr/share/terminfo", term); -} - -#define TI_MAGIC 0432 -#define TI_ALT_MAGIC 542 -#define TI_HEADER_LENGTH 12 -#define TB_KEYS_NUM 22 - -static const char *terminfo_copy_string(char *data, int str, int table) { - const int16_t off = *(int16_t*)(data + str); - const char *src = data + table + off; - int len = strlen(src); - char *dst = malloc(len+1); - strcpy(dst, src); - return dst; -} - -static const int16_t ti_funcs[] = { - 28, 40, 16, 13, 5, 39, 36, 27, 26, 34, 89, 88, -}; - -static const int16_t ti_keys[] = { - 66, 68 /* apparently not a typo; 67 is F10 for whatever reason */, 69, - 70, 71, 72, 73, 74, 75, 67, 216, 217, 77, 59, 76, 164, 82, 81, 87, 61, - 79, 83, -}; - -static int init_term(void) { - int i; - char *data = load_terminfo(); - if (!data) { - init_from_terminfo = false; - return init_term_builtin(); - } - - int16_t *header = (int16_t*)data; - - const int number_sec_len = header[0] == TI_ALT_MAGIC ? 4 : 2; - - if ((header[1] + header[2]) % 2) { - // old quirk to align everything on word boundaries - header[2] += 1; - } - - const int str_offset = TI_HEADER_LENGTH + - header[1] + header[2] + number_sec_len * header[3]; - const int table_offset = str_offset + 2 * header[4]; - - keys = malloc(sizeof(const char*) * (TB_KEYS_NUM+1)); - for (i = 0; i < TB_KEYS_NUM; i++) { - keys[i] = terminfo_copy_string(data, - str_offset + 2 * ti_keys[i], table_offset); - } - keys[TB_KEYS_NUM] = 0; - - funcs = malloc(sizeof(const char*) * T_FUNCS_NUM); - // the last two entries are reserved for mouse. because the table offset is - // not there, the two entries have to fill in manually - for (i = 0; i < T_FUNCS_NUM-2; i++) { - funcs[i] = terminfo_copy_string(data, - str_offset + 2 * ti_funcs[i], table_offset); - } - - funcs[T_FUNCS_NUM-2] = ENTER_MOUSE_SEQ; - funcs[T_FUNCS_NUM-1] = EXIT_MOUSE_SEQ; - - init_from_terminfo = true; - free(data); - return 0; -} - -static void shutdown_term(void) { - if (init_from_terminfo) { - int i; - for (i = 0; i < TB_KEYS_NUM; i++) { - free((void*)keys[i]); - } - // the last two entries are reserved for mouse. because the table offset - // is not there, the two entries have to fill in manually and do not - // need to be freed. - for (i = 0; i < T_FUNCS_NUM-2; i++) { - free((void*)funcs[i]); - } - free(keys); - free(funcs); - } -} - -// if s1 starts with s2 returns true, else false -// len is the length of s1 -// s2 should be null-terminated -static bool starts_with(const char *s1, int len, const char *s2) -{ - int n = 0; - while (*s2 && n < len) { - if (*s1++ != *s2++) - return false; - n++; - } - return *s2 == 0; -} - -static int parse_mouse_event(struct tb_event *event, const char *buf, int len) { - if (len >= 6 && starts_with(buf, len, "\033[M")) { - // X10 mouse encoding, the simplest one - // \033 [ M Cb Cx Cy - int b = buf[3] - 32; - switch (b & 3) { - case 0: - if ((b & 64) != 0) - event->key = TB_KEY_MOUSE_WHEEL_UP; - else - event->key = TB_KEY_MOUSE_LEFT; - break; - case 1: - if ((b & 64) != 0) - event->key = TB_KEY_MOUSE_WHEEL_DOWN; - else - event->key = TB_KEY_MOUSE_MIDDLE; - break; - case 2: - event->key = TB_KEY_MOUSE_RIGHT; - break; - case 3: - event->key = TB_KEY_MOUSE_RELEASE; - break; - default: - return -6; - } - event->type = TB_EVENT_MOUSE; // TB_EVENT_KEY by default - if ((b & 32) != 0) - event->mod |= TB_MOD_MOTION; - - // the coord is 1,1 for upper left - event->x = (uint8_t)buf[4] - 1 - 32; - event->y = (uint8_t)buf[5] - 1 - 32; - - return 6; - } else if (starts_with(buf, len, "\033[<") || starts_with(buf, len, "\033[")) { - // xterm 1006 extended mode or urxvt 1015 extended mode - // xterm: \033 [ < Cb ; Cx ; Cy (M or m) - // urxvt: \033 [ Cb ; Cx ; Cy M - int i, mi = -1, starti = -1; - int isM, isU, s1 = -1, s2 = -1; - int n1 = 0, n2 = 0, n3 = 0; - - for (i = 0; i < len; i++) { - // We search the first (s1) and the last (s2) ';' - if (buf[i] == ';') { - if (s1 == -1) - s1 = i; - s2 = i; - } - - // We search for the first 'm' or 'M' - if ((buf[i] == 'm' || buf[i] == 'M') && mi == -1) { - mi = i; - break; - } - } - if (mi == -1) - return 0; - - // whether it's a capital M or not - isM = (buf[mi] == 'M'); - - if (buf[2] == '<') { - isU = 0; - starti = 3; - } else { - isU = 1; - starti = 2; - } - - if (s1 == -1 || s2 == -1 || s1 == s2) - return 0; - - n1 = strtoul(&buf[starti], NULL, 10); - n2 = strtoul(&buf[s1 + 1], NULL, 10); - n3 = strtoul(&buf[s2 + 1], NULL, 10); - - if (isU) - n1 -= 32; - - switch (n1 & 3) { - case 0: - if ((n1&64) != 0) { - event->key = TB_KEY_MOUSE_WHEEL_UP; - } else { - event->key = TB_KEY_MOUSE_LEFT; - } - break; - case 1: - if ((n1&64) != 0) { - event->key = TB_KEY_MOUSE_WHEEL_DOWN; - } else { - event->key = TB_KEY_MOUSE_MIDDLE; - } - break; - case 2: - event->key = TB_KEY_MOUSE_RIGHT; - break; - case 3: - event->key = TB_KEY_MOUSE_RELEASE; - break; - default: - return mi + 1; - } - - if (!isM) { - // on xterm mouse release is signaled by lowercase m - event->key = TB_KEY_MOUSE_RELEASE; - } - - event->type = TB_EVENT_MOUSE; // TB_EVENT_KEY by default - if ((n1&32) != 0) - event->mod |= TB_MOD_MOTION; - - event->x = (uint8_t)n2 - 1; - event->y = (uint8_t)n3 - 1; - - return mi + 1; - } - - return 0; -} - -// convert escape sequence to event, and return consumed bytes on success (failure == 0) -static int parse_escape_seq(struct tb_event *event, const char *buf, int len) -{ - int mouse_parsed = parse_mouse_event(event, buf, len); - - if (mouse_parsed != 0) - return mouse_parsed; - - // it's pretty simple here, find 'starts_with' match and return - // success, else return failure - int i; - for (i = 0; keys[i]; i++) { - if (starts_with(buf, len, keys[i])) { - event->ch = 0; - event->key = 0xFFFF-i; - return strlen(keys[i]); - } - } - return 0; -} - -static bool extract_event(struct tb_event *event, struct bytebuffer *inbuf, int inputmode) -{ - const char *buf = inbuf->buf; - const int len = inbuf->len; - if (len == 0) - return false; - - if (buf[0] == '\033') { - int n = parse_escape_seq(event, buf, len); - if (n != 0) { - bool success = true; - if (n < 0) { - success = false; - n = -n; - } - bytebuffer_truncate(inbuf, n); - return success; - } else { - // it's not escape sequence, then it's ALT or ESC, - // check inputmode - if (inputmode&TB_INPUT_ESC) { - // if we're in escape mode, fill ESC event, pop - // buffer, return success - event->ch = 0; - event->key = TB_KEY_ESC; - event->mod = 0; - bytebuffer_truncate(inbuf, 1); - return true; - } else if (inputmode&TB_INPUT_ALT) { - // if we're in alt mode, set ALT modifier to - // event and redo parsing - event->mod = TB_MOD_ALT; - bytebuffer_truncate(inbuf, 1); - return extract_event(event, inbuf, inputmode); - } - assert(!"never got here"); - } - } - - // if we're here, this is not an escape sequence and not an alt sequence - // so, it's a FUNCTIONAL KEY or a UNICODE character - - // first of all check if it's a functional key - if ((unsigned char)buf[0] <= TB_KEY_SPACE || - (unsigned char)buf[0] == TB_KEY_BACKSPACE2) - { - // fill event, pop buffer, return success */ - event->ch = 0; - event->key = (uint16_t)buf[0]; - bytebuffer_truncate(inbuf, 1); - return true; - } - - // feh... we got utf8 here - - // check if there is all bytes - if (len >= tb_utf8_char_length(buf[0])) { - /* everything ok, fill event, pop buffer, return success */ - tb_utf8_char_to_unicode(&event->ch, buf); - event->key = 0; - bytebuffer_truncate(inbuf, tb_utf8_char_length(buf[0])); - return true; - } - - // event isn't recognized, perhaps there is not enough bytes in utf8 - // sequence - return false; -} - -struct cellbuf { - int width; - int height; - struct tb_cell *cells; -}; - -#define CELL(buf, x, y) (buf)->cells[(y) * (buf)->width + (x)] -#define IS_CURSOR_HIDDEN(cx, cy) (cx == -1 || cy == -1) -#define LAST_COORD_INIT -1 - -static struct termios orig_tios; - -static struct cellbuf back_buffer; -static struct cellbuf front_buffer; -static struct bytebuffer output_buffer; -static struct bytebuffer input_buffer; - -static int termw = -1; -static int termh = -1; - -static int inputmode = TB_INPUT_ESC; -static int outputmode = TB_OUTPUT_NORMAL; - -static int inout; -static int winch_fds[2]; - -static int lastx = LAST_COORD_INIT; -static int lasty = LAST_COORD_INIT; -static int cursor_x = -1; -static int cursor_y = -1; - -static uint16_t background = TB_DEFAULT; -static uint16_t foreground = TB_DEFAULT; - -static void write_cursor(int x, int y); -static void write_sgr(uint16_t fg, uint16_t bg); - -static void cellbuf_init(struct cellbuf *buf, int width, int height); -static void cellbuf_resize(struct cellbuf *buf, int width, int height); -static void cellbuf_clear(struct cellbuf *buf); -static void cellbuf_free(struct cellbuf *buf); - -static void update_size(void); -static void update_term_size(void); -static void send_attr(uint16_t fg, uint16_t bg); -static void send_char(int x, int y, uint32_t c); -static void send_clear(void); -static void sigwinch_handler(int xxx); -static int wait_fill_event(struct tb_event *event, struct timeval *timeout); - -/* may happen in a different thread */ -static volatile int buffer_size_change_request; - -/* -------------------------------------------------------- */ - -int tb_init_fd(int inout_) -{ - inout = inout_; - if (inout == -1) { - return TB_EFAILED_TO_OPEN_TTY; - } - - if (init_term() < 0) { - close(inout); - return TB_EUNSUPPORTED_TERMINAL; - } - - if (pipe(winch_fds) < 0) { - close(inout); - return TB_EPIPE_TRAP_ERROR; - } - - struct sigaction sa; - memset(&sa, 0, sizeof(sa)); - sa.sa_handler = sigwinch_handler; - sa.sa_flags = 0; - sigaction(SIGWINCH, &sa, 0); - - tcgetattr(inout, &orig_tios); - - struct termios tios; - memcpy(&tios, &orig_tios, sizeof(tios)); - - tios.c_iflag &= ~(IGNBRK | BRKINT | PARMRK | ISTRIP - | INLCR | IGNCR | ICRNL | IXON); - tios.c_oflag &= ~OPOST; - tios.c_lflag &= ~(ECHO | ECHONL | ICANON | ISIG | IEXTEN); - tios.c_cflag &= ~(CSIZE | PARENB); - tios.c_cflag |= CS8; - tios.c_cc[VMIN] = 0; - tios.c_cc[VTIME] = 0; - tcsetattr(inout, TCSAFLUSH, &tios); - - bytebuffer_init(&input_buffer, 128); - bytebuffer_init(&output_buffer, 32 * 1024); - - bytebuffer_puts(&output_buffer, funcs[T_ENTER_CA]); - bytebuffer_puts(&output_buffer, funcs[T_ENTER_KEYPAD]); - bytebuffer_puts(&output_buffer, funcs[T_HIDE_CURSOR]); - send_clear(); - - update_term_size(); - cellbuf_init(&back_buffer, termw, termh); - cellbuf_init(&front_buffer, termw, termh); - cellbuf_clear(&back_buffer); - cellbuf_clear(&front_buffer); - - return 0; -} - -int tb_init_file(const char* name){ - return tb_init_fd(open(name, O_RDWR)); -} - -int tb_init(void) -{ - return tb_init_file("/dev/tty"); -} - -void tb_shutdown(void) -{ - if (termw == -1) { - fputs("tb_shutdown() should not be called twice.", stderr); - abort(); - } - - bytebuffer_puts(&output_buffer, funcs[T_SHOW_CURSOR]); - bytebuffer_puts(&output_buffer, funcs[T_SGR0]); - bytebuffer_puts(&output_buffer, funcs[T_CLEAR_SCREEN]); - bytebuffer_puts(&output_buffer, funcs[T_EXIT_CA]); - bytebuffer_puts(&output_buffer, funcs[T_EXIT_KEYPAD]); - bytebuffer_puts(&output_buffer, funcs[T_EXIT_MOUSE]); - bytebuffer_flush(&output_buffer, inout); - tcsetattr(inout, TCSAFLUSH, &orig_tios); - - shutdown_term(); - close(inout); - close(winch_fds[0]); - close(winch_fds[1]); - - cellbuf_free(&back_buffer); - cellbuf_free(&front_buffer); - bytebuffer_free(&output_buffer); - bytebuffer_free(&input_buffer); - termw = termh = -1; -} - -void tb_present(void) -{ - int x,y,w,i; - struct tb_cell *back, *front; - - /* invalidate cursor position */ - lastx = LAST_COORD_INIT; - lasty = LAST_COORD_INIT; - - if (buffer_size_change_request) { - update_size(); - buffer_size_change_request = 0; - } - - for (y = 0; y < front_buffer.height; ++y) { - for (x = 0; x < front_buffer.width; ) { - back = &CELL(&back_buffer, x, y); - front = &CELL(&front_buffer, x, y); - w = wcwidth(back->ch); - if (w < 1) w = 1; - if (memcmp(back, front, sizeof(struct tb_cell)) == 0) { - x += w; - continue; - } - memcpy(front, back, sizeof(struct tb_cell)); - send_attr(back->fg, back->bg); - if (w > 1 && x >= front_buffer.width - (w - 1)) { - // Not enough room for wide ch, so send spaces - for (i = x; i < front_buffer.width; ++i) { - send_char(i, y, ' '); - } - } else { - send_char(x, y, back->ch); - for (i = 1; i < w; ++i) { - front = &CELL(&front_buffer, x + i, y); - front->ch = 0; - front->fg = back->fg; - front->bg = back->bg; - } - } - x += w; - } - } - if (!IS_CURSOR_HIDDEN(cursor_x, cursor_y)) - write_cursor(cursor_x, cursor_y); - bytebuffer_flush(&output_buffer, inout); -} - -void tb_set_cursor(int cx, int cy) -{ - if (IS_CURSOR_HIDDEN(cursor_x, cursor_y) && !IS_CURSOR_HIDDEN(cx, cy)) - bytebuffer_puts(&output_buffer, funcs[T_SHOW_CURSOR]); - - if (!IS_CURSOR_HIDDEN(cursor_x, cursor_y) && IS_CURSOR_HIDDEN(cx, cy)) - bytebuffer_puts(&output_buffer, funcs[T_HIDE_CURSOR]); - - cursor_x = cx; - cursor_y = cy; - if (!IS_CURSOR_HIDDEN(cursor_x, cursor_y)) - write_cursor(cursor_x, cursor_y); -} - -void tb_put_cell(int x, int y, const struct tb_cell *cell) -{ - if ((unsigned)x >= (unsigned)back_buffer.width) - return; - if ((unsigned)y >= (unsigned)back_buffer.height) - return; - CELL(&back_buffer, x, y) = *cell; -} - -void tb_change_cell(int x, int y, uint32_t ch, uint16_t fg, uint16_t bg) -{ - struct tb_cell c = {ch, fg, bg}; - tb_put_cell(x, y, &c); -} - -void tb_blit(int x, int y, int w, int h, const struct tb_cell *cells) -{ - if (x + w < 0 || x >= back_buffer.width) - return; - if (y + h < 0 || y >= back_buffer.height) - return; - int xo = 0, yo = 0, ww = w, hh = h; - if (x < 0) { - xo = -x; - ww -= xo; - x = 0; - } - if (y < 0) { - yo = -y; - hh -= yo; - y = 0; - } - if (ww > back_buffer.width - x) - ww = back_buffer.width - x; - if (hh > back_buffer.height - y) - hh = back_buffer.height - y; - - int sy; - struct tb_cell *dst = &CELL(&back_buffer, x, y); - const struct tb_cell *src = cells + yo * w + xo; - size_t size = sizeof(struct tb_cell) * ww; - - for (sy = 0; sy < hh; ++sy) { - memcpy(dst, src, size); - dst += back_buffer.width; - src += w; - } -} - -struct tb_cell *tb_cell_buffer(void) -{ - return back_buffer.cells; -} - -int tb_poll_event(struct tb_event *event) -{ - return wait_fill_event(event, 0); -} - -int tb_peek_event(struct tb_event *event, int timeout) -{ - struct timeval tv; - tv.tv_sec = timeout / 1000; - tv.tv_usec = (timeout - (tv.tv_sec * 1000)) * 1000; - return wait_fill_event(event, &tv); -} - -int tb_width(void) -{ - return termw; -} - -int tb_height(void) -{ - return termh; -} - -void tb_clear(void) -{ - if (buffer_size_change_request) { - update_size(); - buffer_size_change_request = 0; - } - cellbuf_clear(&back_buffer); -} - -int tb_select_input_mode(int mode) -{ - if (mode) { - if ((mode & (TB_INPUT_ESC | TB_INPUT_ALT)) == 0) - mode |= TB_INPUT_ESC; - - /* technically termbox can handle that, but let's be nice and show here - what mode is actually used */ - if ((mode & (TB_INPUT_ESC | TB_INPUT_ALT)) == (TB_INPUT_ESC | TB_INPUT_ALT)) - mode &= ~TB_INPUT_ALT; - - inputmode = mode; - if (mode&TB_INPUT_MOUSE) { - bytebuffer_puts(&output_buffer, funcs[T_ENTER_MOUSE]); - bytebuffer_flush(&output_buffer, inout); - } else { - bytebuffer_puts(&output_buffer, funcs[T_EXIT_MOUSE]); - bytebuffer_flush(&output_buffer, inout); - } - } - return inputmode; -} - -int tb_select_output_mode(int mode) -{ - if (mode) - outputmode = mode; - return outputmode; -} - -void tb_set_clear_attributes(uint16_t fg, uint16_t bg) -{ - foreground = fg; - background = bg; -} - -/* -------------------------------------------------------- */ - -static int convertnum(uint32_t num, char* buf) { - int i, l = 0; - int ch; - do { - buf[l++] = '0' + (num % 10); - num /= 10; - } while (num); - for(i = 0; i < l / 2; i++) { - ch = buf[i]; - buf[i] = buf[l - 1 - i]; - buf[l - 1 - i] = ch; - } - return l; -} - -#define WRITE_LITERAL(X) bytebuffer_append(&output_buffer, (X), sizeof(X)-1) -#define WRITE_INT(X) bytebuffer_append(&output_buffer, buf, convertnum((X), buf)) - -static void write_cursor(int x, int y) { - char buf[32]; - WRITE_LITERAL("\033["); - WRITE_INT(y+1); - WRITE_LITERAL(";"); - WRITE_INT(x+1); - WRITE_LITERAL("H"); -} - -static void write_sgr(uint16_t fg, uint16_t bg) { - char buf[32]; - - if (fg == TB_DEFAULT && bg == TB_DEFAULT) - return; - - switch (outputmode) { - case TB_OUTPUT_256: - case TB_OUTPUT_216: - case TB_OUTPUT_GRAYSCALE: - WRITE_LITERAL("\033["); - if (fg != TB_DEFAULT) { - WRITE_LITERAL("38;5;"); - WRITE_INT(fg); - if (bg != TB_DEFAULT) { - WRITE_LITERAL(";"); - } - } - if (bg != TB_DEFAULT) { - WRITE_LITERAL("48;5;"); - WRITE_INT(bg); - } - WRITE_LITERAL("m"); - break; - case TB_OUTPUT_NORMAL: - default: - WRITE_LITERAL("\033["); - if (fg != TB_DEFAULT) { - WRITE_LITERAL("3"); - WRITE_INT(fg - 1); - if (bg != TB_DEFAULT) { - WRITE_LITERAL(";"); - } - } - if (bg != TB_DEFAULT) { - WRITE_LITERAL("4"); - WRITE_INT(bg - 1); - } - WRITE_LITERAL("m"); - break; - } -} - -static void cellbuf_init(struct cellbuf *buf, int width, int height) -{ - buf->cells = (struct tb_cell*)malloc(sizeof(struct tb_cell) * width * height); - assert(buf->cells); - buf->width = width; - buf->height = height; -} - -static void cellbuf_resize(struct cellbuf *buf, int width, int height) -{ - if (buf->width == width && buf->height == height) - return; - - int oldw = buf->width; - int oldh = buf->height; - struct tb_cell *oldcells = buf->cells; - - cellbuf_init(buf, width, height); - cellbuf_clear(buf); - - int minw = (width < oldw) ? width : oldw; - int minh = (height < oldh) ? height : oldh; - int i; - - for (i = 0; i < minh; ++i) { - struct tb_cell *csrc = oldcells + (i * oldw); - struct tb_cell *cdst = buf->cells + (i * width); - memcpy(cdst, csrc, sizeof(struct tb_cell) * minw); - } - - free(oldcells); -} - -static void cellbuf_clear(struct cellbuf *buf) -{ - int i; - int ncells = buf->width * buf->height; - - for (i = 0; i < ncells; ++i) { - buf->cells[i].ch = ' '; - buf->cells[i].fg = foreground; - buf->cells[i].bg = background; - } -} - -static void cellbuf_free(struct cellbuf *buf) -{ - free(buf->cells); -} - -static void get_term_size(int *w, int *h) -{ - struct winsize sz; - memset(&sz, 0, sizeof(sz)); - - ioctl(inout, TIOCGWINSZ, &sz); - - if (w) *w = sz.ws_col; - if (h) *h = sz.ws_row; -} - -static void update_term_size(void) -{ - struct winsize sz; - memset(&sz, 0, sizeof(sz)); - - ioctl(inout, TIOCGWINSZ, &sz); - - termw = sz.ws_col; - termh = sz.ws_row; -} - -static void send_attr(uint16_t fg, uint16_t bg) -{ -#define LAST_ATTR_INIT 0xFFFF - static uint16_t lastfg = LAST_ATTR_INIT, lastbg = LAST_ATTR_INIT; - if (fg != lastfg || bg != lastbg) { - bytebuffer_puts(&output_buffer, funcs[T_SGR0]); - - uint16_t fgcol; - uint16_t bgcol; - - switch (outputmode) { - case TB_OUTPUT_256: - fgcol = fg & 0xFF; - bgcol = bg & 0xFF; - break; - - case TB_OUTPUT_216: - fgcol = fg & 0xFF; if (fgcol > 215) fgcol = 7; - bgcol = bg & 0xFF; if (bgcol > 215) bgcol = 0; - fgcol += 0x10; - bgcol += 0x10; - break; - - case TB_OUTPUT_GRAYSCALE: - fgcol = fg & 0xFF; if (fgcol > 23) fgcol = 23; - bgcol = bg & 0xFF; if (bgcol > 23) bgcol = 0; - fgcol += 0xe8; - bgcol += 0xe8; - break; - - case TB_OUTPUT_NORMAL: - default: - fgcol = fg & 0x0F; - bgcol = bg & 0x0F; - } - - if (fg & TB_BOLD) - bytebuffer_puts(&output_buffer, funcs[T_BOLD]); - if (bg & TB_BOLD) - bytebuffer_puts(&output_buffer, funcs[T_BLINK]); - if (fg & TB_UNDERLINE) - bytebuffer_puts(&output_buffer, funcs[T_UNDERLINE]); - if ((fg & TB_REVERSE) || (bg & TB_REVERSE)) - bytebuffer_puts(&output_buffer, funcs[T_REVERSE]); - - write_sgr(fgcol, bgcol); - - lastfg = fg; - lastbg = bg; - } -} - -static void send_char(int x, int y, uint32_t c) -{ - char buf[7]; - int bw = tb_utf8_unicode_to_char(buf, c); - if (x-1 != lastx || y != lasty) - write_cursor(x, y); - lastx = x; lasty = y; - if(!c) buf[0] = ' '; // replace 0 with whitespace - bytebuffer_append(&output_buffer, buf, bw); -} - -static void send_clear(void) -{ - send_attr(foreground, background); - bytebuffer_puts(&output_buffer, funcs[T_CLEAR_SCREEN]); - if (!IS_CURSOR_HIDDEN(cursor_x, cursor_y)) - write_cursor(cursor_x, cursor_y); - bytebuffer_flush(&output_buffer, inout); - - /* we need to invalidate cursor position too and these two vars are - * used only for simple cursor positioning optimization, cursor - * actually may be in the correct place, but we simply discard - * optimization once and it gives us simple solution for the case when - * cursor moved */ - lastx = LAST_COORD_INIT; - lasty = LAST_COORD_INIT; -} - -static void sigwinch_handler(int xxx) -{ - (void) xxx; - const int zzz = 1; - write(winch_fds[1], &zzz, sizeof(int)); -} - -static void update_size(void) -{ - update_term_size(); - cellbuf_resize(&back_buffer, termw, termh); - cellbuf_resize(&front_buffer, termw, termh); - cellbuf_clear(&front_buffer); - send_clear(); -} - -static int read_up_to(int n) { - assert(n > 0); - const int prevlen = input_buffer.len; - bytebuffer_resize(&input_buffer, prevlen + n); - - int read_n = 0; - while (read_n <= n) { - ssize_t r = 0; - if (read_n < n) { - r = read(inout, input_buffer.buf + prevlen + read_n, n - read_n); - } -#ifdef __CYGWIN__ - // While linux man for tty says when VMIN == 0 && VTIME == 0, read - // should return 0 when there is nothing to read, cygwin's read returns - // -1. Not sure why and if it's correct to ignore it, but let's pretend - // it's zero. - if (r < 0) r = 0; -#endif - if (r < 0) { - // EAGAIN / EWOULDBLOCK shouldn't occur here - assert(errno != EAGAIN && errno != EWOULDBLOCK); - return -1; - } else if (r > 0) { - read_n += r; - } else { - bytebuffer_resize(&input_buffer, prevlen + read_n); - return read_n; - } - } - assert(!"unreachable"); - return 0; -} - -static int wait_fill_event(struct tb_event *event, struct timeval *timeout) -{ - // ;-) -#define ENOUGH_DATA_FOR_PARSING 64 - fd_set events; - memset(event, 0, sizeof(struct tb_event)); - - // try to extract event from input buffer, return on success - event->type = TB_EVENT_KEY; - if (extract_event(event, &input_buffer, inputmode)) - return event->type; - - // it looks like input buffer is incomplete, let's try the short path, - // but first make sure there is enough space - int n = read_up_to(ENOUGH_DATA_FOR_PARSING); - if (n < 0) - return -1; - if (n > 0 && extract_event(event, &input_buffer, inputmode)) - return event->type; - - // n == 0, or not enough data, let's go to select - while (1) { - FD_ZERO(&events); - FD_SET(inout, &events); - FD_SET(winch_fds[0], &events); - int maxfd = (winch_fds[0] > inout) ? winch_fds[0] : inout; - int result = select(maxfd+1, &events, 0, 0, timeout); - if (!result) - return 0; - - if (FD_ISSET(inout, &events)) { - event->type = TB_EVENT_KEY; - n = read_up_to(ENOUGH_DATA_FOR_PARSING); - if (n < 0) - return -1; - - if (n == 0) - continue; - - if (extract_event(event, &input_buffer, inputmode)) - return event->type; - } - if (FD_ISSET(winch_fds[0], &events)) { - event->type = TB_EVENT_RESIZE; - int zzz = 0; - read(winch_fds[0], &zzz, sizeof(int)); - buffer_size_change_request = 1; - get_term_size(&event->w, &event->h); - return TB_EVENT_RESIZE; - } - } -} diff --git a/cbits/utf8.c b/cbits/utf8.c deleted file mode 100644 --- a/cbits/utf8.c +++ /dev/null @@ -1,79 +0,0 @@ -#include "termbox.h" - -static const unsigned char utf8_length[256] = { - 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, - 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, - 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, - 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, - 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, - 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, - 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, - 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,4,4,4,4,4,4,4,4,5,5,5,5,6,6,1,1 -}; - -static const unsigned char utf8_mask[6] = { - 0x7F, - 0x1F, - 0x0F, - 0x07, - 0x03, - 0x01 -}; - -int tb_utf8_char_length(char c) -{ - return utf8_length[(unsigned char)c]; -} - -int tb_utf8_char_to_unicode(uint32_t *out, const char *c) -{ - if (*c == 0) - return TB_EOF; - - int i; - unsigned char len = tb_utf8_char_length(*c); - unsigned char mask = utf8_mask[len-1]; - uint32_t result = c[0] & mask; - for (i = 1; i < len; ++i) { - result <<= 6; - result |= c[i] & 0x3f; - } - - *out = result; - return (int)len; -} - -int tb_utf8_unicode_to_char(char *out, uint32_t c) -{ - int len = 0; - int first; - int i; - - if (c < 0x80) { - first = 0; - len = 1; - } else if (c < 0x800) { - first = 0xc0; - len = 2; - } else if (c < 0x10000) { - first = 0xe0; - len = 3; - } else if (c < 0x200000) { - first = 0xf0; - len = 4; - } else if (c < 0x4000000) { - first = 0xf8; - len = 5; - } else { - first = 0xfc; - len = 6; - } - - for (i = len - 1; i > 0; --i) { - out[i] = (c & 0x3f) | 0x80; - c >>= 6; - } - out[0] = c | first; - - return len; -} diff --git a/examples/Colors.hs b/examples/Colors.hs deleted file mode 100644 --- a/examples/Colors.hs +++ /dev/null @@ -1,42 +0,0 @@ -import Data.Semigroup ((<>)) -import qualified Termbox - -main :: IO () -main = - Termbox.run $ \_w _h render poll -> do - let rectangles :: [(Int, Int, Int, Int)] - rectangles = do - y0 <- [0, 2 ..] - x0 <- [0, 4 .. 48] - pure (x0, y0, x0 + 3, y0 + 1) - - 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) - - 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) - - loop Nothing - -string :: Int -> Int -> Termbox.Attr -> Termbox.Attr -> [Char] -> Termbox.Cells -string x0 y fg bg = - mconcat . zipWith (\x c -> Termbox.set x y (Termbox.Cell c fg bg)) [x0 ..] - -rectangle :: Int -> Int -> Int -> Int -> Termbox.Cell -> Termbox.Cells -rectangle x0 y0 x1 y1 c = - foldMap (\(x, y) -> Termbox.set x y c) ((,) <$> [x0 .. x1] <*> [y0 .. y1]) diff --git a/examples/Demo.hs b/examples/Demo.hs new file mode 100644 --- /dev/null +++ b/examples/Demo.hs @@ -0,0 +1,292 @@ +module Main (main) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.MVar +import Control.Monad (forever) +import GHC.Clock (getMonotonicTime) +import qualified Ki +import qualified Termbox +import Text.Printf (printf) + +main :: IO () +main = do + t0 <- getMonotonicTime + result <- + Ki.scoped \scope -> do + timeVar <- newEmptyMVar + Ki.fork_ scope do + forever do + threadDelay 100_000 + getMonotonicTime >>= putMVar timeVar + Termbox.run + Termbox.Program + { initialize, + pollEvent = pollEvent t0 timeVar, + handleEvent, + render, + finished + } + case result of + Left err -> print err + Right _state -> pure () + +data State = State + { elapsed :: Double, + lastKey :: Maybe Termbox.Key, + bright :: Bool + } + +initialize :: Termbox.Size -> State +initialize _size = + State + { elapsed = 0, + lastKey = Nothing, + bright = False + } + +pollEvent :: Double -> MVar Double -> Maybe (IO Double) +pollEvent t0 timeVar = + Just do + t1 <- takeMVar timeVar + pure (t1 - t0) + +handleEvent :: State -> Termbox.Event Double -> IO State +handleEvent State {elapsed, lastKey, bright} = \case + Termbox.EventKey key -> + pure + State + { elapsed, + lastKey = Just key, + bright = + case key of + Termbox.KeyChar '*' -> not bright + _ -> bright + } + Termbox.EventUser elapsed1 -> + pure + State + { elapsed = elapsed1, + lastKey, + bright + } + _ -> + pure + State + { elapsed, + lastKey, + bright + } + +render :: State -> Termbox.Scene +render State {elapsed, lastKey, bright} = + renderBox Termbox.Pos {row = 1, col = 2} $ + vcat + [ string "Welcome to Termbox. Try typing, clicking, and resizing the terminal!", + string " ", + hcat + [ string "Elapsed time: ", + string (map Termbox.char (printf "%.1fs" elapsed)) + ], + hcat + [ string "Latest key press: ", + case lastKey of + Nothing -> emptyBox + Just event -> string (map (Termbox.bold . Termbox.char) (show event)) + ], + string " ", + string "default red green yellow blue magenta cyan white", + hcat + [ rect + Rect + { size = Termbox.Size {width = 7, height = 2}, + color = brighten Termbox.defaultColor + }, + string " ", + rect + Rect + { size = Termbox.Size {width = 3, height = 2}, + color = brighten Termbox.red + }, + string " ", + rect + Rect + { size = Termbox.Size {width = 5, height = 2}, + color = brighten Termbox.green + }, + string " ", + rect + Rect + { size = Termbox.Size {width = 6, height = 2}, + color = brighten Termbox.yellow + }, + string " ", + rect + Rect + { size = Termbox.Size {width = 4, height = 2}, + color = brighten Termbox.blue + }, + string " ", + rect + Rect + { size = Termbox.Size {width = 7, height = 2}, + color = brighten Termbox.magenta + }, + string " ", + rect + Rect + { size = Termbox.Size {width = 4, height = 2}, + color = brighten Termbox.cyan + }, + string " ", + rect + Rect + { size = Termbox.Size {width = 5, height = 2}, + color = brighten Termbox.white + }, + string " ", + vcat + [ string ("Press " ++ [Termbox.bold (Termbox.char '*')] ++ " to toggle brightness."), + string + ( let selected = map (Termbox.bg (Termbox.gray 20) . Termbox.fg (Termbox.gray 0)) + in if bright + then "normal " ++ selected "bright" + else selected "normal" ++ " bright" + ) + ] + ], + string " ", + string "color 0 .. color 215", + vcat + ( map + ( \is -> + hcat + ( map + ( \i -> + acat + [ rect + Rect + { size = Termbox.Size {width = 4, height = 2}, + color = Termbox.color i + }, + string (map (Termbox.bg (Termbox.color i) . Termbox.char) (show i)) + ] + ) + is + ) + ) + (chunksOf 24 [0 .. 215]) + ), + string " ", + string "gray 0 .. gray 23", + hcat + ( map + ( \i -> + acat + [ rect + Rect + { size = Termbox.Size {width = 4, height = 2}, + color = Termbox.gray i + }, + string (map (Termbox.bg (Termbox.gray i) . Termbox.char) (show i)) + ] + ) + [0 .. 23] + ), + string " ", + hcat + [ string (map Termbox.bold "This text is bold."), + string " ", + string (map Termbox.underline "This text is underlined."), + string " ", + string (map Termbox.blink "This text is blinking (maybe).") + ], + string " ", + hcat + [ string "Press ", + string (map Termbox.bold "Esc"), + string " to quit!" + ] + ] + where + brighten :: Termbox.Color -> Termbox.Color + brighten = + if bright + then Termbox.bright + else id + +finished :: State -> Bool +finished State {lastKey} = + case lastKey of + Just Termbox.KeyEsc -> True + _ -> False + +data Box + = Box !Termbox.Size Content + +data Content + = E + | O !Termbox.Cell + | A !Box !Box + | H !Box !Box + | V !Box !Box + +emptyBox :: Box +emptyBox = + Box (Termbox.Size 0 0) E + +one :: Termbox.Cell -> Box +one cell = + Box (Termbox.Size 1 1) (O cell) -- assume it's not an empty cell *shrug* + +acat :: [Box] -> Box +acat = + foldr f emptyBox + where + f :: Box -> Box -> Box + f box1@(Box (Termbox.Size w1 h1) _) box2@(Box (Termbox.Size w2 h2) _) = + Box (Termbox.Size (max w1 w2) (max h1 h2)) (A box1 box2) + +hcat :: [Box] -> Box +hcat = + foldr f emptyBox + where + f :: Box -> Box -> Box + f box1@(Box (Termbox.Size w1 h1) _) box2@(Box (Termbox.Size w2 h2) _) = + Box (Termbox.Size (w1 + w2) (max h1 h2)) (H box1 box2) + +vcat :: [Box] -> Box +vcat = + foldr f emptyBox + where + f :: Box -> Box -> Box + f box1@(Box (Termbox.Size w1 h1) _) box2@(Box (Termbox.Size w2 h2) _) = + Box (Termbox.Size (max w1 w2) (h1 + h2)) (V box1 box2) + +renderBox :: Termbox.Pos -> Box -> Termbox.Scene +renderBox pos (Box _ content) = + case content of + E -> mempty + O cell -> Termbox.cell pos cell + A box1 box2 -> renderBox pos box1 <> renderBox pos box2 + H box1@(Box (Termbox.Size w1 _) _) box2 -> renderBox pos box1 <> renderBox (Termbox.posRight w1 pos) box2 + V box1@(Box (Termbox.Size _ h1) _) box2 -> renderBox pos box1 <> renderBox (Termbox.posDown h1 pos) box2 + +string :: [Termbox.Cell] -> Box +string = + hcat . map one + +data Rect = Rect + { size :: Termbox.Size, + color :: Termbox.Color + } + +rect :: Rect -> Box +rect Rect {size = Termbox.Size {width, height}, color} = + vcat (replicate height (string (replicate width (Termbox.bg color (Termbox.char ' '))))) + +chunksOf :: Int -> [a] -> [[a]] +chunksOf n = \case + [] -> [] + xs -> + let (ys, zs) = splitAt n xs + in ys : chunksOf n zs diff --git a/include/termbox.h b/include/termbox.h deleted file mode 100644 --- a/include/termbox.h +++ /dev/null @@ -1,320 +0,0 @@ -#pragma once - -#include - -/* for shared objects */ -#if __GNUC__ >= 4 - #define SO_IMPORT __attribute__((visibility("default"))) -#else - #define SO_IMPORT -#endif - -#ifdef __cplusplus -extern "C" { -#endif - -/* Key constants. See also struct tb_event's key field. - * - * These are a safe subset of terminfo keys, which exist on all popular - * terminals. Termbox uses only them to stay truly portable. - */ -#define TB_KEY_F1 (0xFFFF-0) -#define TB_KEY_F2 (0xFFFF-1) -#define TB_KEY_F3 (0xFFFF-2) -#define TB_KEY_F4 (0xFFFF-3) -#define TB_KEY_F5 (0xFFFF-4) -#define TB_KEY_F6 (0xFFFF-5) -#define TB_KEY_F7 (0xFFFF-6) -#define TB_KEY_F8 (0xFFFF-7) -#define TB_KEY_F9 (0xFFFF-8) -#define TB_KEY_F10 (0xFFFF-9) -#define TB_KEY_F11 (0xFFFF-10) -#define TB_KEY_F12 (0xFFFF-11) -#define TB_KEY_INSERT (0xFFFF-12) -#define TB_KEY_DELETE (0xFFFF-13) -#define TB_KEY_HOME (0xFFFF-14) -#define TB_KEY_END (0xFFFF-15) -#define TB_KEY_PGUP (0xFFFF-16) -#define TB_KEY_PGDN (0xFFFF-17) -#define TB_KEY_ARROW_UP (0xFFFF-18) -#define TB_KEY_ARROW_DOWN (0xFFFF-19) -#define TB_KEY_ARROW_LEFT (0xFFFF-20) -#define TB_KEY_ARROW_RIGHT (0xFFFF-21) -#define TB_KEY_MOUSE_LEFT (0xFFFF-22) -#define TB_KEY_MOUSE_RIGHT (0xFFFF-23) -#define TB_KEY_MOUSE_MIDDLE (0xFFFF-24) -#define TB_KEY_MOUSE_RELEASE (0xFFFF-25) -#define TB_KEY_MOUSE_WHEEL_UP (0xFFFF-26) -#define TB_KEY_MOUSE_WHEEL_DOWN (0xFFFF-27) - -/* These are all ASCII code points below SPACE character and a BACKSPACE key. */ -#define TB_KEY_CTRL_TILDE 0x00 -#define TB_KEY_CTRL_2 0x00 /* clash with 'CTRL_TILDE' */ -#define TB_KEY_CTRL_A 0x01 -#define TB_KEY_CTRL_B 0x02 -#define TB_KEY_CTRL_C 0x03 -#define TB_KEY_CTRL_D 0x04 -#define TB_KEY_CTRL_E 0x05 -#define TB_KEY_CTRL_F 0x06 -#define TB_KEY_CTRL_G 0x07 -#define TB_KEY_BACKSPACE 0x08 -#define TB_KEY_CTRL_H 0x08 /* clash with 'CTRL_BACKSPACE' */ -#define TB_KEY_TAB 0x09 -#define TB_KEY_CTRL_I 0x09 /* clash with 'TAB' */ -#define TB_KEY_CTRL_J 0x0A -#define TB_KEY_CTRL_K 0x0B -#define TB_KEY_CTRL_L 0x0C -#define TB_KEY_ENTER 0x0D -#define TB_KEY_CTRL_M 0x0D /* clash with 'ENTER' */ -#define TB_KEY_CTRL_N 0x0E -#define TB_KEY_CTRL_O 0x0F -#define TB_KEY_CTRL_P 0x10 -#define TB_KEY_CTRL_Q 0x11 -#define TB_KEY_CTRL_R 0x12 -#define TB_KEY_CTRL_S 0x13 -#define TB_KEY_CTRL_T 0x14 -#define TB_KEY_CTRL_U 0x15 -#define TB_KEY_CTRL_V 0x16 -#define TB_KEY_CTRL_W 0x17 -#define TB_KEY_CTRL_X 0x18 -#define TB_KEY_CTRL_Y 0x19 -#define TB_KEY_CTRL_Z 0x1A -#define TB_KEY_ESC 0x1B -#define TB_KEY_CTRL_LSQ_BRACKET 0x1B /* clash with 'ESC' */ -#define TB_KEY_CTRL_3 0x1B /* clash with 'ESC' */ -#define TB_KEY_CTRL_4 0x1C -#define TB_KEY_CTRL_BACKSLASH 0x1C /* clash with 'CTRL_4' */ -#define TB_KEY_CTRL_5 0x1D -#define TB_KEY_CTRL_RSQ_BRACKET 0x1D /* clash with 'CTRL_5' */ -#define TB_KEY_CTRL_6 0x1E -#define TB_KEY_CTRL_7 0x1F -#define TB_KEY_CTRL_SLASH 0x1F /* clash with 'CTRL_7' */ -#define TB_KEY_CTRL_UNDERSCORE 0x1F /* clash with 'CTRL_7' */ -#define TB_KEY_SPACE 0x20 -#define TB_KEY_BACKSPACE2 0x7F -#define TB_KEY_CTRL_8 0x7F /* clash with 'BACKSPACE2' */ - -/* These are non-existing ones. - * - * #define TB_KEY_CTRL_1 clash with '1' - * #define TB_KEY_CTRL_9 clash with '9' - * #define TB_KEY_CTRL_0 clash with '0' - */ - -/* - * Alt modifier constant, see tb_event.mod field and tb_select_input_mode function. - * Mouse-motion modifier - */ -#define TB_MOD_ALT 0x01 -#define TB_MOD_MOTION 0x02 - -/* Colors (see struct tb_cell's fg and bg fields). */ -#define TB_DEFAULT 0x00 -#define TB_BLACK 0x01 -#define TB_RED 0x02 -#define TB_GREEN 0x03 -#define TB_YELLOW 0x04 -#define TB_BLUE 0x05 -#define TB_MAGENTA 0x06 -#define TB_CYAN 0x07 -#define TB_WHITE 0x08 - -/* Attributes, it is possible to use multiple attributes by combining them - * using bitwise OR ('|'). Although, colors cannot be combined. But you can - * combine attributes and a single color. See also struct tb_cell's fg and bg - * fields. - */ -#define TB_BOLD 0x0100 -#define TB_UNDERLINE 0x0200 -#define TB_REVERSE 0x0400 - -/* A cell, single conceptual entity on the terminal screen. The terminal screen - * is basically a 2d array of cells. It has the following fields: - * - 'ch' is a unicode character - * - 'fg' foreground color and attributes - * - 'bg' background color and attributes - */ -struct tb_cell { - uint32_t ch; - uint16_t fg; - uint16_t bg; -}; - -#define TB_EVENT_KEY 1 -#define TB_EVENT_RESIZE 2 -#define TB_EVENT_MOUSE 3 - -/* An event, single interaction from the user. The 'mod' and 'ch' fields are - * valid if 'type' is TB_EVENT_KEY. The 'w' and 'h' fields are valid if 'type' - * is TB_EVENT_RESIZE. The 'x' and 'y' fields are valid if 'type' is - * TB_EVENT_MOUSE. The 'key' field is valid if 'type' is either TB_EVENT_KEY - * or TB_EVENT_MOUSE. The fields 'key' and 'ch' are mutually exclusive; only - * one of them can be non-zero at a time. - */ -struct tb_event { - uint8_t type; - uint8_t mod; /* modifiers to either 'key' or 'ch' below */ - uint16_t key; /* one of the TB_KEY_* constants */ - uint32_t ch; /* unicode character */ - int32_t w; - int32_t h; - int32_t x; - int32_t y; -}; - -/* Error codes returned by tb_init(). All of them are self-explanatory, except - * the pipe trap error. Termbox uses unix pipes in order to deliver a message - * from a signal handler (SIGWINCH) to the main event reading loop. Honestly in - * most cases you should just check the returned code as < 0. - */ -#define TB_EUNSUPPORTED_TERMINAL -1 -#define TB_EFAILED_TO_OPEN_TTY -2 -#define TB_EPIPE_TRAP_ERROR -3 - -/* Initializes the termbox library. This function should be called before any - * other functions. Function tb_init is same as tb_init_file("/dev/tty"). - * After successful initialization, the library must be - * finalized using the tb_shutdown() function. - */ -SO_IMPORT int tb_init(void); -SO_IMPORT int tb_init_file(const char* name); -SO_IMPORT int tb_init_fd(int inout); -SO_IMPORT void tb_shutdown(void); - -/* Returns the size of the internal back buffer (which is the same as - * terminal's window size in characters). The internal buffer can be resized - * after tb_clear() or tb_present() function calls. Both dimensions have an - * unspecified negative value when called before tb_init() or after - * tb_shutdown(). - */ -SO_IMPORT int tb_width(void); -SO_IMPORT int tb_height(void); - -/* Clears the internal back buffer using TB_DEFAULT color or the - * color/attributes set by tb_set_clear_attributes() function. - */ -SO_IMPORT void tb_clear(void); -SO_IMPORT void tb_set_clear_attributes(uint16_t fg, uint16_t bg); - -/* Synchronizes the internal back buffer with the terminal. */ -SO_IMPORT void tb_present(void); - -#define TB_HIDE_CURSOR -1 - -/* Sets the position of the cursor. Upper-left character is (0, 0). If you pass - * TB_HIDE_CURSOR as both coordinates, then the cursor will be hidden. Cursor - * is hidden by default. - */ -SO_IMPORT void tb_set_cursor(int cx, int cy); - -/* Changes cell's parameters in the internal back buffer at the specified - * position. - */ -SO_IMPORT void tb_put_cell(int x, int y, const struct tb_cell *cell); -SO_IMPORT void tb_change_cell(int x, int y, uint32_t ch, uint16_t fg, uint16_t bg); - -/* Copies the buffer from 'cells' at the specified position, assuming the - * buffer is a two-dimensional array of size ('w' x 'h'), represented as a - * one-dimensional buffer containing lines of cells starting from the top. - * - * (DEPRECATED: use tb_cell_buffer() instead and copy memory on your own) - */ -SO_IMPORT void tb_blit(int x, int y, int w, int h, const struct tb_cell *cells); - -/* Returns a pointer to internal cell back buffer. You can get its dimensions - * using tb_width() and tb_height() functions. The pointer stays valid as long - * as no tb_clear() and tb_present() calls are made. The buffer is - * one-dimensional buffer containing lines of cells starting from the top. - */ -SO_IMPORT struct tb_cell *tb_cell_buffer(void); - -#define TB_INPUT_CURRENT 0 /* 000 */ -#define TB_INPUT_ESC 1 /* 001 */ -#define TB_INPUT_ALT 2 /* 010 */ -#define TB_INPUT_MOUSE 4 /* 100 */ - -/* Sets the termbox input mode. Termbox has two input modes: - * 1. Esc input mode. - * When ESC sequence is in the buffer and it doesn't match any known - * ESC sequence => ESC means TB_KEY_ESC. - * 2. Alt input mode. - * When ESC sequence is in the buffer and it doesn't match any known - * sequence => ESC enables TB_MOD_ALT modifier for the next keyboard event. - * - * You can also apply TB_INPUT_MOUSE via bitwise OR operation to either of the - * modes (e.g. TB_INPUT_ESC | TB_INPUT_MOUSE). If none of the main two modes - * were set, but the mouse mode was, TB_INPUT_ESC mode is used. If for some - * reason you've decided to use (TB_INPUT_ESC | TB_INPUT_ALT) combination, it - * will behave as if only TB_INPUT_ESC was selected. - * - * If 'mode' is TB_INPUT_CURRENT, it returns the current input mode. - * - * Default termbox input mode is TB_INPUT_ESC. - */ -SO_IMPORT int tb_select_input_mode(int mode); - -#define TB_OUTPUT_CURRENT 0 -#define TB_OUTPUT_NORMAL 1 -#define TB_OUTPUT_256 2 -#define TB_OUTPUT_216 3 -#define TB_OUTPUT_GRAYSCALE 4 - -/* Sets the termbox output mode. Termbox has three output options: - * 1. TB_OUTPUT_NORMAL => [1..8] - * This mode provides 8 different colors: - * black, red, green, yellow, blue, magenta, cyan, white - * Shortcut: TB_BLACK, TB_RED, ... - * Attributes: TB_BOLD, TB_UNDERLINE, TB_REVERSE - * - * Example usage: - * tb_change_cell(x, y, '@', TB_BLACK | TB_BOLD, TB_RED); - * - * 2. TB_OUTPUT_256 => [0..256] - * In this mode you can leverage the 256 terminal mode: - * 0x00 - 0x07: the 8 colors as in TB_OUTPUT_NORMAL - * 0x08 - 0x0f: TB_* | TB_BOLD - * 0x10 - 0xe7: 216 different colors - * 0xe8 - 0xff: 24 different shades of grey - * - * Example usage: - * tb_change_cell(x, y, '@', 184, 240); - * tb_change_cell(x, y, '@', 0xb8, 0xf0); - * - * 3. TB_OUTPUT_216 => [0..216] - * This mode supports the 3rd range of the 256 mode only. - * But you don't need to provide an offset. - * - * 4. TB_OUTPUT_GRAYSCALE => [0..23] - * This mode supports the 4th range of the 256 mode only. - * But you dont need to provide an offset. - * - * Execute build/src/demo/output to see its impact on your terminal. - * - * If 'mode' is TB_OUTPUT_CURRENT, it returns the current output mode. - * - * Default termbox output mode is TB_OUTPUT_NORMAL. - */ -SO_IMPORT int tb_select_output_mode(int mode); - -/* Wait for an event up to 'timeout' milliseconds and fill the 'event' - * structure with it, when the event is available. Returns the type of the - * event (one of TB_EVENT_* constants) or -1 if there was an error or 0 in case - * there were no event during 'timeout' period. - */ -SO_IMPORT int tb_peek_event(struct tb_event *event, int timeout); - -/* Wait for an event forever and fill the 'event' structure with it, when the - * event is available. Returns the type of the event (one of TB_EVENT_* - * constants) or -1 if there was an error. - */ -SO_IMPORT int tb_poll_event(struct tb_event *event); - -/* Utility utf8 functions. */ -#define TB_EOF -1 -SO_IMPORT int tb_utf8_char_length(char c); -SO_IMPORT int tb_utf8_char_to_unicode(uint32_t *out, const char *c); -SO_IMPORT int tb_utf8_unicode_to_char(char *out, uint32_t c); - -#ifdef __cplusplus -} -#endif diff --git a/src/Termbox.hs b/src/Termbox.hs --- a/src/Termbox.hs +++ b/src/Termbox.hs @@ -1,71 +1,129 @@ -{-# LANGUAGE PatternSynonyms #-} - -- | --- A @termbox@ program is typically constructed as an infinite loop that: -- --- 1. Renders a scene. --- 2. Polls for an event. +-- This module provides a high-level wrapper around @termbox@, a simple C library for writing text-based user +-- interfaces: -- --- For example, this progam simply displays the number of keys pressed, and --- quits on @Esc@: +-- This module is intended to be imported qualified. -- +-- ==== __👉 Quick start example__ +-- +-- This @termbox@ program displays the number of keys pressed. +-- -- @ +-- {-\# LANGUAGE DerivingStrategies \#-} +-- {-\# LANGUAGE DuplicateRecordFields \#-} +-- {-\# LANGUAGE ImportQualifiedPost \#-} -- {-\# LANGUAGE LambdaCase \#-} +-- {-\# LANGUAGE OverloadedRecordDot \#-} +-- {-\# LANGUAGE OverloadedStrings \#-} +-- {-\# LANGUAGE NoFieldSelectors \#-} -- --- import qualified Termbox +-- import Data.Foldable (fold) +-- import Data.Void (Void) +-- import Termbox qualified -- -- main :: IO () --- main = --- Termbox.'run' (\\_width _height render poll -> loop render poll 0) +-- main = do +-- result <- +-- Termbox.'run' +-- Termbox.'Program' +-- { initialize, +-- pollEvent, +-- handleEvent, +-- handleEventError, +-- render, +-- finished +-- } +-- case result of +-- Left err -> putStrLn ("Termbox program failed to initialize: " ++ show err) +-- Right state -> putStrLn ("Final state: " ++ show state) -- --- loop :: (Termbox.'Cells' -> Termbox.'Cursor' -> IO ()) -> IO Termbox.'Event' -> Int -> IO () --- loop render poll n = do --- render (string (show n)) Termbox.'NoCursor' +-- data MyState = MyState +-- { keysPressed :: Int, +-- pressedEsc :: Bool +-- } +-- deriving stock (Show) -- --- poll >>= \\case --- Termbox.'EventKey' Termbox.'KeyEsc' -> pure () --- _ -> loop render poll (n+1) +-- initialize :: Termbox.'Size' -> MyState +-- initialize _size = +-- MyState +-- { keysPressed = 0, +-- pressedEsc = False +-- } -- --- string :: Int -> Int -> String -> Termbox.'Cells' --- string col row = --- foldMap (\\(i, c) -> Termbox.'set' (col + i) row (Termbox.'Cell' c 0 0)) . zip [0..] --- @ +-- pollEvent :: Maybe (IO Void) +-- pollEvent = +-- Nothing -- --- Other termbox features include cell attributes (style, color), cursor --- display, and mouse click handling. +-- handleEvent :: MyState -> Termbox.'Event' Void -> IO MyState +-- handleEvent state = \\case +-- Termbox.'EventKey' key -> +-- pure +-- MyState +-- { keysPressed = state.keysPressed + 1, +-- pressedEsc = +-- case key of +-- Termbox.'KeyEsc' -> True +-- _ -> False +-- } +-- _ -> pure state -- --- This module is intended to be imported qualified. +-- handleEventError :: MyState -> IO MyState +-- handleEventError state = +-- pure state +-- +-- render :: MyState -> Termbox.'Scene' +-- render state = +-- fold +-- [ string +-- Termbox.'Pos' {row = 2, col = 4} +-- ("Number of keys pressed: " ++ map Termbox.'char' (show state.keysPressed)) +-- , string +-- Termbox.'Pos' {row = 4, col = 4} +-- ("Press " ++ map (Termbox.'bold' . Termbox.'char') "Esc" ++ " to quit.") +-- ] +-- +-- finished :: MyState -> Bool +-- finished state = +-- state.pressedEsc +-- +-- string :: Termbox.'Pos' -> [Termbox.'Cell'] -> Termbox.'Scene' +-- string pos cells = +-- foldMap +-- (\\(i, cell) -> +-- Termbox.'cell' +-- Termbox.'Pos' {row = pos.row, col = pos.col + i} +-- cell) +-- (zip [0 ..] cells) +-- @ module Termbox - ( -- * Initialization + ( -- * Termbox + Program (..), run, InitError (..), -- * Terminal contents - set, - Cells, - Cell (..), - Cursor (..), - -- * 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 (..), + -- ** Scene + Scene, + cell, + fill, + cursor, - -- * Attributes - Attr, - black, + -- ** Cell + Cell, + char, + fg, + bg, + bold, + underline, + blink, + + -- ** Colors + Color, + + -- *** Basic colors + defaultColor, red, green, yellow, @@ -73,33 +131,63 @@ magenta, cyan, white, - bold, - underline, - reverse, + bright, + + -- *** 216 miscellaneous colors + color, + + -- *** 24 monochrome colors + gray, + + -- * Event handling + Event (..), + Key + ( .., + KeyCtrlH, + KeyCtrlLsqBracket, + KeyCtrl2, + KeyCtrl3, + KeyCtrl4, + KeyCtrl5, + KeyCtrl7, + KeyCtrlM, + KeyCtrlI, + KeyCtrlUnderscore + ), + Mouse (..), + + -- * Miscellaneous types + Pos (..), + posUp, + posDown, + posLeft, + posRight, + Size (..), ) where +import Control.Concurrent.MVar import Control.Exception -import Data.Semigroup (Semigroup (..)) -import Termbox.Attr - ( Attr, - black, +import Control.Monad (forever) +import qualified Ki +import qualified Termbox.Bindings.Hs +import Termbox.Internal.Cell (Cell, bg, blink, bold, char, fg, underline) +import Termbox.Internal.Color + ( Color, blue, - bold, + bright, + color, cyan, + defaultColor, + gray, 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 +import Termbox.Internal.Event (Event (..), poll) +import Termbox.Internal.Key ( Key (..), pattern KeyCtrl2, pattern KeyCtrl3, @@ -112,73 +200,106 @@ pattern KeyCtrlM, pattern KeyCtrlUnderscore, ) -import Termbox.Mouse (Mouse (..)) -import Prelude hiding (reverse) - --- | A cursor. -data Cursor - = -- | Column, then row - Cursor !Int !Int - | NoCursor - --- $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. +import Termbox.Internal.Mouse + ( Mouse + ( MouseLeft, + MouseMiddle, + MouseRelease, + MouseRight, + MouseWheelDown, + MouseWheelUp + ), + ) +import Termbox.Internal.Pos (Pos (..), posDown, posLeft, posRight, posUp) +import Termbox.Internal.Scene (Scene, cell, cursor, drawScene, fill) +import Termbox.Internal.Size (Size (..)) --- | Termbox initialization errors. +-- | @termbox@ initialization errors. data InitError = FailedToOpenTTY | PipeTrapError | UnsupportedTerminal - deriving (Show) + deriving stock (Show) instance Exception InitError --- | Run a @termbox@ program and restore the terminal state afterwards. --- --- The function provided to @run@ is provided: --- --- * The initial terminal width --- * The initial terminal height --- * An action that renders a scene --- * An action that polls for an event indefinitely +-- | A @termbox@ program, parameterized by state __@s@__. +data Program s = forall e. Program + { -- | The initial state, given the initial terminal size. + initialize :: Size -> s, + -- | Poll for a user event. Every value that this @IO@ action returns is provided to @handleEvent@. + pollEvent :: Maybe (IO e), + -- | Handle an event. + handleEvent :: s -> Event e -> IO s, + -- | Render the current state. + render :: s -> Scene, + -- | Is the current state finished? + finished :: s -> Bool + } + +-- | Run a @termbox@ program. -- --- /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 +-- Either returns immediately with an 'InitError', or once the program state is finished with the final state. +run :: Program s -> IO (Either InitError s) +run program = do + mask \unmask -> + Termbox.Bindings.Hs.tb_init >>= \case + Left err -> + (pure . Left) case err of + Termbox.Bindings.Hs.TB_EFAILED_TO_OPEN_TTY -> FailedToOpenTTY + Termbox.Bindings.Hs.TB_EPIPE_TRAP_ERROR -> PipeTrapError + Termbox.Bindings.Hs.TB_EUNSUPPORTED_TERMINAL -> UnsupportedTerminal + Right () -> do + result <- unmask (runProgram program) `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) + pure (Right result) --- | 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 +runProgram :: Program s -> IO s +runProgram Program {initialize, pollEvent, handleEvent, render, finished} = do + _ <- Termbox.Bindings.Hs.tb_select_input_mode Termbox.Bindings.Hs.TB_INPUT_MOUSE + _ <- Termbox.Bindings.Hs.tb_select_output_mode Termbox.Bindings.Hs.TB_OUTPUT_256 + width <- Termbox.Bindings.Hs.tb_width + height <- Termbox.Bindings.Hs.tb_height + let state0 = + initialize Size {width, height} + + let loop0 doPoll = + let loop s0 = + if finished s0 + then pure s0 + else do + drawScene (render s0) + event <- doPoll + s1 <- handleEvent s0 event + loop s1 + in loop + + case pollEvent of + Nothing -> loop0 pollIgnoringErrors state0 + Just pollEvent1 -> do + eventVar <- newEmptyMVar + + Ki.scoped \scope -> do + Ki.fork_ scope do + forever do + event <- pollEvent1 + putMVar eventVar (EventUser event) + + Ki.fork_ scope do + forever do + event <- pollIgnoringErrors + putMVar eventVar event + + loop0 (takeMVar eventVar) state0 + +pollIgnoringErrors :: IO (Event e) +pollIgnoringErrors = + poll >>= \case + Left () -> pollIgnoringErrors + Right event -> pure event + shutdown :: IO () shutdown = do - _ <- tb_select_output_mode tB_OUTPUT_NORMAL - tb_shutdown + _ <- Termbox.Bindings.Hs.tb_select_output_mode Termbox.Bindings.Hs.TB_OUTPUT_NORMAL + Termbox.Bindings.Hs.tb_shutdown diff --git a/src/Termbox/Attr.hs b/src/Termbox/Attr.hs deleted file mode 100644 --- a/src/Termbox/Attr.hs +++ /dev/null @@ -1,124 +0,0 @@ -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 deleted file mode 100644 --- a/src/Termbox/Cell.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Termbox/Cells.hs +++ /dev/null @@ -1,21 +0,0 @@ -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 deleted file mode 100644 --- a/src/Termbox/Event.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# 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.hs b/src/Termbox/Internal.hs deleted file mode 100644 --- a/src/Termbox/Internal.hs +++ /dev/null @@ -1,350 +0,0 @@ -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/Internal/Cell.hs b/src/Termbox/Internal/Cell.hs new file mode 100644 --- /dev/null +++ b/src/Termbox/Internal/Cell.hs @@ -0,0 +1,115 @@ +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 + = CellEmpty + | 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 + CellEmpty -> pure () + 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 = + case wcwidth (charToCWchar ch) of + 1 -> CellFg ch Termbox.Bindings.Hs.TB_DEFAULT + _ -> CellEmpty + +-- | Set the foreground color of a cell. +fg :: Color -> Cell -> Cell +fg (Color color) = \case + CellEmpty -> CellEmpty + 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 + CellEmpty -> CellEmpty + 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 + CellEmpty -> CellEmpty + 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 + CellEmpty -> CellEmpty + 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 + CellEmpty -> CellEmpty + 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 new file mode 100644 --- /dev/null +++ b/src/Termbox/Internal/Color.hs @@ -0,0 +1,85 @@ +module Termbox.Internal.Color + ( Color (..), + defaultColor, + red, + green, + yellow, + blue, + magenta, + cyan, + white, + bright, + color, + gray, + ) +where + +import Data.Coerce (coerce) +import Data.Word (Word16) +import qualified Termbox.Bindings.Hs + +-- | A color. +-- +-- There are three classes of colors: +-- +-- * Basic named colors and their bright variants, such as 'red' and 'bright' 'blue'. +-- * 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 + +defaultColor :: Color +defaultColor = + Color 0 + +red :: Color +red = + Color 1 + +green :: Color +green = + Color 2 + +yellow :: Color +yellow = + Color 3 + +blue :: Color +blue = + Color 4 + +magenta :: Color +magenta = + Color 5 + +cyan :: Color +cyan = + Color 6 + +white :: Color +white = + Color 7 + +-- | Make a basic color brighter. +bright :: Color -> Color +bright = + coerce bright_ + +bright_ :: Termbox.Bindings.Hs.Tb_color -> Termbox.Bindings.Hs.Tb_color +bright_ c + | c <= 7 = c + 8 + | otherwise = c + +-- | A miscellaneous color. +-- +-- Valid values are in the range @[0, 215]@; values outside of this range are clamped. +color :: Int -> Color +color = + coerce (fromIntegral @Int @Word16 . (+ 16) . max 0 . min 215) + +-- | A monochrome color; black is 0 and white is 23. +-- +-- Valid values are in the range @[0, 23]@; values outside of this range are clamped. +gray :: Int -> Color +gray = + coerce (fromIntegral @Int @Word16 . (+ 232) . max 0 . min 23) diff --git a/src/Termbox/Internal/Event.hs b/src/Termbox/Internal/Event.hs new file mode 100644 --- /dev/null +++ b/src/Termbox/Internal/Event.hs @@ -0,0 +1,61 @@ +module Termbox.Internal.Event + ( Event (..), + poll, + ) +where + +import Data.Int (Int32) +import GHC.Generics (Generic) +import qualified Termbox.Bindings.Hs +import Termbox.Internal.Key (Key (KeyChar), parseKey) +import Termbox.Internal.Mouse (Mouse (Mouse)) +import Termbox.Internal.Pos (Pos (..)) +import Termbox.Internal.Size (Size (..)) +import Prelude hiding (mod) + +-- | An input event. +data Event e + = -- | Key event + EventKey !Key + | -- | Resize event + EventResize !Size + | -- | Mouse event + EventMouse !Mouse !Pos + | -- | User event + EventUser !e + deriving stock (Eq, Generic, Show) + +-- Block until an Event arrives. +poll :: IO (Either () (Event e)) +poll = do + result <- Termbox.Bindings.Hs.tb_poll_event + pure (parseEvent <$> result) + +-- Parse an Event from a TbEvent. +parseEvent :: Termbox.Bindings.Hs.Tb_event -> Event e +parseEvent + Termbox.Bindings.Hs.Tb_event + { Termbox.Bindings.Hs.type_, + Termbox.Bindings.Hs.mod = _, + Termbox.Bindings.Hs.key, + Termbox.Bindings.Hs.ch, + Termbox.Bindings.Hs.w, + Termbox.Bindings.Hs.h, + Termbox.Bindings.Hs.x, + Termbox.Bindings.Hs.y + } = + case type_ of + Termbox.Bindings.Hs.TB_EVENT_KEY -> EventKey (if ch == '\0' then parseKey key else KeyChar ch) + Termbox.Bindings.Hs.TB_EVENT_RESIZE -> + EventResize + Size + { width = fromIntegral @Int32 @Int w, + height = fromIntegral @Int32 @Int h + } + Termbox.Bindings.Hs.TB_EVENT_MOUSE -> + EventMouse + (Mouse key) + Pos + { row = fromIntegral @Int32 @Int y, + col = fromIntegral @Int32 @Int x + } diff --git a/src/Termbox/Internal/Key.hs b/src/Termbox/Internal/Key.hs new file mode 100644 --- /dev/null +++ b/src/Termbox/Internal/Key.hs @@ -0,0 +1,182 @@ +module Termbox.Internal.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 qualified Termbox.Bindings.Hs + +-- | A key event. +-- +-- Some distinct key sequences map to the same key event. For example, to a @termbox@ program, @Enter@ is +-- indistinguishable from @Ctrl+M@. Pattern synonyms below are provided for an alternate syntax in these cases, if +-- desired. +data Key + = KeyChar Char + | KeyArrowDown + | KeyArrowLeft + | KeyArrowRight + | KeyArrowUp + | KeyBackspace + | -- | Also 'KeyCtrlH' + KeyCtrlBackspace + | KeyCtrl6 + | KeyCtrl8 + | KeyCtrlA + | KeyCtrlB + | -- | Also 'KeyCtrl4' + KeyCtrlBackslash + | KeyCtrlC + | KeyCtrlD + | KeyCtrlE + | KeyCtrlF + | KeyCtrlG + | KeyCtrlJ + | KeyCtrlK + | KeyCtrlL + | KeyCtrlN + | KeyCtrlO + | KeyCtrlP + | KeyCtrlQ + | KeyCtrlR + | -- | Also 'KeyCtrl5' + KeyCtrlRsqBracket + | KeyCtrlS + | -- | Also 'KeyCtrl7', 'KeyCtrlUnderscore' + KeyCtrlSlash + | -- | Also 'KeyCtrl2' + KeyCtrlTilde + | KeyCtrlT + | KeyCtrlU + | KeyCtrlV + | KeyCtrlW + | KeyCtrlX + | KeyCtrlY + | KeyCtrlZ + | KeyDelete + | KeyEnd + | -- | Also 'KeyCtrlM' + KeyEnter + | -- | Also 'KeyCtrlLsqBracket', 'KeyCtrl3' + KeyEsc + | KeyF1 + | KeyF10 + | KeyF11 + | KeyF12 + | KeyF2 + | KeyF3 + | KeyF4 + | KeyF5 + | KeyF6 + | KeyF7 + | KeyF8 + | KeyF9 + | KeyHome + | KeyInsert + | KeyPageDn + | KeyPageUp + | KeySpace + | -- | Also 'KeyCtrlI' + KeyTab + deriving stock (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 :: Termbox.Bindings.Hs.Tb_key -> Key +parseKey = \case + Termbox.Bindings.Hs.TB_KEY_ARROW_DOWN -> KeyArrowDown + Termbox.Bindings.Hs.TB_KEY_ARROW_LEFT -> KeyArrowLeft + Termbox.Bindings.Hs.TB_KEY_ARROW_RIGHT -> KeyArrowRight + Termbox.Bindings.Hs.TB_KEY_ARROW_UP -> KeyArrowUp + Termbox.Bindings.Hs.TB_KEY_BACKSPACE -> KeyBackspace + Termbox.Bindings.Hs.TB_KEY_CTRL_TILDE -> KeyCtrlTilde + Termbox.Bindings.Hs.TB_KEY_CTRL_6 -> KeyCtrl6 + Termbox.Bindings.Hs.TB_KEY_CTRL_8 -> KeyCtrl8 + Termbox.Bindings.Hs.TB_KEY_CTRL_A -> KeyCtrlA + Termbox.Bindings.Hs.TB_KEY_CTRL_B -> KeyCtrlB + Termbox.Bindings.Hs.TB_KEY_CTRL_BACKSLASH -> KeyCtrlBackslash + Termbox.Bindings.Hs.TB_KEY_CTRL_C -> KeyCtrlC + Termbox.Bindings.Hs.TB_KEY_CTRL_D -> KeyCtrlD + Termbox.Bindings.Hs.TB_KEY_CTRL_E -> KeyCtrlE + Termbox.Bindings.Hs.TB_KEY_CTRL_F -> KeyCtrlF + Termbox.Bindings.Hs.TB_KEY_CTRL_G -> KeyCtrlG + Termbox.Bindings.Hs.TB_KEY_CTRL_H -> KeyCtrlBackspace + Termbox.Bindings.Hs.TB_KEY_CTRL_J -> KeyCtrlJ + Termbox.Bindings.Hs.TB_KEY_CTRL_K -> KeyCtrlK + Termbox.Bindings.Hs.TB_KEY_CTRL_L -> KeyCtrlL + Termbox.Bindings.Hs.TB_KEY_CTRL_N -> KeyCtrlN + Termbox.Bindings.Hs.TB_KEY_CTRL_O -> KeyCtrlO + Termbox.Bindings.Hs.TB_KEY_CTRL_P -> KeyCtrlP + Termbox.Bindings.Hs.TB_KEY_CTRL_Q -> KeyCtrlQ + Termbox.Bindings.Hs.TB_KEY_CTRL_R -> KeyCtrlR + Termbox.Bindings.Hs.TB_KEY_CTRL_RSQ_BRACKET -> KeyCtrlRsqBracket + Termbox.Bindings.Hs.TB_KEY_CTRL_S -> KeyCtrlS + Termbox.Bindings.Hs.TB_KEY_CTRL_SLASH -> KeyCtrlSlash + Termbox.Bindings.Hs.TB_KEY_CTRL_T -> KeyCtrlT + Termbox.Bindings.Hs.TB_KEY_CTRL_U -> KeyCtrlU + Termbox.Bindings.Hs.TB_KEY_CTRL_V -> KeyCtrlV + Termbox.Bindings.Hs.TB_KEY_CTRL_W -> KeyCtrlW + Termbox.Bindings.Hs.TB_KEY_CTRL_X -> KeyCtrlX + Termbox.Bindings.Hs.TB_KEY_CTRL_Y -> KeyCtrlY + Termbox.Bindings.Hs.TB_KEY_CTRL_Z -> KeyCtrlZ + Termbox.Bindings.Hs.TB_KEY_DELETE -> KeyDelete + Termbox.Bindings.Hs.TB_KEY_END -> KeyEnd + Termbox.Bindings.Hs.TB_KEY_ENTER -> KeyEnter + Termbox.Bindings.Hs.TB_KEY_ESC -> KeyEsc + Termbox.Bindings.Hs.TB_KEY_F1 -> KeyF1 + Termbox.Bindings.Hs.TB_KEY_F10 -> KeyF10 + Termbox.Bindings.Hs.TB_KEY_F11 -> KeyF11 + Termbox.Bindings.Hs.TB_KEY_F12 -> KeyF12 + Termbox.Bindings.Hs.TB_KEY_F2 -> KeyF2 + Termbox.Bindings.Hs.TB_KEY_F3 -> KeyF3 + Termbox.Bindings.Hs.TB_KEY_F4 -> KeyF4 + Termbox.Bindings.Hs.TB_KEY_F5 -> KeyF5 + Termbox.Bindings.Hs.TB_KEY_F6 -> KeyF6 + Termbox.Bindings.Hs.TB_KEY_F7 -> KeyF7 + Termbox.Bindings.Hs.TB_KEY_F8 -> KeyF8 + Termbox.Bindings.Hs.TB_KEY_F9 -> KeyF9 + Termbox.Bindings.Hs.TB_KEY_HOME -> KeyHome + Termbox.Bindings.Hs.TB_KEY_INSERT -> KeyInsert + Termbox.Bindings.Hs.TB_KEY_PGDN -> KeyPageDn + Termbox.Bindings.Hs.TB_KEY_PGUP -> KeyPageUp + Termbox.Bindings.Hs.TB_KEY_SPACE -> KeySpace + Termbox.Bindings.Hs.TB_KEY_TAB -> KeyTab + key -> error ("unknown key: " ++ show key) diff --git a/src/Termbox/Internal/Mouse.hs b/src/Termbox/Internal/Mouse.hs new file mode 100644 --- /dev/null +++ b/src/Termbox/Internal/Mouse.hs @@ -0,0 +1,48 @@ +module Termbox.Internal.Mouse + ( Mouse + ( Mouse, + MouseLeft, + MouseMiddle, + MouseRelease, + MouseRight, + MouseWheelUp, + MouseWheelDown + ), + ) +where + +import qualified Termbox.Bindings.Hs + +-- | A mouse event. +newtype Mouse + = Mouse Termbox.Bindings.Hs.Tb_key + deriving stock (Eq, Ord) + +instance Show Mouse where + show = \case + MouseLeft -> "MouseLeft" + MouseMiddle -> "MouseMiddle" + MouseRelease -> "MouseRelease" + MouseRight -> "MouseRight" + MouseWheelDown -> "MouseWheelDown" + MouseWheelUp -> "MouseWheelUp" + +pattern MouseLeft :: Mouse +pattern MouseLeft = Mouse Termbox.Bindings.Hs.TB_KEY_MOUSE_LEFT + +pattern MouseMiddle :: Mouse +pattern MouseMiddle = Mouse Termbox.Bindings.Hs.TB_KEY_MOUSE_MIDDLE + +pattern MouseRelease :: Mouse +pattern MouseRelease = Mouse Termbox.Bindings.Hs.TB_KEY_MOUSE_RELEASE + +pattern MouseRight :: Mouse +pattern MouseRight = Mouse Termbox.Bindings.Hs.TB_KEY_MOUSE_RIGHT + +pattern MouseWheelDown :: Mouse +pattern MouseWheelDown = Mouse Termbox.Bindings.Hs.TB_KEY_MOUSE_WHEEL_DOWN + +pattern MouseWheelUp :: Mouse +pattern MouseWheelUp = Mouse Termbox.Bindings.Hs.TB_KEY_MOUSE_WHEEL_UP + +{-# COMPLETE MouseLeft, MouseMiddle, MouseRelease, MouseRight, MouseWheelDown, MouseWheelUp #-} diff --git a/src/Termbox/Internal/Pos.hs b/src/Termbox/Internal/Pos.hs new file mode 100644 --- /dev/null +++ b/src/Termbox/Internal/Pos.hs @@ -0,0 +1,37 @@ +module Termbox.Internal.Pos + ( Pos (..), + posUp, + posDown, + posLeft, + posRight, + ) +where + +import GHC.Generics (Generic) + +-- | A terminal position. +data Pos = Pos + { row :: {-# UNPACK #-} !Int, + col :: {-# UNPACK #-} !Int + } + deriving stock (Eq, Generic, Ord, Show) + +-- | Move a position up. +posUp :: Int -> Pos -> Pos +posUp n (Pos row col) = + Pos (row - n) col + +-- | Move a position down. +posDown :: Int -> Pos -> Pos +posDown n (Pos row col) = + Pos (row + n) col + +-- | Move a position left. +posLeft :: Int -> Pos -> Pos +posLeft n (Pos row col) = + Pos row (col - n) + +-- | Move a position right. +posRight :: Int -> Pos -> Pos +posRight n (Pos row col) = + Pos row (col + n) diff --git a/src/Termbox/Internal/Scene.hs b/src/Termbox/Internal/Scene.hs new file mode 100644 --- /dev/null +++ b/src/Termbox/Internal/Scene.hs @@ -0,0 +1,71 @@ +module Termbox.Internal.Scene + ( Scene, + drawScene, + cell, + fill, + cursor, + ) +where + +import qualified Termbox.Bindings.Hs +import Termbox.Internal.Cell (Cell, drawCell) +import Termbox.Internal.Color (Color (Color)) +import Termbox.Internal.Pos (Pos (..)) + +-- | A scene. +-- +-- * Set individual cells with 'cell'. +-- * Set the background fill color with 'fill'. +-- * Set the cursor position with 'cursor'. +-- * Combine scenes together with @<>@. +data Scene = Scene + { sceneFill :: Maybe Termbox.Bindings.Hs.Tb_color, + sceneDraw :: Termbox.Bindings.Hs.Tb_color -> IO () + } + +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 + } + +-- Draw a scene. +drawScene :: Scene -> IO () +drawScene 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 + +-- | Set the background fill color. +fill :: Color -> Scene +fill (Color color) = + mempty {sceneFill = Just color} + +-- | Set a single cell. +cell :: Pos -> Cell -> Scene +cell Pos {col, row} img = + mempty {sceneDraw = \bg -> drawCell bg col row img} + +-- | Set the cursor position. +cursor :: Pos -> Scene +cursor Pos {col, row} = + mempty {sceneDraw = \_ -> Termbox.Bindings.Hs.tb_set_cursor (Just (col, row))} diff --git a/src/Termbox/Internal/Size.hs b/src/Termbox/Internal/Size.hs new file mode 100644 --- /dev/null +++ b/src/Termbox/Internal/Size.hs @@ -0,0 +1,13 @@ +module Termbox.Internal.Size + ( Size (..), + ) +where + +import GHC.Generics (Generic) + +-- | A terminal size. +data Size = Size + { width :: {-# UNPACK #-} !Int, + height :: {-# UNPACK #-} !Int + } + deriving stock (Eq, Generic, Ord, Show) diff --git a/src/Termbox/Key.hs b/src/Termbox/Key.hs deleted file mode 100644 --- a/src/Termbox/Key.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Termbox/Mouse.hs +++ /dev/null @@ -1,28 +0,0 @@ -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,33 +1,33 @@ cabal-version: 2.4 -name: termbox -version: 0.3.0 category: User Interfaces +author: Mitchell Rosen +bug-reports: https://github.com/termbox/termbox-haskell/issues +build-type: Simple +copyright: (c) 2018-2022, Mitchell Rosen description: - This package provides a thin wrapper around @termbox v1.1.2@, a simple C + This package provides a high-level wrapper around @termbox@, a simple C 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. -synopsis: termbox bindings -author: Mitchell Rosen -maintainer: Mitchell Rosen -homepage: https://github.com/mitchellwrosen/termbox -bug-reports: https://github.com/mitchellwrosen/termbox/issues -copyright: (c) 2018-2020, Mitchell Rosen -license: BSD-3-Clause + See also: + . + * @@ for lower-level bindings. + * @@ for even lower-level bindings. +homepage: https://github.com/termbox/termbox-haskell license-file: LICENSE -build-type: Simple +license: BSD-3-Clause +maintainer: Mitchell Rosen +name: termbox +synopsis: termbox +tested-with: GHC == 9.0.2, GHC == 9.2.4, GHC == 9.4.2 +version: 1.0.0 extra-source-files: - cbits/LICENSE CHANGELOG.md - include/termbox.h - README.md source-repository head type: git - location: git://github.com/mitchellwrosen/termbox.git + location: git://github.com/termbox/termbox-haskell.git flag build-examples default: False @@ -35,12 +35,28 @@ common component default-extensions: + BlockArguments + CApiFFI + DeriveAnyClass + DeriveFunctor + DeriveGeneric + DerivingStrategies + DerivingVia + DuplicateRecordFields + ExistentialQuantification + FlexibleInstances GeneralizedNewtypeDeriving InstanceSigs LambdaCase + NamedFieldPuns + NumericUnderscores + OverloadedStrings + PatternSynonyms + TypeApplications default-language: Haskell2010 ghc-options: -Weverything + -Wno-all-missed-specialisations -Wno-implicit-prelude -Wno-missing-import-lists -Wno-missing-local-signatures @@ -51,35 +67,38 @@ ghc-options: -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module + if impl(ghc >= 9.2) + ghc-options: + -Wno-missing-kind-signatures 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 + build-depends: + base ^>= 4.13 || ^>= 4.14 || ^>= 4.15 || ^>= 4.16 || ^>= 4.17, + termbox-bindings-hs ^>= 0.1, + ki ^>= 1.0, + exposed-modules: Termbox hs-source-dirs: src - include-dirs: include other-modules: - Termbox.Attr - Termbox.Cell - Termbox.Cells - Termbox.Event - Termbox.Key - Termbox.Mouse + Termbox.Internal.Cell + Termbox.Internal.Color + Termbox.Internal.Event + Termbox.Internal.Key + Termbox.Internal.Mouse + Termbox.Internal.Pos + Termbox.Internal.Size + Termbox.Internal.Scene -executable termbox-example-colors +executable termbox-example-demo import: component if !flag(build-examples) buildable: False build-depends: base, + ki ^>= 1.0, termbox, ghc-options: -rtsopts -threaded hs-source-dirs: examples - main-is: Colors.hs + main-is: Demo.hs