├── .github └── workflows │ └── main.yml ├── .gitignore ├── ChangeLog ├── LICENSE ├── README.md ├── Setup.hs ├── TODO ├── UI └── HSCurses │ ├── CWString.hsc │ ├── Curses.hsc │ ├── CursesHelper.hs │ ├── IConv.hsc │ ├── Logging.hs │ └── Widgets.hs ├── boring ├── cabal.project ├── cabal.project.ci ├── cbits ├── HSCurses.h ├── HSCursesUtils.c ├── HSCursesUtils.h └── config.h.in ├── configure ├── configure.ac ├── example ├── ContactManager.hs ├── README.md ├── contacts └── contacts2 ├── fourmolu.yaml ├── hscurses.buildinfo.in ├── hscurses.cabal └── tests ├── key-test └── KeyTest.hs └── widget-test ├── EditTest.hs ├── TableTest.hs └── TextTest.hs /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | on: [push] 2 | name: build 3 | 4 | jobs: 5 | build: 6 | strategy: 7 | matrix: 8 | ghc: ['8.4', '8.6', '8.8', '8.10', '9.4', '9.6', '9.8', '9.10', '9.12'] 9 | os: [ubuntu-latest] 10 | name: GHC ${{ matrix.ghc }} / ${{ matrix.os }} 11 | runs-on: ${{ matrix.os }} 12 | steps: 13 | - uses: actions/checkout@v4 14 | - uses: haskell-actions/setup@v2 15 | with: 16 | ghc-version: ${{ matrix.ghc }} 17 | cabal-version: 'latest' 18 | cabal-update: true 19 | - run: cabal build --project-file=cabal.project.ci -f examples 20 | - run: cabal haddock all --disable-documentation 21 | 22 | macos-build: 23 | name: GHC 9.10 / macOS 24 | runs-on: macos-latest 25 | steps: 26 | - uses: actions/checkout@v4 27 | - uses: haskell-actions/setup@v2 28 | with: 29 | ghc-version: '9.10' 30 | cabal-version: 'latest' 31 | cabal-update: true 32 | - run: cabal build --project-file=cabal.project.ci -f examples 33 | - run: cabal haddock all --disable-documentation 34 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .hscurses.log 2 | autom4te.cache 3 | dist 4 | dist-newstyle 5 | cbits/config.h 6 | config.log 7 | config.status 8 | hscurses.buildinfo 9 | *.o 10 | *.hi 11 | cabal-dev 12 | .cabal-sandbox 13 | cabal.sandbox.config 14 | cabal.project.local 15 | -------------------------------------------------------------------------------- /ChangeLog: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skogsbaer/hscurses/3250af06a1ada9a180e28f4b1e499ee19d5633cf/ChangeLog -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 2.1, February 1999 3 | 4 | Copyright (C) 1991, 1999 Free Software Foundation, Inc. 5 | 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 6 | Everyone is permitted to copy and distribute verbatim copies 7 | of this license document, but changing it is not allowed. 8 | 9 | [This is the first released version of the Lesser GPL. It also counts 10 | as the successor of the GNU Library Public License, version 2, hence 11 | the version number 2.1.] 12 | 13 | Preamble 14 | 15 | The licenses for most software are designed to take away your 16 | freedom to share and change it. By contrast, the GNU General Public 17 | Licenses are intended to guarantee your freedom to share and change 18 | free software--to make sure the software is free for all its users. 19 | 20 | This license, the Lesser General Public License, applies to some 21 | specially designated software packages--typically libraries--of the 22 | Free Software Foundation and other authors who decide to use it. You 23 | can use it too, but we suggest you first think carefully about whether 24 | this license or the ordinary General Public License is the better 25 | strategy to use in any particular case, based on the explanations below. 26 | 27 | When we speak of free software, we are referring to freedom of use, 28 | not price. Our General Public Licenses are designed to make sure that 29 | you have the freedom to distribute copies of free software (and charge 30 | for this service if you wish); that you receive source code or can get 31 | it if you want it; that you can change the software and use pieces of 32 | it in new free programs; and that you are informed that you can do 33 | these things. 34 | 35 | To protect your rights, we need to make restrictions that forbid 36 | distributors to deny you these rights or to ask you to surrender these 37 | rights. These restrictions translate to certain responsibilities for 38 | you if you distribute copies of the library or if you modify it. 39 | 40 | For example, if you distribute copies of the library, whether gratis 41 | or for a fee, you must give the recipients all the rights that we gave 42 | you. You must make sure that they, too, receive or can get the source 43 | code. If you link other code with the library, you must provide 44 | complete object files to the recipients, so that they can relink them 45 | with the library after making changes to the library and recompiling 46 | it. And you must show them these terms so they know their rights. 47 | 48 | We protect your rights with a two-step method: (1) we copyright the 49 | library, and (2) we offer you this license, which gives you legal 50 | permission to copy, distribute and/or modify the library. 51 | 52 | To protect each distributor, we want to make it very clear that 53 | there is no warranty for the free library. Also, if the library is 54 | modified by someone else and passed on, the recipients should know 55 | that what they have is not the original version, so that the original 56 | author's reputation will not be affected by problems that might be 57 | introduced by others. 58 | 59 | Finally, software patents pose a constant threat to the existence of 60 | any free program. We wish to make sure that a company cannot 61 | effectively restrict the users of a free program by obtaining a 62 | restrictive license from a patent holder. Therefore, we insist that 63 | any patent license obtained for a version of the library must be 64 | consistent with the full freedom of use specified in this license. 65 | 66 | Most GNU software, including some libraries, is covered by the 67 | ordinary GNU General Public License. This license, the GNU Lesser 68 | General Public License, applies to certain designated libraries, and 69 | is quite different from the ordinary General Public License. We use 70 | this license for certain libraries in order to permit linking those 71 | libraries into non-free programs. 72 | 73 | When a program is linked with a library, whether statically or using 74 | a shared library, the combination of the two is legally speaking a 75 | combined work, a derivative of the original library. The ordinary 76 | General Public License therefore permits such linking only if the 77 | entire combination fits its criteria of freedom. The Lesser General 78 | Public License permits more lax criteria for linking other code with 79 | the library. 80 | 81 | We call this license the "Lesser" General Public License because it 82 | does Less to protect the user's freedom than the ordinary General 83 | Public License. It also provides other free software developers Less 84 | of an advantage over competing non-free programs. These disadvantages 85 | are the reason we use the ordinary General Public License for many 86 | libraries. However, the Lesser license provides advantages in certain 87 | special circumstances. 88 | 89 | For example, on rare occasions, there may be a special need to 90 | encourage the widest possible use of a certain library, so that it becomes 91 | a de-facto standard. To achieve this, non-free programs must be 92 | allowed to use the library. A more frequent case is that a free 93 | library does the same job as widely used non-free libraries. In this 94 | case, there is little to gain by limiting the free library to free 95 | software only, so we use the Lesser General Public License. 96 | 97 | In other cases, permission to use a particular library in non-free 98 | programs enables a greater number of people to use a large body of 99 | free software. For example, permission to use the GNU C Library in 100 | non-free programs enables many more people to use the whole GNU 101 | operating system, as well as its variant, the GNU/Linux operating 102 | system. 103 | 104 | Although the Lesser General Public License is Less protective of the 105 | users' freedom, it does ensure that the user of a program that is 106 | linked with the Library has the freedom and the wherewithal to run 107 | that program using a modified version of the Library. 108 | 109 | The precise terms and conditions for copying, distribution and 110 | modification follow. Pay close attention to the difference between a 111 | "work based on the library" and a "work that uses the library". The 112 | former contains code derived from the library, whereas the latter must 113 | be combined with the library in order to run. 114 | 115 | GNU LESSER GENERAL PUBLIC LICENSE 116 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 117 | 118 | 0. This License Agreement applies to any software library or other 119 | program which contains a notice placed by the copyright holder or 120 | other authorized party saying it may be distributed under the terms of 121 | this Lesser General Public License (also called "this License"). 122 | Each licensee is addressed as "you". 123 | 124 | A "library" means a collection of software functions and/or data 125 | prepared so as to be conveniently linked with application programs 126 | (which use some of those functions and data) to form executables. 127 | 128 | The "Library", below, refers to any such software library or work 129 | which has been distributed under these terms. A "work based on the 130 | Library" means either the Library or any derivative work under 131 | copyright law: that is to say, a work containing the Library or a 132 | portion of it, either verbatim or with modifications and/or translated 133 | straightforwardly into another language. (Hereinafter, translation is 134 | included without limitation in the term "modification".) 135 | 136 | "Source code" for a work means the preferred form of the work for 137 | making modifications to it. For a library, complete source code means 138 | all the source code for all modules it contains, plus any associated 139 | interface definition files, plus the scripts used to control compilation 140 | and installation of the library. 141 | 142 | Activities other than copying, distribution and modification are not 143 | covered by this License; they are outside its scope. The act of 144 | running a program using the Library is not restricted, and output from 145 | such a program is covered only if its contents constitute a work based 146 | on the Library (independent of the use of the Library in a tool for 147 | writing it). Whether that is true depends on what the Library does 148 | and what the program that uses the Library does. 149 | 150 | 1. You may copy and distribute verbatim copies of the Library's 151 | complete source code as you receive it, in any medium, provided that 152 | you conspicuously and appropriately publish on each copy an 153 | appropriate copyright notice and disclaimer of warranty; keep intact 154 | all the notices that refer to this License and to the absence of any 155 | warranty; and distribute a copy of this License along with the 156 | Library. 157 | 158 | You may charge a fee for the physical act of transferring a copy, 159 | and you may at your option offer warranty protection in exchange for a 160 | fee. 161 | 162 | 2. You may modify your copy or copies of the Library or any portion 163 | of it, thus forming a work based on the Library, and copy and 164 | distribute such modifications or work under the terms of Section 1 165 | above, provided that you also meet all of these conditions: 166 | 167 | a) The modified work must itself be a software library. 168 | 169 | b) You must cause the files modified to carry prominent notices 170 | stating that you changed the files and the date of any change. 171 | 172 | c) You must cause the whole of the work to be licensed at no 173 | charge to all third parties under the terms of this License. 174 | 175 | d) If a facility in the modified Library refers to a function or a 176 | table of data to be supplied by an application program that uses 177 | the facility, other than as an argument passed when the facility 178 | is invoked, then you must make a good faith effort to ensure that, 179 | in the event an application does not supply such function or 180 | table, the facility still operates, and performs whatever part of 181 | its purpose remains meaningful. 182 | 183 | (For example, a function in a library to compute square roots has 184 | a purpose that is entirely well-defined independent of the 185 | application. Therefore, Subsection 2d requires that any 186 | application-supplied function or table used by this function must 187 | be optional: if the application does not supply it, the square 188 | root function must still compute square roots.) 189 | 190 | These requirements apply to the modified work as a whole. If 191 | identifiable sections of that work are not derived from the Library, 192 | and can be reasonably considered independent and separate works in 193 | themselves, then this License, and its terms, do not apply to those 194 | sections when you distribute them as separate works. But when you 195 | distribute the same sections as part of a whole which is a work based 196 | on the Library, the distribution of the whole must be on the terms of 197 | this License, whose permissions for other licensees extend to the 198 | entire whole, and thus to each and every part regardless of who wrote 199 | it. 200 | 201 | Thus, it is not the intent of this section to claim rights or contest 202 | your rights to work written entirely by you; rather, the intent is to 203 | exercise the right to control the distribution of derivative or 204 | collective works based on the Library. 205 | 206 | In addition, mere aggregation of another work not based on the Library 207 | with the Library (or with a work based on the Library) on a volume of 208 | a storage or distribution medium does not bring the other work under 209 | the scope of this License. 210 | 211 | 3. You may opt to apply the terms of the ordinary GNU General Public 212 | License instead of this License to a given copy of the Library. To do 213 | this, you must alter all the notices that refer to this License, so 214 | that they refer to the ordinary GNU General Public License, version 2, 215 | instead of to this License. (If a newer version than version 2 of the 216 | ordinary GNU General Public License has appeared, then you can specify 217 | that version instead if you wish.) Do not make any other change in 218 | these notices. 219 | 220 | Once this change is made in a given copy, it is irreversible for 221 | that copy, so the ordinary GNU General Public License applies to all 222 | subsequent copies and derivative works made from that copy. 223 | 224 | This option is useful when you wish to copy part of the code of 225 | the Library into a program that is not a library. 226 | 227 | 4. You may copy and distribute the Library (or a portion or 228 | derivative of it, under Section 2) in object code or executable form 229 | under the terms of Sections 1 and 2 above provided that you accompany 230 | it with the complete corresponding machine-readable source code, which 231 | must be distributed under the terms of Sections 1 and 2 above on a 232 | medium customarily used for software interchange. 233 | 234 | If distribution of object code is made by offering access to copy 235 | from a designated place, then offering equivalent access to copy the 236 | source code from the same place satisfies the requirement to 237 | distribute the source code, even though third parties are not 238 | compelled to copy the source along with the object code. 239 | 240 | 5. A program that contains no derivative of any portion of the 241 | Library, but is designed to work with the Library by being compiled or 242 | linked with it, is called a "work that uses the Library". Such a 243 | work, in isolation, is not a derivative work of the Library, and 244 | therefore falls outside the scope of this License. 245 | 246 | However, linking a "work that uses the Library" with the Library 247 | creates an executable that is a derivative of the Library (because it 248 | contains portions of the Library), rather than a "work that uses the 249 | library". The executable is therefore covered by this License. 250 | Section 6 states terms for distribution of such executables. 251 | 252 | When a "work that uses the Library" uses material from a header file 253 | that is part of the Library, the object code for the work may be a 254 | derivative work of the Library even though the source code is not. 255 | Whether this is true is especially significant if the work can be 256 | linked without the Library, or if the work is itself a library. The 257 | threshold for this to be true is not precisely defined by law. 258 | 259 | If such an object file uses only numerical parameters, data 260 | structure layouts and accessors, and small macros and small inline 261 | functions (ten lines or less in length), then the use of the object 262 | file is unrestricted, regardless of whether it is legally a derivative 263 | work. (Executables containing this object code plus portions of the 264 | Library will still fall under Section 6.) 265 | 266 | Otherwise, if the work is a derivative of the Library, you may 267 | distribute the object code for the work under the terms of Section 6. 268 | Any executables containing that work also fall under Section 6, 269 | whether or not they are linked directly with the Library itself. 270 | 271 | 6. As an exception to the Sections above, you may also combine or 272 | link a "work that uses the Library" with the Library to produce a 273 | work containing portions of the Library, and distribute that work 274 | under terms of your choice, provided that the terms permit 275 | modification of the work for the customer's own use and reverse 276 | engineering for debugging such modifications. 277 | 278 | You must give prominent notice with each copy of the work that the 279 | Library is used in it and that the Library and its use are covered by 280 | this License. You must supply a copy of this License. If the work 281 | during execution displays copyright notices, you must include the 282 | copyright notice for the Library among them, as well as a reference 283 | directing the user to the copy of this License. Also, you must do one 284 | of these things: 285 | 286 | a) Accompany the work with the complete corresponding 287 | machine-readable source code for the Library including whatever 288 | changes were used in the work (which must be distributed under 289 | Sections 1 and 2 above); and, if the work is an executable linked 290 | with the Library, with the complete machine-readable "work that 291 | uses the Library", as object code and/or source code, so that the 292 | user can modify the Library and then relink to produce a modified 293 | executable containing the modified Library. (It is understood 294 | that the user who changes the contents of definitions files in the 295 | Library will not necessarily be able to recompile the application 296 | to use the modified definitions.) 297 | 298 | b) Use a suitable shared library mechanism for linking with the 299 | Library. A suitable mechanism is one that (1) uses at run time a 300 | copy of the library already present on the user's computer system, 301 | rather than copying library functions into the executable, and (2) 302 | will operate properly with a modified version of the library, if 303 | the user installs one, as long as the modified version is 304 | interface-compatible with the version that the work was made with. 305 | 306 | c) Accompany the work with a written offer, valid for at 307 | least three years, to give the same user the materials 308 | specified in Subsection 6a, above, for a charge no more 309 | than the cost of performing this distribution. 310 | 311 | d) If distribution of the work is made by offering access to copy 312 | from a designated place, offer equivalent access to copy the above 313 | specified materials from the same place. 314 | 315 | e) Verify that the user has already received a copy of these 316 | materials or that you have already sent this user a copy. 317 | 318 | For an executable, the required form of the "work that uses the 319 | Library" must include any data and utility programs needed for 320 | reproducing the executable from it. However, as a special exception, 321 | the materials to be distributed need not include anything that is 322 | normally distributed (in either source or binary form) with the major 323 | components (compiler, kernel, and so on) of the operating system on 324 | which the executable runs, unless that component itself accompanies 325 | the executable. 326 | 327 | It may happen that this requirement contradicts the license 328 | restrictions of other proprietary libraries that do not normally 329 | accompany the operating system. Such a contradiction means you cannot 330 | use both them and the Library together in an executable that you 331 | distribute. 332 | 333 | 7. You may place library facilities that are a work based on the 334 | Library side-by-side in a single library together with other library 335 | facilities not covered by this License, and distribute such a combined 336 | library, provided that the separate distribution of the work based on 337 | the Library and of the other library facilities is otherwise 338 | permitted, and provided that you do these two things: 339 | 340 | a) Accompany the combined library with a copy of the same work 341 | based on the Library, uncombined with any other library 342 | facilities. This must be distributed under the terms of the 343 | Sections above. 344 | 345 | b) Give prominent notice with the combined library of the fact 346 | that part of it is a work based on the Library, and explaining 347 | where to find the accompanying uncombined form of the same work. 348 | 349 | 8. You may not copy, modify, sublicense, link with, or distribute 350 | the Library except as expressly provided under this License. Any 351 | attempt otherwise to copy, modify, sublicense, link with, or 352 | distribute the Library is void, and will automatically terminate your 353 | rights under this License. However, parties who have received copies, 354 | or rights, from you under this License will not have their licenses 355 | terminated so long as such parties remain in full compliance. 356 | 357 | 9. You are not required to accept this License, since you have not 358 | signed it. However, nothing else grants you permission to modify or 359 | distribute the Library or its derivative works. These actions are 360 | prohibited by law if you do not accept this License. Therefore, by 361 | modifying or distributing the Library (or any work based on the 362 | Library), you indicate your acceptance of this License to do so, and 363 | all its terms and conditions for copying, distributing or modifying 364 | the Library or works based on it. 365 | 366 | 10. Each time you redistribute the Library (or any work based on the 367 | Library), the recipient automatically receives a license from the 368 | original licensor to copy, distribute, link with or modify the Library 369 | subject to these terms and conditions. You may not impose any further 370 | restrictions on the recipients' exercise of the rights granted herein. 371 | You are not responsible for enforcing compliance by third parties with 372 | this License. 373 | 374 | 11. If, as a consequence of a court judgment or allegation of patent 375 | infringement or for any other reason (not limited to patent issues), 376 | conditions are imposed on you (whether by court order, agreement or 377 | otherwise) that contradict the conditions of this License, they do not 378 | excuse you from the conditions of this License. If you cannot 379 | distribute so as to satisfy simultaneously your obligations under this 380 | License and any other pertinent obligations, then as a consequence you 381 | may not distribute the Library at all. For example, if a patent 382 | license would not permit royalty-free redistribution of the Library by 383 | all those who receive copies directly or indirectly through you, then 384 | the only way you could satisfy both it and this License would be to 385 | refrain entirely from distribution of the Library. 386 | 387 | If any portion of this section is held invalid or unenforceable under any 388 | particular circumstance, the balance of the section is intended to apply, 389 | and the section as a whole is intended to apply in other circumstances. 390 | 391 | It is not the purpose of this section to induce you to infringe any 392 | patents or other property right claims or to contest validity of any 393 | such claims; this section has the sole purpose of protecting the 394 | integrity of the free software distribution system which is 395 | implemented by public license practices. Many people have made 396 | generous contributions to the wide range of software distributed 397 | through that system in reliance on consistent application of that 398 | system; it is up to the author/donor to decide if he or she is willing 399 | to distribute software through any other system and a licensee cannot 400 | impose that choice. 401 | 402 | This section is intended to make thoroughly clear what is believed to 403 | be a consequence of the rest of this License. 404 | 405 | 12. If the distribution and/or use of the Library is restricted in 406 | certain countries either by patents or by copyrighted interfaces, the 407 | original copyright holder who places the Library under this License may add 408 | an explicit geographical distribution limitation excluding those countries, 409 | so that distribution is permitted only in or among countries not thus 410 | excluded. In such case, this License incorporates the limitation as if 411 | written in the body of this License. 412 | 413 | 13. The Free Software Foundation may publish revised and/or new 414 | versions of the Lesser General Public License from time to time. 415 | Such new versions will be similar in spirit to the present version, 416 | but may differ in detail to address new problems or concerns. 417 | 418 | Each version is given a distinguishing version number. If the Library 419 | specifies a version number of this License which applies to it and 420 | "any later version", you have the option of following the terms and 421 | conditions either of that version or of any later version published by 422 | the Free Software Foundation. If the Library does not specify a 423 | license version number, you may choose any version ever published by 424 | the Free Software Foundation. 425 | 426 | 14. If you wish to incorporate parts of the Library into other free 427 | programs whose distribution conditions are incompatible with these, 428 | write to the author to ask for permission. For software which is 429 | copyrighted by the Free Software Foundation, write to the Free 430 | Software Foundation; we sometimes make exceptions for this. Our 431 | decision will be guided by the two goals of preserving the free status 432 | of all derivatives of our free software and of promoting the sharing 433 | and reuse of software generally. 434 | 435 | NO WARRANTY 436 | 437 | 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO 438 | WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. 439 | EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR 440 | OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY 441 | KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE 442 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 443 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE 444 | LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME 445 | THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 446 | 447 | 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN 448 | WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY 449 | AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU 450 | FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR 451 | CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE 452 | LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING 453 | RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A 454 | FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF 455 | SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH 456 | DAMAGES. 457 | 458 | END OF TERMS AND CONDITIONS 459 | 460 | 461 | ------------------------------------------------------------------------ 462 | 463 | The ncurses binding was originally written by John Meacham, and is 464 | available under the license: 465 | 466 | Unless otherwise stated the following licence applies: 467 | 468 | Copyright (c) 2002-2004 John Meacham (john at repetae dot net) 469 | 470 | Permission is hereby granted, free of charge, to any person obtaining a 471 | copy of this software and associated documentation files (the 472 | "Software"), to deal in the Software without restriction, including 473 | without limitation the rights to use, copy, modify, merge, publish, 474 | distribute, sublicense, and/or sell copies of the Software, and to 475 | permit persons to whom the Software is furnished to do so, subject to 476 | the following conditions: 477 | 478 | The above copyright notice and this permission notice shall be included 479 | in all copies or substantial portions of the Software. 480 | 481 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 482 | OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 483 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 484 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 485 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 486 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 487 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/skogsbaer/hscurses/3250af06a1ada9a180e28f4b1e499ee19d5633cf/README.md -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMainWithHooks autoconfUserHooks 4 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | * Examples: 2 | - find proper connection between application-specific and generic widgets 3 | - `add' command for contact manager 4 | 5 | * Keys: 6 | - ENTER returns (KeyChar '\r'), but what is KeyEnter good for? (**) 7 | - TAB returns (KeyChar '\t') 8 | 9 | * Widgets: 10 | - export list for module (**) 11 | - autowrap for text widget (low priority) 12 | - border widget (**) 13 | - selection widget 14 | -------------------------------------------------------------------------------- /UI/HSCurses/CWString.hsc: -------------------------------------------------------------------------------- 1 | -- Copyright (c) 2002-2004 John Meacham (john at repetae dot net) 2 | -- Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons 3 | -- 4 | -- This library is free software; you can redistribute it and/or 5 | -- modify it under the terms of the GNU Lesser General Public 6 | -- License as published by the Free Software Foundation; either 7 | -- version 2.1 of the License, or (at your option) any later version. 8 | -- 9 | -- This library is distributed in the hope that it will be useful, 10 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 | -- Lesser General Public License for more details. 13 | -- 14 | -- You should have received a copy of the GNU Lesser General Public 15 | -- License along with this library; if not, write to the Free Software 16 | -- Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 17 | 18 | 19 | module UI.HSCurses.CWString ( 20 | -- utf8 versions 21 | withUTF8String, 22 | withUTF8StringLen, 23 | newUTF8String, 24 | newUTF8StringLen, 25 | peekUTF8String, 26 | peekUTF8StringLen, 27 | 28 | -- WChar stuff 29 | #ifdef HAVE_WCHAR_H 30 | withCWString, 31 | withCWStringLen, 32 | newCWString, 33 | newCWStringLen, 34 | peekCWString, 35 | peekCWStringLen, 36 | wcharIsUnicode, 37 | CWChar, 38 | CWString, 39 | CWStringLen, 40 | #endif 41 | 42 | -- Locale versions 43 | withLCString, 44 | withLCStringLen, 45 | newLCString, 46 | newLCStringLen, 47 | peekLCStringLen, 48 | peekLCString, 49 | ) where 50 | 51 | import Data.Bits (Bits (shift, (.&.), (.|.))) 52 | import Data.Char (chr, ord) 53 | import Foreign.C.String 54 | 55 | #if __GLASGOW_HASKELL__ < 603 56 | import GHC.Exts 57 | #endif 58 | 59 | #ifdef HAVE_WCHAR_H 60 | 61 | import Foreign.C.Types 62 | 63 | #include 64 | #include 65 | #include 66 | 67 | type CWChar = (#type wchar_t) 68 | type CWString = Ptr CWChar 69 | type CWStringLen = (CWString, Int) 70 | 71 | fi :: (Integral a, Num b) => a -> b 72 | fi x = fromIntegral x 73 | 74 | ------------------- 75 | -- CWChar functions 76 | ------------------- 77 | 78 | {-# INLINE wcharIsUnicode #-} 79 | wcharIsUnicode :: Bool 80 | 81 | #if defined(__STDC_ISO_10646__) 82 | 83 | wcharIsUnicode = True 84 | 85 | -- support functions 86 | wNUL :: CWChar 87 | wNUL = 0 88 | 89 | #ifndef __GLASGOW_HASKELL__ 90 | 91 | pairLength :: String -> CString -> CStringLen 92 | pairLength = flip (,) . length 93 | 94 | cwCharsToChars :: [CWChar] -> [Char] 95 | cwCharsToChars xs = map castCWCharToChar xs 96 | charsToCWChars :: [Char] -> [CWChar] 97 | charsToCWChars xs = map castCharToCWChar xs 98 | 99 | #endif 100 | 101 | -- __STDC_ISO_10646__ 102 | 103 | castCWCharToChar :: CWChar -> Char 104 | castCWCharToChar ch = chr (fromIntegral ch) 105 | 106 | castCharToCWChar :: Char -> CWChar 107 | castCharToCWChar ch = fromIntegral (ord ch) 108 | 109 | peekCWString :: CWString -> IO String 110 | #ifndef __GLASGOW_HASKELL__ 111 | peekCString cp = do cs <- peekArray0 wNUL cp; return (cwCharsToChars cs) 112 | #else 113 | peekCWString cp = loop 0 114 | where 115 | loop i = do 116 | val <- peekElemOff cp i 117 | if val == wNUL 118 | then return [] 119 | else do 120 | rest <- loop (i + 1) 121 | return (castCWCharToChar val : rest) 122 | #endif 123 | 124 | peekCWStringLen :: CWStringLen -> IO String 125 | #ifndef __GLASGOW_HASKELL__ 126 | peekCWStringLen (cp, len) = do cs <- peekArray len cp; return (cwCharsToChars cs) 127 | #else 128 | peekCWStringLen (cp, len) = loop 0 129 | where 130 | loop i 131 | | i == len = return [] 132 | | otherwise = do 133 | val <- peekElemOff cp i 134 | rest <- loop (i + 1) 135 | return (castCWCharToChar val : rest) 136 | #endif 137 | 138 | newCWString :: String -> IO CWString 139 | #ifndef __GLASGOW_HASKELL__ 140 | newCWString = newArray0 wNUL . charsToCWChars 141 | #else 142 | newCWString str = do 143 | ptr <- mallocArray0 (length str) 144 | let 145 | go [] n## = pokeElemOff ptr (I## n##) wNUL 146 | go (c:cs) n## = do pokeElemOff ptr (I## n##) (castCharToCWChar c); go cs (n## +## 1##) 147 | go str 0## 148 | return ptr 149 | #endif 150 | 151 | newCWStringLen :: String -> IO CWStringLen 152 | #ifndef __GLASGOW_HASKELL__ 153 | newCWStringLen str = do 154 | a <- newArray (charsToCWChars str) 155 | return 156 | (pairLength str a) 157 | #else 158 | newCWStringLen str = do 159 | ptr <- mallocArray0 len 160 | let 161 | go [] _ = return () 162 | go (c:cs) n## = do pokeElemOff ptr (I## n##) (castCharToCWChar c); go cs (n## +## 1##) 163 | go str 0## 164 | return (ptr, len) 165 | where 166 | len = length str 167 | #endif 168 | 169 | withCWString :: String -> (CWString -> IO a) -> IO a 170 | #ifndef __GLASGOW_HASKELL__ 171 | withCWString = withArray0 wNUL . charsToCWChars 172 | #else 173 | withCWString str f = 174 | allocaArray0 (length str) $ \ptr -> 175 | let 176 | go [] n## = pokeElemOff ptr (I## n##) wNUL 177 | go (c:cs) n## = do pokeElemOff ptr (I## n##) (castCharToCWChar c); go cs (n## +## 1##) 178 | in do 179 | go str 0## 180 | f ptr 181 | #endif 182 | 183 | withCWStringLen :: String -> (CWStringLen -> IO a) -> IO a 184 | #ifndef __GLASGOW_HASKELL__ 185 | withCWStringLen str act = withArray (charsToCWChars str) $ act . pairLength str 186 | #else 187 | withCWStringLen str f = 188 | allocaArray len $ \ptr -> 189 | let 190 | go [] _ = return () 191 | go (c:cs) n## = do pokeElemOff ptr (I## n##) (castCharToCWChar c); go cs (n## +## 1##) 192 | in do 193 | go str 0## 194 | f (ptr,len) 195 | where 196 | len = length str 197 | #endif 198 | 199 | 200 | #else 201 | -- no __STDC_ISO_10646__ 202 | wcharIsUnicode = False 203 | #endif 204 | 205 | newtype MBState = MBState {_mbstate :: (Ptr MBState)} 206 | 207 | withMBState :: (MBState -> IO a) -> IO a 208 | withMBState act = allocaBytes (# const sizeof (mbstate_t)) (\mb -> c_memset mb 0 (# const sizeof (mbstate_t)) >> act (MBState mb)) 209 | 210 | clearMBState :: MBState -> IO () 211 | clearMBState (MBState mb) = c_memset mb 0 (# const sizeof (mbstate_t)) >> return () 212 | 213 | wcsrtombs :: CWString -> (CString, CSize) -> IO CSize 214 | wcsrtombs wcs (cs, len) = 215 | alloca 216 | ( \p -> 217 | poke p wcs 218 | >> withMBState 219 | ( \mb -> 220 | wcsrtombs' p cs len mb 221 | ) 222 | ) 223 | where 224 | wcsrtombs' p cs' len' mb = do 225 | x <- c_wcsrtombs cs p len' mb 226 | case x of 227 | -1 -> do 228 | sp <- peek p 229 | poke sp ((fi (ord '?')) :: CWChar) 230 | poke p wcs 231 | clearMBState mb 232 | wcsrtombs' p cs' len' mb 233 | e | e >= 0 && e <= len' -> do 234 | let ep = advancePtr cs' (fi e) 235 | poke ep (fi (0 :: Int)) 236 | return x 237 | e -> error $ "HSCurses.CWString.wcsrtombs: impossible case: " ++ show e 238 | 239 | foreign import ccall unsafe hs_get_mb_cur_max :: IO Int 240 | 241 | mb_cur_max :: Int 242 | mb_cur_max = unsafePerformIO hs_get_mb_cur_max 243 | 244 | foreign import ccall unsafe "stdlib.h wcsrtombs" 245 | c_wcsrtombs :: CString -> (Ptr (Ptr CWChar)) -> CSize -> MBState -> IO CSize 246 | 247 | foreign import ccall unsafe "string.h memset" 248 | c_memset :: Ptr a -> CInt -> CSize -> IO (Ptr a) 249 | 250 | foreign import ccall unsafe "stdlib.h mbstowcs" 251 | c_mbstowcs :: CWString -> CString -> CSize -> IO CSize 252 | 253 | mbstowcs :: 254 | CWString -> 255 | Foreign.C.String.CString -> 256 | Foreign.C.Types.CSize -> 257 | IO Foreign.C.Types.CSize 258 | mbstowcs a b s = throwIf (== -1) (const "mbstowcs") $ c_mbstowcs a b s 259 | 260 | peekLCString :: CString -> IO String 261 | peekLCString cp = do 262 | sz <- mbstowcs nullPtr cp 0 263 | allocaArray (fi $ sz + 1) (\wcp -> mbstowcs wcp cp (sz + 1) >> peekCWString wcp) 264 | 265 | -- TODO fix for embeded NULs 266 | peekLCStringLen :: CStringLen -> IO String 267 | peekLCStringLen (cp, len) = allocaBytes (len + 1) $ \ncp -> do 268 | copyBytes ncp cp len 269 | pokeElemOff ncp len 0 270 | peekLCString ncp 271 | 272 | newLCString :: String -> IO CString 273 | newLCString s = 274 | withCWString s $ \wcs -> do 275 | cs <- mallocArray0 alen 276 | wcsrtombs wcs (cs, fi alen) 277 | return cs 278 | where 279 | alen = mb_cur_max * length s 280 | 281 | newLCStringLen :: String -> IO CStringLen 282 | newLCStringLen str = newLCString str >>= \cs -> return (pairLength1 str cs) 283 | 284 | withLCString :: String -> (CString -> IO a) -> IO a 285 | withLCString s a = 286 | withCWString s $ \wcs -> 287 | allocaArray0 alen $ \cs -> 288 | wcsrtombs wcs (cs, fi alen) >> a cs 289 | where 290 | alen = mb_cur_max * length s 291 | 292 | withLCStringLen :: String -> (CStringLen -> IO a) -> IO a 293 | withLCStringLen s a = 294 | withCWString s $ \wcs -> 295 | allocaArray0 alen $ \cs -> do 296 | sz <- wcsrtombs wcs (cs, fi alen) 297 | a (cs, fi sz) 298 | where 299 | alen = mb_cur_max * length s 300 | 301 | pairLength1 :: String -> CString -> CStringLen 302 | pairLength1 = flip (,) . length 303 | 304 | #else 305 | -- ----------------------------------------------------------- 306 | -- no CF_WCHAR_SUPPORT (OpenBSD) 307 | 308 | withLCString :: String -> (Foreign.C.String.CString -> IO a) -> IO a 309 | withLCString = withCString 310 | 311 | withLCStringLen :: String -> (Foreign.C.String.CStringLen -> IO a) -> IO a 312 | withLCStringLen = withCStringLen 313 | 314 | newLCString :: String -> IO Foreign.C.String.CString 315 | newLCString = newCString 316 | 317 | newLCStringLen :: String -> IO Foreign.C.String.CStringLen 318 | newLCStringLen = newCStringLen 319 | 320 | peekLCString :: Foreign.C.String.CString -> IO String 321 | peekLCString = peekCString 322 | 323 | peekLCStringLen :: Foreign.C.String.CStringLen -> IO String 324 | peekLCStringLen = peekCStringLen 325 | 326 | #endif 327 | -- no CF_WCHAR_SUPPORT 328 | 329 | ----------------- 330 | -- UTF8 versions 331 | ----------------- 332 | 333 | withUTF8String :: String -> (CString -> IO a) -> IO a 334 | withUTF8String hsStr = withCString (toUTF hsStr) 335 | 336 | withUTF8StringLen :: String -> (CStringLen -> IO a) -> IO a 337 | withUTF8StringLen hsStr = withCStringLen (toUTF hsStr) 338 | 339 | newUTF8String :: String -> IO CString 340 | newUTF8String = newCString . toUTF 341 | 342 | newUTF8StringLen :: String -> IO CStringLen 343 | newUTF8StringLen = newCStringLen . toUTF 344 | 345 | peekUTF8String :: CString -> IO String 346 | peekUTF8String strPtr = fmap fromUTF $ peekCString strPtr 347 | 348 | peekUTF8StringLen :: CStringLen -> IO String 349 | peekUTF8StringLen strPtr = fmap fromUTF $ peekCStringLen strPtr 350 | 351 | -- these should read and write directly from/to memory. 352 | -- A first pass will be needed to determine the size of the allocated region 353 | 354 | toUTF :: String -> String 355 | toUTF [] = [] 356 | toUTF (x : xs) 357 | | ord x <= 0x007F = x : toUTF xs 358 | | ord x <= 0x07FF = 359 | chr (0xC0 .|. ((ord x `shift` (-6)) .&. 0x1F)) 360 | : chr (0x80 .|. (ord x .&. 0x3F)) 361 | : toUTF xs 362 | | otherwise = 363 | chr (0xE0 .|. ((ord x `shift` (-12)) .&. 0x0F)) 364 | : chr (0x80 .|. ((ord x `shift` (-6)) .&. 0x3F)) 365 | : chr (0x80 .|. (ord x .&. 0x3F)) 366 | : toUTF xs 367 | 368 | fromUTF :: String -> String 369 | fromUTF [] = [] 370 | fromUTF (al@(x : xs)) 371 | | ord x <= 0x7F = x : fromUTF xs 372 | | ord x <= 0xBF = err 373 | | ord x <= 0xDF = twoBytes al 374 | | ord x <= 0xEF = threeBytes al 375 | | otherwise = err 376 | where 377 | twoBytes (x1 : x2 : xs') = 378 | chr 379 | ( ((ord x1 .&. 0x1F) `shift` 6) 380 | .|. (ord x2 .&. 0x3F) 381 | ) 382 | : fromUTF xs' 383 | twoBytes _ = error "fromUTF: illegal two byte sequence" 384 | 385 | threeBytes (x1 : x2 : x3 : xs') = 386 | chr 387 | ( ((ord x1 .&. 0x0F) `shift` 12) 388 | .|. ((ord x2 .&. 0x3F) `shift` 6) 389 | .|. (ord x3 .&. 0x3F) 390 | ) 391 | : fromUTF xs' 392 | threeBytes _ = error "fromUTF: illegal three byte sequence" 393 | 394 | err = error "fromUTF: illegal UTF-8 character" 395 | -------------------------------------------------------------------------------- /UI/HSCurses/Curses.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | -- Copyright (c) 2002-2004 John Meacham (john at repetae dot net) 6 | -- Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons 7 | -- Copyright (c) 2005-2011 Stefan Wehr - http://www.stefanwehr.de 8 | -- 9 | -- This library is free software; you can redistribute it and/or 10 | -- modify it under the terms of the GNU Lesser General Public 11 | -- License as published by the Free Software Foundation; either 12 | -- version 2.1 of the License, or (at your option) any later version. 13 | -- 14 | -- This library is distributed in the hope that it will be useful, 15 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 17 | -- Lesser General Public License for more details. 18 | -- 19 | -- You should have received a copy of the GNU Lesser General Public 20 | -- License along with this library; if not, write to the Free Software 21 | -- Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 22 | 23 | -- | Binding to the [wn]curses library. From the ncurses man page: 24 | -- 25 | -- > The curses library routines give the user a terminal-inde- 26 | -- > pendent method of updating character screens with reason- 27 | -- > able optimization. 28 | -- 29 | -- Sections of the quoted documentation are from the OpenBSD man pages, which 30 | -- are distributed under a BSD license. 31 | -- 32 | -- A useful reference is: 33 | -- /Writing Programs with NCURSES/, by Eric S. Raymond and Zeyd 34 | -- M. Ben-Halim, 35 | -- 36 | -- N.B attrs don't work with Irix curses.h. This should be fixed. 37 | module UI.HSCurses.Curses ( 38 | -- Basic Functions 39 | stdScr, 40 | initScr, 41 | initCurses, 42 | resetParams, 43 | endWin, 44 | scrSize, 45 | newTerm, 46 | delScreen, 47 | 48 | -- Windows, screens and Pads 49 | Screen, 50 | Window, 51 | Border (..), 52 | touchWin, 53 | newPad, 54 | pRefresh, 55 | delWin, 56 | newWin, 57 | wRefresh, 58 | wnoutRefresh, 59 | wBorder, 60 | defaultBorder, 61 | 62 | -- Refresh routines 63 | refresh, 64 | update, 65 | resizeTerminal, 66 | timeout, 67 | noqiflush, 68 | 69 | -- Navigation 70 | move, 71 | getYX, 72 | 73 | -- Input 74 | getCh, 75 | getch, 76 | decodeKey, 77 | ungetCh, 78 | keyResizeCode, 79 | 80 | -- * Input Options 81 | cBreak, -- :: Bool -> IO () 82 | raw, -- :: Bool -> IO () 83 | echo, -- :: Bool -> IO () 84 | intrFlush, -- :: Bool -> IO () 85 | keypad, -- :: Window -> Bool -> IO () 86 | noDelay, -- :: Window -> Bool -> IO () 87 | 88 | -- * Output 89 | wAddStr, -- :: Window -> String -> IO () 90 | addLn, -- :: IO () 91 | mvWAddStr, 92 | mvAddCh, -- :: Int -> Int -> ChType -> IO () 93 | wMove, 94 | bkgrndSet, -- :: Attr -> Pair -> IO () 95 | erase, -- :: IO () 96 | wclear, -- :: Window -> IO () 97 | werase, 98 | clrToEol, -- :: IO () 99 | wClrToEol, 100 | beep, 101 | waddch, 102 | winsch, 103 | waddchnstr, -- :: Window -> CString -> CInt -> IO CInt 104 | 105 | -- * Output Options 106 | clearOk, 107 | leaveOk, 108 | nl, -- :: Bool -> IO () 109 | 110 | -- * Cursor Routines 111 | CursorVisibility (..), 112 | cursSet, 113 | 114 | -- * Color Support 115 | hasColors, -- :: IO Bool 116 | startColor, -- :: IO () 117 | useDefaultColors, -- :: IO () 118 | Pair (..), -- newtype Pair = Pair Int deriving (Eq, Ord, Ix) 119 | colorPairs, -- :: IO Int 120 | Color (..), -- newtype Color = Color Int deriving (Eq, Ord, Ix) 121 | colors, -- :: IO Int 122 | color, -- :: String -> Maybe Color 123 | -- black, red, green, yellow, blue, magenta, cyan, white, -- :: Color 124 | initPair, -- :: Pair -> Color -> Color -> IO () 125 | pairContent, -- :: Pair -> IO (Color, Color) 126 | canChangeColor, -- :: IO Bool 127 | initColor, -- :: Color -> (Int, Int, Int) -> IO () 128 | colorContent, -- :: Color -> IO (Int, Int, Int) 129 | defaultBackground, 130 | defaultForeground, 131 | 132 | -- * Attributes 133 | attrPlus, 134 | Attr, 135 | attr0, -- :: Attr 136 | isAltCharset, 137 | isBlink, 138 | isBold, 139 | isDim, 140 | isHorizontal, 141 | isInvis, 142 | isLeft, 143 | isLow, 144 | isProtect, 145 | isReverse, 146 | isRight, 147 | isStandout, 148 | isTop, 149 | isUnderline, 150 | isVertical, 151 | -- :: Attr -> Bool 152 | 153 | setAltCharset, 154 | setBlink, 155 | setBold, 156 | setDim, 157 | setHorizontal, 158 | setInvis, 159 | setLeft, 160 | setLow, 161 | setProtect, 162 | setReverse, 163 | setRight, 164 | setStandout, 165 | setTop, 166 | setUnderline, 167 | setVertical, 168 | -- :: Attr -> Bool -> Attr 169 | 170 | attrSet, -- :: Attr -> Pair -> IO () 171 | attrOn, 172 | attrOff, 173 | standout, 174 | standend, 175 | attrDim, 176 | attrBold, 177 | attrDimOn, 178 | attrDimOff, 179 | attrBoldOn, 180 | attrBoldOff, 181 | wAttrOn, 182 | wAttrOff, 183 | wAttrSet, 184 | wAttrGet, 185 | 186 | -- * Mouse Routines 187 | getMouse, 188 | withMouseEventMask, 189 | withAllMouseEvents, 190 | ButtonEvent (..), 191 | MouseEvent (..), 192 | 193 | -- * Keys 194 | Key (..), 195 | cERR, 196 | cKEY_UP, 197 | cKEY_DOWN, 198 | cKEY_LEFT, 199 | cKEY_RIGHT, 200 | cTRUE, 201 | -- cACS_BLOCK, 202 | 203 | -- * Lines 204 | vline, 205 | ulCorner, 206 | llCorner, 207 | urCorner, 208 | lrCorner, 209 | rTee, 210 | lTee, 211 | bTee, 212 | tTee, 213 | hLine, 214 | vLine, 215 | plus, 216 | s1, 217 | s9, 218 | diamond, 219 | ckBoard, 220 | degree, 221 | plMinus, 222 | bullet, 223 | lArrow, 224 | rArrow, 225 | dArrow, 226 | uArrow, 227 | board, 228 | lantern, 229 | block, 230 | s3, 231 | s7, 232 | lEqual, 233 | gEqual, 234 | pi, 235 | nEqual, 236 | sterling, 237 | 238 | -- * Signals 239 | cursesSigWinch, 240 | 241 | -- * Misc 242 | cursesTest, 243 | throwIfErr, 244 | throwIfErr_, 245 | errI, -- :: IO CInt -> IO () 246 | flushinp, 247 | recognize, 248 | ChType, 249 | NBool, 250 | ) where 251 | 252 | #include 253 | 254 | #if HAVE_SIGNAL_H 255 | #include 256 | #endif 257 | 258 | import UI.HSCurses.Logging 259 | 260 | #if !(defined(HAVE_WCHAR_H) && (defined(HAVE_LIBNCURSESW) || defined(HAVE_LIBPDCURSESW))) 261 | -- FIXME: this is needed for CI builds on macOS; we can probably replace the 262 | -- whole CWString module with just the "new" function in Foreign.C.String 263 | import UI.HSCurses.CWString (withLCStringLen) 264 | #endif 265 | 266 | import Data.Char 267 | import Data.Ix (Ix) 268 | import Prelude hiding (pi) 269 | 270 | -- foldl' was put into Prelude in base 4.20 271 | #if !MIN_VERSION_base(4,20,0) 272 | import Data.List (foldl') 273 | #endif 274 | 275 | import System.IO.Unsafe (unsafePerformIO) 276 | 277 | import Control.Concurrent 278 | import Control.Monad (liftM, void, when) 279 | import Control.Monad.Trans 280 | 281 | #if !MIN_VERSION_base(4,7,0) 282 | import Foreign hiding (unsafePerformIO, void) 283 | #else 284 | import Foreign hiding (void) 285 | #endif 286 | 287 | import Foreign.C.Error 288 | import Foreign.C.String 289 | import Foreign.C.Types 290 | 291 | import GHC.IO.FD (FD (..)) 292 | 293 | #ifndef mingw32_HOST_OS 294 | import System.Posix.Signals 295 | #endif 296 | 297 | #if __GLASGOW_HASKELL__ < 603 298 | import Data.Bits 299 | #endif 300 | 301 | 302 | -- | 'initCurses' does all initialization necessary for a Curses application. 303 | initCurses :: IO () 304 | initCurses = do 305 | initScr 306 | b <- hasColors 307 | when b $ startColor >> useDefaultColors 308 | 309 | resetParams :: IO () 310 | resetParams = do 311 | raw True -- raw mode please 312 | echo False 313 | nl False 314 | intrFlush True 315 | leaveOk False 316 | keypad stdScr True 317 | #ifdef NCURSES_EXT_FUNCS 318 | defineKey (# const KEY_UP) "\x1b[1;2A" 319 | defineKey (# const KEY_DOWN) "\x1b[1;2B" 320 | defineKey (# const KEY_SLEFT) "\x1b[1;2D" 321 | defineKey (# const KEY_SRIGHT) "\x1b[1;2C" 322 | defineKey (# const KEY_B2) "\x1b[E" -- xterm seems to emit B2, not BEG 323 | defineKey (# const KEY_END) "\x1b[F" 324 | defineKey (# const KEY_END) "\x1b[4~" 325 | defineKey (# const KEY_HOME) "\x1b[H" 326 | defineKey (# const KEY_HOME) "\x1b[1~" 327 | #endif 328 | 329 | fi :: (Integral a, Num b) => a -> b 330 | fi = fromIntegral 331 | 332 | throwIfErr :: (Eq a, Show a, Num a) => String -> IO a -> IO a 333 | throwIfErr s = throwIf (== (# const ERR)) (\a -> "Curses[" ++ show a ++ "]:" ++ s) 334 | 335 | throwIfErr_ :: (Eq a, Show a, Num a) => String -> IO a -> IO () 336 | throwIfErr_ name act = void $ throwIfErr name act 337 | 338 | errI :: IO CInt -> IO () 339 | errI f = do 340 | r <- f 341 | if r == cERR 342 | then do 343 | _ <- endwin 344 | error "curses returned an error" 345 | else return () 346 | 347 | type WindowTag = () 348 | type Window = Ptr WindowTag 349 | type ChType = #type chtype 350 | type NBool = #type bool 351 | 352 | 353 | -- | The standard screen 354 | stdScr :: Window 355 | stdScr = unsafePerformIO (peek stdscr) 356 | {-# NOINLINE stdScr #-} 357 | 358 | foreign import ccall "static HSCurses.h &stdscr" 359 | stdscr :: Ptr Window 360 | 361 | -- | 'initScr' is normally the first curses routine to call when initializing a 362 | -- program. curs_initscr(3): 363 | -- 364 | -- > To initialize the routines, the routine initscr or newterm must be called 365 | -- > before any of the other routines that deal with windows and screens are 366 | -- > used. 367 | -- > 368 | -- > The initscr code determines the terminal type and initial- izes all curses 369 | -- > data structures. initscr also causes the first call to refresh to clear the 370 | -- > screen. If errors occur, initscr writes an appropriate error message to 371 | -- > standard error and exits; otherwise, a pointer is returned to stdscr. 372 | initScr :: IO Window 373 | initScr = throwIfNull "initscr" initscr 374 | 375 | foreign import ccall unsafe "HSCurses.h initscr" initscr :: IO Window 376 | 377 | -- This seems like the easiest way to get a FILE (see: man FILE) 378 | -- from an FD 379 | type FILE = Ptr () 380 | 381 | foreign import ccall unsafe "fdopen" 382 | fdopen :: CInt -> CString -> IO FILE 383 | 384 | fdOpen :: FD -> String -> IO FILE 385 | fdOpen fd mode = 386 | withCString mode $ \mode' -> do 387 | fdopen (fdFD fd) mode' 388 | 389 | type Screen = Ptr () 390 | 391 | -- | A program that outputs to more than one terminal should use the 'newTerm' 392 | -- routine for each terminal instead of 'initScr'. A program that needs to 393 | -- inspect capabilities, so it can continue to run in a line-oriented mode if 394 | -- the terminal cannot support a screen-oriented program, would also use 395 | -- 'newTerm'. curs_initscr(3X): 396 | -- 397 | -- > The routine newterm should be called once for each terminal. It returns 398 | -- > a variable of type SCREEN * which should be saved as a reference to that 399 | -- > terminal. newterm's arguments are 400 | -- > 401 | -- > - the type of the terminal to be used in place of $TERM, 402 | -- > 403 | -- > - an output stream connected to the terminal, and 404 | -- > 405 | -- > - an input stream connected to the terminal 406 | -- > 407 | -- > If the type parameter is NULL, $TERM will be used. 408 | newTerm :: String -> FD -> FD -> IO Screen 409 | newTerm typ out in' = 410 | withCString typ $ \typ' -> do 411 | fout <- fdOpen out "rw" 412 | fin <- fdOpen in' "r" 413 | throwIfNull "newterm" $ newterm typ' fout fin 414 | 415 | foreign import ccall unsafe "HSCurses.h newterm" 416 | newterm :: CString -> FILE -> FILE -> IO Screen 417 | 418 | foreign import ccall unsafe "HSCurses.h delscreen" 419 | delScreen :: Screen -> IO () 420 | 421 | -- | > The cbreak routine disables line buffering and erase/kill 422 | -- > character-processing (interrupt and flow control characters are 423 | -- > unaffected), making characters typed by the user immediately available to 424 | -- > the program. The nocbreak routine returns the terminal to normal (cooked) 425 | -- > mode. 426 | cBreak :: Bool -> IO () 427 | cBreak True = throwIfErr_ "cbreak" cbreak 428 | cBreak False = throwIfErr_ "nocbreak" nocbreak 429 | 430 | foreign import ccall unsafe "HSCurses.h cbreak" cbreak :: IO CInt 431 | foreign import ccall unsafe "HSCurses.h nocbreak" nocbreak :: IO CInt 432 | 433 | -- | > The raw and noraw routines place the terminal into or out of raw mode. 434 | -- > Raw mode is similar to cbreak mode, in that characters typed are 435 | -- > immediately passed through to the user program. The differences are that 436 | -- > in raw mode, the interrupt, quit, suspend, and flow control characters 437 | -- > are all passed through uninterpreted, instead of generating a signal. The 438 | -- > behavior of the BREAK key depends on other bits in the tty driver that 439 | -- > are not set by curses. 440 | raw :: Bool -> IO () 441 | raw False = throwIfErr_ "noraw" noraw 442 | raw True = throwIfErr_ "raw" raw_c 443 | 444 | foreign import ccall unsafe "hscurses.h noraw" noraw :: IO CInt 445 | foreign import ccall unsafe "HSCurses.h raw" raw_c :: IO CInt 446 | 447 | -- | > The echo and noecho routines control whether characters typed by the user 448 | -- > are echoed by getch as they are typed. Echoing by the tty driver is 449 | -- > always disabled, but ini- tially getch is in echo mode, so characters 450 | -- > typed are echoed. Authors of most interactive programs prefer to do their 451 | -- > own echoing in a controlled area of the screen, or not to echo at all, so 452 | -- > they disable echoing by calling noecho. [See curs_getch(3) for a 453 | -- > discussion of how these routines interact with cbreak and nocbreak.] 454 | echo :: Bool -> IO () 455 | echo False = throwIfErr_ "noecho" noecho 456 | echo True = throwIfErr_ "echo" echo_c 457 | 458 | foreign import ccall unsafe "HSCurses.h noecho" noecho :: IO CInt 459 | foreign import ccall unsafe "HSCurses.h echo" echo_c :: IO CInt 460 | 461 | -- | > The nl and nonl routines control whether the underlying display device 462 | -- > translates the return key into newline on input, and whether it 463 | -- > translates newline into return and line-feed on output (in either case, 464 | -- > the call addch('\n') does the equivalent of return and line feed on the 465 | -- > virtual screen). Initially, these translations do occur. If you disable 466 | -- > them using nonl, curses will be able to make bet- ter use of the 467 | -- > line-feed capability, resulting in faster cursor motion. Also, curses 468 | -- > will then be able to detect the return key. 469 | nl :: Bool -> IO () 470 | nl True = throwIfErr_ "nl" nl_c 471 | nl False = throwIfErr_ "nonl" nonl 472 | 473 | foreign import ccall unsafe "HSCurses.h nl" nl_c :: IO CInt 474 | foreign import ccall unsafe "HSCurses.h nonl" nonl :: IO CInt 475 | 476 | -- | > If the intrflush option is enabled, (bf is TRUE), when an interrupt key 477 | -- > is pressed on the keyboard (interrupt, break, quit) all output in the tty 478 | -- > driver queue will be flushed, giving the effect of faster response to the 479 | -- > interrupt, but causing curses to have the wrong idea of what is on the 480 | -- > screen. Disabling (bf is FALSE), the option prevents the flush. 481 | intrFlush :: Bool -> IO () 482 | intrFlush bf = 483 | throwIfErr_ "intrflush" $ intrflush stdScr (if bf then 1 else 0) 484 | 485 | foreign import ccall unsafe "HSCurses.h intrflush" 486 | intrflush :: Window -> (#type bool) -> IO CInt 487 | 488 | -- | Enable the keypad of the user's terminal. 489 | keypad :: Window -> Bool -> IO () 490 | keypad win bf = throwIfErr_ "keypad" $ keypad_c win (if bf then 1 else 0) 491 | 492 | foreign import ccall unsafe "HSCurses.h keypad" 493 | keypad_c :: Window -> (#type bool) -> IO CInt 494 | 495 | noDelay :: Window -> Bool -> IO () 496 | noDelay win bf = 497 | throwIfErr_ "nodelay" $ nodelay win (if bf then 1 else 0) 498 | 499 | foreign import ccall unsafe "HSCurses.h nodelay" 500 | nodelay :: Window -> (#type bool) -> IO CInt 501 | 502 | -- | Normally, the hardware cursor is left at the location of the window cursor 503 | -- being refreshed. The leaveok option allows the cursor to be left wherever the 504 | -- update happens to leave it. It is useful for applications where the cursor is 505 | -- not used, since it reduces the need for cursor motions. If possible, the 506 | -- cursor is made invisible when this option is enabled. 507 | leaveOk :: Bool -> IO CInt 508 | leaveOk True = leaveok_c stdScr 1 509 | leaveOk False = leaveok_c stdScr 0 510 | 511 | foreign import ccall unsafe "HSCurses.h leaveok" 512 | leaveok_c :: Window -> (#type bool) -> IO CInt 513 | 514 | clearOk :: Bool -> IO CInt 515 | clearOk True = clearok_c stdScr 1 516 | clearOk False = clearok_c stdScr 0 517 | 518 | foreign import ccall unsafe "HSCurses.h clearok" 519 | clearok_c :: Window -> (#type bool) -> IO CInt 520 | 521 | foreign import ccall unsafe "HSCurses.h use_default_colors" 522 | useDefaultColors :: IO () 523 | 524 | defaultBackground, defaultForeground :: Color 525 | defaultBackground = Color (-1) 526 | defaultForeground = Color (-1) 527 | 528 | #ifdef NCURSES_EXT_FUNCS 529 | defineKey :: CInt -> String -> IO () 530 | defineKey k s = withCString s (\s' -> define_key s' k) >> return () 531 | 532 | foreign import ccall unsafe "HSCurses.h define_key" 533 | define_key :: Ptr CChar -> CInt -> IO () 534 | #endif 535 | 536 | -- | > The program must call endwin for each terminal being used before 537 | -- > exiting from curses. 538 | endWin :: IO () 539 | endWin = throwIfErr_ "endwin" endwin 540 | 541 | foreign import ccall unsafe "HSCurses.h endwin" endwin :: IO CInt 542 | 543 | -- | Get the dimensions of the screen (lines, cols). 544 | scrSize :: IO (Int, Int) 545 | -- Note, per the documentation: 546 | -- http://invisible-island.net/ncurses/ncurses-intro.html#caution 547 | -- It is not recommended to peek at the LINES and COLS global variables. This code 548 | -- was previously doing exactly that, but now it is fixed to use getmaxyx. 549 | -- -Ryan Newton [2013.03.31] 550 | scrSize = do 551 | yfp <- mallocForeignPtr 552 | xfp <- mallocForeignPtr 553 | withForeignPtr yfp $ \yp -> 554 | withForeignPtr xfp $ \xp -> do 555 | getMaxYX stdScr yp xp 556 | y <- peek yp 557 | x <- peek xp 558 | return (fromIntegral y, fromIntegral x) 559 | 560 | foreign import ccall "HSCurses.h getmaxyx_fun" 561 | getMaxYX :: 562 | Window -> Ptr CInt -> Ptr CInt -> IO () 563 | 564 | -- | Refresh curses windows and lines. curs_refresh(3) 565 | refresh :: IO () 566 | refresh = throwIfErr_ "refresh" refresh_c 567 | 568 | foreign import ccall unsafe "HSCurses.h refresh" 569 | refresh_c :: IO CInt 570 | 571 | -- | Refresh the specified window, copying the data from the virtual screen to 572 | -- the physical screen. 573 | wRefresh :: Window -> IO () 574 | wRefresh w = throwIfErr_ "wrefresh" $ wrefresh_c w 575 | 576 | foreign import ccall unsafe "HSCurses.h wrefresh" 577 | wrefresh_c :: Window -> IO CInt 578 | 579 | -- | Stage an update to a window, but don't actually do the refresh until update 580 | -- is called. This allows multiple windows to be updated together more smoothly. 581 | wnoutRefresh :: Window -> IO () 582 | wnoutRefresh w = throwIfErr_ "wnoutrefresh" $ wnoutrefresh_c w 583 | 584 | foreign import ccall safe "HSCurses.h wnoutrefresh" 585 | wnoutrefresh_c :: Window -> IO CInt 586 | 587 | -- | Do an actual update. Used after endWin on linux to restore the terminal. 588 | update :: IO () 589 | update = throwIfErr_ "update" update_c 590 | 591 | foreign import ccall unsafe "HSCurses.h doupdate" update_c :: IO CInt 592 | 593 | foreign import ccall unsafe "static curses.h timeout" timeout_c :: CInt -> IO () 594 | 595 | -- | Set a delay in milliseconds. 596 | timeout :: Int -> IO () 597 | timeout = timeout_c . fromIntegral 598 | 599 | hasColors :: IO Bool 600 | hasColors = liftM (/= 0) has_colors 601 | 602 | foreign import ccall unsafe "HSCurses.h has_colors" has_colors :: IO (#type bool) 603 | 604 | -- | Initialise the color settings. Also sets the screen to the default colors 605 | -- (white on black). 606 | startColor :: IO () 607 | startColor = throwIfErr_ "start_color" start_color 608 | 609 | foreign import ccall unsafe start_color :: IO CInt 610 | 611 | newtype Pair = Pair Int deriving (Eq, Ord, Ix, Show) 612 | 613 | -- | Defines the maximum number of color-pairs the terminal can support). 614 | colorPairs :: IO Int 615 | colorPairs = fmap fromIntegral $ peek colorPairsPtr 616 | 617 | foreign import ccall "HSCurses.h &COLOR_PAIRS" 618 | colorPairsPtr :: Ptr CInt 619 | 620 | newtype Color = Color Int deriving (Eq, Ord, Ix) 621 | 622 | colors :: IO Int 623 | colors = liftM fromIntegral $ peek colorsPtr 624 | 625 | foreign import ccall "HSCurses.h &COLORS" colorsPtr :: Ptr CInt 626 | 627 | color :: String -> Maybe Color 628 | color "default" = Just $ Color (-1) 629 | color "black" = Just $ Color (# const COLOR_BLACK) 630 | color "red" = Just $ Color (# const COLOR_RED) 631 | color "green" = Just $ Color (# const COLOR_GREEN) 632 | color "yellow" = Just $ Color (# const COLOR_YELLOW) 633 | color "blue" = Just $ Color (# const COLOR_BLUE) 634 | color "magenta" = Just $ Color (# const COLOR_MAGENTA) 635 | color "cyan" = Just $ Color (# const COLOR_CYAN) 636 | color "white" = Just $ Color (# const COLOR_WHITE) 637 | color _ = Nothing 638 | 639 | -- | curses support color attributes on terminals with that capability. To use 640 | -- these routines start_color must be called, usually right after initscr. 641 | -- Colors are always used in pairs (referred to as color-pairs). A color-pair 642 | -- consists of a foreground color (for characters) and a background color (for 643 | -- the blank field on which the charac- ters are displayed). A programmer 644 | -- initializes a color- pair with the routine init_pair. After it has been ini- 645 | -- tialized, COLOR_PAIR(n), a macro defined in , can be used as a new 646 | -- video attribute. 647 | -- 648 | -- If a terminal is capable of redefining colors, the pro- grammer can use the 649 | -- routine init_color to change the defi- nition of a color. 650 | -- 651 | -- The init_pair routine changes the definition of a color- pair. It takes three 652 | -- arguments: the number of the color- pair to be changed, the foreground color 653 | -- number, and the background color number. For portable applications: 654 | -- 655 | -- - The value of the first argument must be between 1 and COLOR_PAIRS-1. 656 | -- 657 | -- - The value of the second and third arguments must be between 0 and COLORS 658 | -- (the 0 color pair is wired to white on black and cannot be changed). 659 | initPair :: Pair -> Color -> Color -> IO () 660 | initPair (Pair p) (Color f) (Color b) = 661 | throwIfErr_ "init_pair" $ 662 | init_pair (fromIntegral p) (fromIntegral f) (fromIntegral b) 663 | 664 | foreign import ccall unsafe 665 | init_pair :: CShort -> CShort -> CShort -> IO CInt 666 | 667 | pairContent :: Pair -> IO (Color, Color) 668 | pairContent (Pair p) = 669 | alloca $ \fPtr -> 670 | alloca $ \bPtr -> do 671 | throwIfErr "pair_content" $ pair_content (fromIntegral p) fPtr bPtr 672 | f <- peek fPtr 673 | b <- peek bPtr 674 | return (Color (fromIntegral f), Color (fromIntegral b)) 675 | 676 | foreign import ccall unsafe 677 | pair_content :: CShort -> Ptr CShort -> Ptr CShort -> IO CInt 678 | 679 | canChangeColor :: IO Bool 680 | canChangeColor = liftM (/= 0) can_change_color 681 | 682 | foreign import ccall unsafe can_change_color :: IO (#type bool) 683 | 684 | initColor :: Color -> (Int, Int, Int) -> IO () 685 | initColor (Color c) (r, g, b) = 686 | throwIfErr_ "init_color" $ 687 | init_color (fromIntegral c) (fromIntegral r) (fromIntegral g) (fromIntegral b) 688 | 689 | foreign import ccall unsafe 690 | init_color :: CShort -> CShort -> CShort -> CShort -> IO CInt 691 | 692 | colorContent :: Color -> IO (Int, Int, Int) 693 | colorContent (Color c) = 694 | alloca $ \rPtr -> 695 | alloca $ \gPtr -> 696 | alloca $ \bPtr -> do 697 | throwIfErr "color_content" $ color_content (fromIntegral c) rPtr gPtr bPtr 698 | r <- peek rPtr 699 | g <- peek gPtr 700 | b <- peek bPtr 701 | return (fromIntegral r, fromIntegral g, fromIntegral b) 702 | 703 | foreign import ccall unsafe 704 | color_content :: CShort -> Ptr CShort -> Ptr CShort -> Ptr CShort -> IO CInt 705 | 706 | foreign import ccall unsafe "HSCurses.h hs_curses_color_pair" colorPair :: Pair -> ChType 707 | 708 | ----------------------------------------------------------------------------- 709 | -- * Attributes 710 | ----------------------------------------------------------------------------- 711 | 712 | foreign import ccall unsafe "HSCurses.h attr_set" 713 | attr_set :: Attr -> CShort -> Ptr a -> IO Int 714 | 715 | foreign import ccall unsafe "HSCurses.h wattr_set" 716 | wattr_set :: Window -> Attr -> CInt -> Ptr a -> IO CInt 717 | 718 | foreign import ccall unsafe "HSCurses.h wattr_get" 719 | wattr_get :: Window -> Ptr Attr -> Ptr CShort -> Ptr a -> IO CInt 720 | 721 | foreign import ccall "HSCurses.h attr_on" attr_on :: (#type attr_t) -> Ptr a -> IO Int 722 | foreign import ccall "HSCurses.h attr_off" attr_off :: (#type attr_t) -> Ptr a -> IO Int 723 | foreign import ccall "HSCurses.h attron" attron :: Int -> IO Int 724 | foreign import ccall "HSCurses.h attroff" attroff :: Int -> IO Int 725 | foreign import ccall unsafe "HSCurses.h wattron" wattron :: Window -> CInt -> IO CInt 726 | foreign import ccall unsafe "HSCurses.h wattroff" wattroff :: Window -> CInt -> IO CInt 727 | foreign import ccall standout :: IO Int 728 | foreign import ccall standend :: IO Int 729 | 730 | wAttrSet :: Window -> (Attr, Pair) -> IO () 731 | wAttrSet w (a, (Pair p)) = 732 | throwIfErr_ "wattr_set" $ 733 | wattr_set w a (fromIntegral p) nullPtr 734 | 735 | -- | Manipulate the current attributes of the named window. see curs_attr(3) 736 | wAttrGet :: Window -> IO (Attr, Pair) 737 | wAttrGet w = 738 | alloca $ \pa -> 739 | alloca $ \pp -> do 740 | throwIfErr_ "wattr_get" $ wattr_get w pa pp nullPtr 741 | a <- peek pa 742 | p <- peek pp 743 | return (a, Pair $ fromIntegral p) 744 | 745 | newtype Attr = Attr (#type attr_t) 746 | deriving (Eq, Storable, Bits, Num, Show) 747 | 748 | -- | Normal display (no highlight) 749 | attr0 :: Attr 750 | #ifdef WA_NORMAL 751 | attr0 = Attr (#const WA_NORMAL) 752 | #else 753 | attr0 = Attr (#const A_NORMAL) 754 | #endif 755 | 756 | isAltCharset, isBlink, isBold, isDim, isHorizontal, isInvis, isLeft, 757 | isLow, isProtect, isReverse, isRight, isStandout, isTop, 758 | isUnderline, isVertical :: Attr -> Bool 759 | 760 | isAltCharset = isAttr (#const WA_ALTCHARSET) 761 | isBlink = isAttr (#const WA_BLINK) 762 | isBold = isAttr (#const WA_BOLD) 763 | isDim = isAttr (#const WA_DIM) 764 | isHorizontal = isAttr (#const WA_HORIZONTAL) 765 | isInvis = isAttr (#const WA_INVIS) 766 | isLeft = isAttr (#const WA_LEFT) 767 | isLow = isAttr (#const WA_LOW) 768 | isProtect = isAttr (#const WA_PROTECT) 769 | isReverse = isAttr (#const WA_REVERSE) 770 | isRight = isAttr (#const WA_RIGHT) 771 | isStandout = isAttr (#const WA_STANDOUT) 772 | isTop = isAttr (#const WA_TOP) 773 | isUnderline = isAttr (#const WA_UNDERLINE) 774 | isVertical = isAttr (#const WA_VERTICAL) 775 | 776 | isAttr :: (#type attr_t) -> Attr -> Bool 777 | isAttr b (Attr a) = a .&. b /= 0 778 | 779 | setAltCharset, setBlink, setBold, setDim, setHorizontal, setInvis, 780 | setLeft, setLow, setProtect, setReverse, setRight, setStandout, 781 | setTop, setUnderline, setVertical :: Attr -> Bool -> Attr 782 | 783 | setAltCharset = setAttr (#const WA_ALTCHARSET) 784 | setBlink = setAttr (#const WA_BLINK) 785 | setBold = setAttr (#const WA_BOLD) 786 | setDim = setAttr (#const WA_DIM) 787 | setHorizontal = setAttr (#const WA_HORIZONTAL) 788 | setInvis = setAttr (#const WA_INVIS) 789 | setLeft = setAttr (#const WA_LEFT) 790 | setLow = setAttr (#const WA_LOW) 791 | setProtect = setAttr (#const WA_PROTECT) 792 | setReverse = setAttr (#const WA_REVERSE) 793 | setRight = setAttr (#const WA_RIGHT) 794 | setStandout = setAttr (#const WA_STANDOUT) 795 | setTop = setAttr (#const WA_TOP) 796 | setUnderline = setAttr (#const WA_UNDERLINE) 797 | setVertical = setAttr (#const WA_VERTICAL) 798 | 799 | setAttr :: (#type attr_t) -> Attr -> Bool -> Attr 800 | setAttr b (Attr a) False = Attr (a .&. complement b) 801 | setAttr b (Attr a) True = Attr (a .|. b) 802 | 803 | attrPlus :: Attr -> Attr -> Attr 804 | attrPlus (Attr a) (Attr b) = Attr (a .|. b) 805 | 806 | attrSet :: Attr -> Pair -> IO () 807 | attrSet attr (Pair p) = throwIfErr_ "attrset" $ 808 | attr_set attr (fromIntegral p) nullPtr 809 | 810 | attrOn :: Attr -> IO () 811 | attrOn (Attr attr) = throwIfErr_ "attr_on" $ 812 | attr_on attr nullPtr 813 | 814 | attrOff :: Attr -> IO () 815 | attrOff (Attr attr) = throwIfErr_ "attr_off" $ 816 | attr_off attr nullPtr 817 | 818 | wAttrOn :: Window -> Int -> IO () 819 | wAttrOn w x = throwIfErr_ "wattron" $ wattron w (fi x) 820 | 821 | wAttrOff :: Window -> Int -> IO () 822 | wAttrOff w x = throwIfErr_ "wattroff" $ wattroff w (fi x) 823 | 824 | attrDimOn :: IO () 825 | attrDimOn = throwIfErr_ "attron A_DIM" $ 826 | attron (#const A_DIM) 827 | 828 | attrDimOff :: IO () 829 | attrDimOff = throwIfErr_ "attroff A_DIM" $ 830 | attroff (#const A_DIM) 831 | 832 | attrBoldOn :: IO () 833 | attrBoldOn = throwIfErr_ "attron A_BOLD" $ 834 | attron (#const A_BOLD) 835 | 836 | attrBoldOff :: IO () 837 | attrBoldOff = throwIfErr_ "attroff A_BOLD" $ 838 | attroff (#const A_BOLD) 839 | 840 | attrDim :: Int 841 | attrDim = (#const A_DIM) 842 | attrBold :: Int 843 | attrBold = (#const A_BOLD) 844 | 845 | -- | Raw NCurses routine. 846 | foreign import ccall safe 847 | waddch :: Window -> ChType -> IO CInt 848 | 849 | -- | Raw NCurses routine. 850 | foreign import ccall safe 851 | winsch :: Window -> ChType -> IO CInt 852 | 853 | -- | Raw NCurses routine. 854 | foreign import ccall safe 855 | waddchnstr :: Window -> CString -> CInt -> IO CInt 856 | 857 | foreign import ccall safe "static curses.h mvaddch" 858 | mvaddch_c :: CInt -> CInt -> ChType -> IO () 859 | 860 | mvWAddStr :: Window -> Int -> Int -> String -> IO () 861 | mvWAddStr w y x str = wMove w y x >> wAddStr w str 862 | 863 | mvAddCh :: Int -> Int -> ChType -> IO () 864 | mvAddCh l m n = mvaddch_c (fromIntegral l) (fromIntegral m) (fromIntegral n) 865 | 866 | addLn :: IO () 867 | addLn = wAddStr stdScr "\n" 868 | 869 | #if defined(HAVE_WCHAR_H) && (defined(HAVE_LIBNCURSESW) || defined(HAVE_LIBPDCURSESW)) 870 | 871 | foreign import ccall unsafe 872 | waddnwstr :: Window -> CWString -> CInt -> IO CInt 873 | 874 | wAddStr :: Window -> String -> IO () 875 | wAddStr win str = do 876 | let convStr f = case f [] of 877 | [] -> return () 878 | s -> 879 | throwIfErr_ "waddnstr" $ 880 | withCWStringLen (s) (\(ws, len) -> (waddnwstr win ws (fi len))) 881 | loop [] acc = convStr acc 882 | loop (ch : str') acc = 883 | recognize 884 | ch 885 | (loop str' (acc . (ch :))) 886 | ( \ch' -> do 887 | convStr acc 888 | throwIfErr "waddch" $ waddch win ch' 889 | loop str' id 890 | ) 891 | loop str id 892 | 893 | #else 894 | 895 | -- This is heavily called, and does a lot of allocs. We walk over all 896 | -- the string accumulating a list of characters to be drawn. 897 | -- 898 | -- Got it down to: 899 | -- 900 | -- wAddStr Yi.Curses 20.0 38.1 901 | -- wAddStr Yi.Curses 10.0 32.5 902 | -- 903 | -- TODO make this way less expensive. That accum sucks. 904 | -- use difference lists for O(1) append 905 | wAddStr :: Window -> [Char] -> IO () 906 | wAddStr _ [] = return () 907 | wAddStr win s = 908 | throwIfErr_ ("waddnstr: <" ++ s ++ ">") $ 909 | withLCStringLen (s) (\(ws, len) -> waddnstr win ws (fi len)) 910 | 911 | foreign import ccall safe 912 | waddnstr :: Window -> CString -> CInt -> IO CInt 913 | 914 | #endif 915 | 916 | foreign import ccall safe 917 | vline :: Char -> Int -> IO () 918 | 919 | -- 920 | -- what ? 921 | -- 922 | 923 | #let translate_attr attr = \ 924 | "(if a .&. %lu /= 0 then %lu else 0) .|.", \ 925 | (unsigned long) WA_##attr, (unsigned long) A_##attr 926 | 927 | bkgrndSet :: Attr -> Pair -> IO () 928 | bkgrndSet (Attr a) p = bkgdset $ 929 | fromIntegral (ord ' ') .|. 930 | #translate_attr ALTCHARSET 931 | #translate_attr BLINK 932 | #translate_attr BOLD 933 | #translate_attr DIM 934 | #translate_attr INVIS 935 | #translate_attr PROTECT 936 | #translate_attr REVERSE 937 | #translate_attr STANDOUT 938 | #translate_attr UNDERLINE 939 | colorPair p 940 | 941 | foreign import ccall unsafe bkgdset :: ChType -> IO () 942 | 943 | -- | Copy blanks to every position in the screen. 944 | erase :: IO () 945 | erase = throwIfErr_ "erase" $ werase_c stdScr 946 | 947 | foreign import ccall unsafe "werase" werase_c :: Window -> IO CInt 948 | 949 | -- | Copy blanks to every position in a window. 950 | werase :: Window -> IO () 951 | werase w = throwIfErr_ "werase" $ werase_c w 952 | 953 | -- | Copy blanks to a window and set clearOk for that window. 954 | wclear :: Window -> IO () 955 | wclear w = throwIfErr_ "wclear" $ wclear_c w 956 | 957 | foreign import ccall unsafe "wclear" wclear_c :: Window -> IO CInt 958 | 959 | clrToEol :: IO () 960 | clrToEol = throwIfErr_ "clrtoeol" clrtoeol 961 | 962 | foreign import ccall unsafe clrtoeol :: IO CInt 963 | 964 | -- | > move the cursor associated with the window to line y and column x. This 965 | -- > routine does not move the physical cursor of the terminal until refresh 966 | -- > is called. The position specified is relative to the upper left-hand 967 | -- > corner of the window, which is (0,0). 968 | -- 969 | -- Note that 'move_c' may be a macro. 970 | move :: Int -> Int -> IO () 971 | move y x = throwIfErr_ "move" $ move_c (fromIntegral y) (fromIntegral x) 972 | 973 | foreign import ccall unsafe "move" 974 | move_c :: CInt -> CInt -> IO CInt 975 | 976 | -- | > move the cursor associated with the window 977 | -- > to line y and column x. This routine does not move the 978 | -- > physical cursor of the terminal until refresh is called. 979 | -- > The position specified is relative to the upper left-hand 980 | -- > corner of the window, which is (0,0). 981 | wMove :: Window -> Int -> Int -> IO () 982 | wMove w y x = throwIfErr_ "wmove" $ wmove w (fi y) (fi x) 983 | 984 | foreign import ccall unsafe 985 | wmove :: Window -> CInt -> CInt -> IO CInt 986 | 987 | ----------------------------------------------------------------------------- 988 | -- * Cursor routines 989 | ----------------------------------------------------------------------------- 990 | 991 | data CursorVisibility 992 | = CursorInvisible 993 | | CursorVisible 994 | | CursorVeryVisible 995 | 996 | vis_c :: CursorVisibility -> CInt 997 | vis_c vis = case vis of 998 | CursorInvisible -> 0 999 | CursorVisible -> 1 1000 | CursorVeryVisible -> 2 1001 | 1002 | c_vis :: CInt -> CursorVisibility 1003 | c_vis 0 = CursorInvisible 1004 | c_vis 1 = CursorVisible 1005 | c_vis 2 = CursorVeryVisible 1006 | c_vis n = error ("Illegal C value for cursor visibility: " ++ show n) 1007 | 1008 | -- | Set the cursor state. 1009 | -- 1010 | -- > The curs_set routine sets the cursor state is set to invisible, normal, or 1011 | -- > very visible for visibility equal to 0, 1, or 2 respectively. If the 1012 | -- > terminal supports the visibility requested, the previous cursor state is 1013 | -- > returned; otherwise, ERR is returned. 1014 | cursSet :: CursorVisibility -> IO CursorVisibility 1015 | cursSet CursorInvisible = do 1016 | leaveOk True 1017 | old <- curs_set 0 1018 | return $ c_vis old 1019 | cursSet v = do 1020 | leaveOk False 1021 | old <- curs_set (vis_c v) 1022 | return $ c_vis old 1023 | 1024 | foreign import ccall unsafe "HSCurses.h curs_set" 1025 | curs_set :: CInt -> IO CInt 1026 | 1027 | -- | Get the current cursor coordinates. 1028 | getYX :: Window -> IO (Int, Int) 1029 | getYX w = 1030 | alloca $ \py -> 1031 | -- allocate two ints on the stack 1032 | alloca $ \px -> do 1033 | nomacro_getyx w py px -- writes current cursor coords 1034 | y <- peek py 1035 | x <- peek px 1036 | return (fromIntegral y, fromIntegral x) 1037 | 1038 | -- | Get the current cursor coords, written into the two argument ints. 1039 | -- 1040 | -- > The getyx macro places the current cursor position of the given window in 1041 | -- > the two integer variables y and x. 1042 | foreign import ccall unsafe "HSCursesUtils.h hscurses_nomacro_getyx" 1043 | nomacro_getyx :: Window -> Ptr CInt -> Ptr CInt -> IO () 1044 | 1045 | touchWin :: Window -> IO () 1046 | touchWin w = throwIfErr_ "touchwin" $ touchwin w 1047 | 1048 | foreign import ccall touchwin :: Window -> IO CInt 1049 | 1050 | newPad :: Int -> Int -> IO Window 1051 | newPad nlines ncols = 1052 | throwIfNull "newpad" $ 1053 | newpad (fromIntegral nlines) (fromIntegral ncols) 1054 | 1055 | pRefresh :: Window -> Int -> Int -> Int -> Int -> Int -> Int -> IO () 1056 | pRefresh pad pminrow pmincol sminrow smincol smaxrow smaxcol = 1057 | throwIfErr_ "prefresh" $ 1058 | prefresh 1059 | pad 1060 | (fromIntegral pminrow) 1061 | (fromIntegral pmincol) 1062 | (fromIntegral sminrow) 1063 | (fromIntegral smincol) 1064 | (fromIntegral smaxrow) 1065 | (fromIntegral smaxcol) 1066 | 1067 | delWin :: Window -> IO () 1068 | delWin w = throwIfErr_ "delwin" $ delwin w 1069 | 1070 | data Border = Border 1071 | { ls :: Char 1072 | , rs :: Char 1073 | , ts :: Char 1074 | , bs :: Char 1075 | , tl :: Char 1076 | , tr :: Char 1077 | , bl :: Char 1078 | , br :: Char 1079 | } 1080 | 1081 | defaultBorder :: Border 1082 | defaultBorder = Border '\0' '\0' '\0' '\0' '\0' '\0' '\0' '\0' 1083 | 1084 | -- | Draw a border around the edges of a window. 'defaultBorder' is a record 1085 | -- representing all 0 parameters to wrecord. 1086 | wBorder :: Window -> Border -> IO () 1087 | wBorder w (Border ls rs ts bs tl tr bl br) = 1088 | throwIfErr_ "wborder" $ 1089 | wborder w ls' rs' ts' bs' tl' tr' bl' br' 1090 | where 1091 | ls' = castCharToCChar ls 1092 | rs' = castCharToCChar rs 1093 | ts' = castCharToCChar ts 1094 | bs' = castCharToCChar bs 1095 | tl' = castCharToCChar tl 1096 | tr' = castCharToCChar tr 1097 | bl' = castCharToCChar bl 1098 | br' = castCharToCChar br 1099 | 1100 | foreign import ccall unsafe 1101 | prefresh :: Window -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt 1102 | 1103 | foreign import ccall unsafe 1104 | newpad :: CInt -> CInt -> IO Window 1105 | 1106 | foreign import ccall unsafe 1107 | delwin :: Window -> IO CInt 1108 | 1109 | foreign import ccall unsafe 1110 | wborder :: Window -> CChar -> CChar -> CChar -> CChar -> CChar -> CChar -> CChar -> CChar -> IO CInt 1111 | 1112 | newWin :: Int -> Int -> Int -> Int -> IO Window 1113 | newWin nlines ncolumn begin_y begin_x = 1114 | throwIfNull "newwin" $ 1115 | newwin (fi nlines) (fi ncolumn) (fi begin_y) (fi begin_x) 1116 | 1117 | foreign import ccall unsafe 1118 | newwin :: CInt -> CInt -> CInt -> CInt -> IO Window 1119 | 1120 | wClrToEol :: Window -> IO () 1121 | wClrToEol w = throwIfErr_ "wclrtoeol" $ wclrtoeol w 1122 | 1123 | foreign import ccall unsafe wclrtoeol :: Window -> IO CInt 1124 | 1125 | -- | > The getch, wgetch, mvgetch and mvwgetch, routines read a 1126 | -- > character from the window. 1127 | #if defined(HAVE_LIBPDCURSES) || defined (HAVE_LIBPDCURSESW) 1128 | foreign import ccall unsafe "HSCurses.h hscurses_nomacro_getch" getch :: IO CInt 1129 | #else 1130 | foreign import ccall unsafe "HSCurses.h getch" getch :: IO CInt 1131 | #endif 1132 | 1133 | foreign import ccall unsafe flushinp :: IO CInt 1134 | 1135 | foreign import ccall unsafe "HSCurses.h noqiflush" noqiflush :: IO () 1136 | 1137 | foreign import ccall unsafe "HSCurses.h beep" c_beep :: IO CInt 1138 | foreign import ccall unsafe "HSCurses.h flash" c_flash :: IO CInt 1139 | 1140 | beep :: IO () 1141 | beep = do 1142 | br <- c_beep 1143 | when (br /= (# const OK)) (c_flash >> return ()) 1144 | 1145 | -- | A mapping of curses keys to Haskell values. 1146 | data Key 1147 | = KeyChar Char 1148 | | KeyBreak 1149 | | KeyDown 1150 | | KeyUp 1151 | | KeyLeft 1152 | | KeyRight 1153 | | KeyHome 1154 | | KeyBackspace 1155 | | KeyF Int 1156 | | KeyDL 1157 | | KeyIL 1158 | | KeyDC 1159 | | KeyIC 1160 | | KeyEIC 1161 | | KeyClear 1162 | | KeyEOS 1163 | | KeyEOL 1164 | | KeySF 1165 | | KeySR 1166 | | KeyNPage 1167 | | KeyPPage 1168 | | KeySTab 1169 | | KeyCTab 1170 | | KeyCATab 1171 | | KeyEnter 1172 | | KeySReset 1173 | | KeyReset 1174 | | KeyPrint 1175 | | KeyLL 1176 | | KeyA1 1177 | | KeyA3 1178 | | KeyB2 1179 | | KeyC1 1180 | | KeyC3 1181 | | KeyBTab 1182 | | KeyBeg 1183 | | KeyCancel 1184 | | KeyClose 1185 | | KeyCommand 1186 | | KeyCopy 1187 | | KeyCreate 1188 | | KeyEnd 1189 | | KeyExit 1190 | | KeyFind 1191 | | KeyHelp 1192 | | KeyMark 1193 | | KeyMessage 1194 | | KeyMove 1195 | | KeyNext 1196 | | KeyOpen 1197 | | KeyOptions 1198 | | KeyPrevious 1199 | | KeyRedo 1200 | | KeyReference 1201 | | KeyRefresh 1202 | | KeyReplace 1203 | | KeyRestart 1204 | | KeyResume 1205 | | KeySave 1206 | | KeySBeg 1207 | | KeySCancel 1208 | | KeySCommand 1209 | | KeySCopy 1210 | | KeySCreate 1211 | | KeySDC 1212 | | KeySDL 1213 | | KeySelect 1214 | | KeySEnd 1215 | | KeySEOL 1216 | | KeySExit 1217 | | KeySFind 1218 | | KeySHelp 1219 | | KeySHome 1220 | | KeySIC 1221 | | KeySLeft 1222 | | KeySMessage 1223 | | KeySMove 1224 | | KeySNext 1225 | | KeySOptions 1226 | | KeySPrevious 1227 | | KeySPrint 1228 | | KeySRedo 1229 | | KeySReplace 1230 | | KeySRight 1231 | | KeySRsume 1232 | | KeySSave 1233 | | KeySSuspend 1234 | | KeySUndo 1235 | | KeySuspend 1236 | | KeyUndo 1237 | | KeyResize 1238 | | KeyMouse 1239 | | KeyUnknown Int 1240 | deriving (Eq, Show) 1241 | 1242 | decodeKey :: CInt -> Key 1243 | decodeKey key = case key of 1244 | _ | key >= 0 && key <= 255 -> KeyChar (chr (fromIntegral key)) 1245 | (#const KEY_BREAK) -> KeyBreak 1246 | (#const KEY_DOWN) -> KeyDown 1247 | (#const KEY_UP) -> KeyUp 1248 | (#const KEY_LEFT) -> KeyLeft 1249 | (#const KEY_RIGHT) -> KeyRight 1250 | (#const KEY_HOME) -> KeyHome 1251 | (#const KEY_BACKSPACE) -> KeyBackspace 1252 | _ | key >= (#const KEY_F0) && key <= (#const KEY_F(63)) 1253 | -> KeyF (fromIntegral (key - #const KEY_F0)) 1254 | (#const KEY_DL) -> KeyDL 1255 | (#const KEY_IL) -> KeyIL 1256 | (#const KEY_DC) -> KeyDC 1257 | (#const KEY_IC) -> KeyIC 1258 | (#const KEY_EIC) -> KeyEIC 1259 | (#const KEY_CLEAR) -> KeyClear 1260 | (#const KEY_EOS) -> KeyEOS 1261 | (#const KEY_EOL) -> KeyEOL 1262 | (#const KEY_SF) -> KeySF 1263 | (#const KEY_SR) -> KeySR 1264 | (#const KEY_NPAGE) -> KeyNPage 1265 | (#const KEY_PPAGE) -> KeyPPage 1266 | (#const KEY_STAB) -> KeySTab 1267 | (#const KEY_CTAB) -> KeyCTab 1268 | (#const KEY_CATAB) -> KeyCATab 1269 | (#const KEY_ENTER) -> KeyEnter 1270 | (#const KEY_SRESET) -> KeySReset 1271 | (#const KEY_RESET) -> KeyReset 1272 | (#const KEY_PRINT) -> KeyPrint 1273 | (#const KEY_LL) -> KeyLL 1274 | (#const KEY_A1) -> KeyA1 1275 | (#const KEY_A3) -> KeyA3 1276 | (#const KEY_B2) -> KeyB2 1277 | (#const KEY_C1) -> KeyC1 1278 | (#const KEY_C3) -> KeyC3 1279 | (#const KEY_BTAB) -> KeyBTab 1280 | (#const KEY_BEG) -> KeyBeg 1281 | (#const KEY_CANCEL) -> KeyCancel 1282 | (#const KEY_CLOSE) -> KeyClose 1283 | (#const KEY_COMMAND) -> KeyCommand 1284 | (#const KEY_COPY) -> KeyCopy 1285 | (#const KEY_CREATE) -> KeyCreate 1286 | (#const KEY_END) -> KeyEnd 1287 | (#const KEY_EXIT) -> KeyExit 1288 | (#const KEY_FIND) -> KeyFind 1289 | (#const KEY_HELP) -> KeyHelp 1290 | (#const KEY_MARK) -> KeyMark 1291 | (#const KEY_MESSAGE) -> KeyMessage 1292 | (#const KEY_MOVE) -> KeyMove 1293 | (#const KEY_NEXT) -> KeyNext 1294 | (#const KEY_OPEN) -> KeyOpen 1295 | (#const KEY_OPTIONS) -> KeyOptions 1296 | (#const KEY_PREVIOUS) -> KeyPrevious 1297 | (#const KEY_REDO) -> KeyRedo 1298 | (#const KEY_REFERENCE) -> KeyReference 1299 | (#const KEY_REFRESH) -> KeyRefresh 1300 | (#const KEY_REPLACE) -> KeyReplace 1301 | (#const KEY_RESTART) -> KeyRestart 1302 | (#const KEY_RESUME) -> KeyResume 1303 | (#const KEY_SAVE) -> KeySave 1304 | (#const KEY_SBEG) -> KeySBeg 1305 | (#const KEY_SCANCEL) -> KeySCancel 1306 | (#const KEY_SCOMMAND) -> KeySCommand 1307 | (#const KEY_SCOPY) -> KeySCopy 1308 | (#const KEY_SCREATE) -> KeySCreate 1309 | (#const KEY_SDC) -> KeySDC 1310 | (#const KEY_SDL) -> KeySDL 1311 | (#const KEY_SELECT) -> KeySelect 1312 | (#const KEY_SEND) -> KeySEnd 1313 | (#const KEY_SEOL) -> KeySEOL 1314 | (#const KEY_SEXIT) -> KeySExit 1315 | (#const KEY_SFIND) -> KeySFind 1316 | (#const KEY_SHELP) -> KeySHelp 1317 | (#const KEY_SHOME) -> KeySHome 1318 | (#const KEY_SIC) -> KeySIC 1319 | (#const KEY_SLEFT) -> KeySLeft 1320 | (#const KEY_SMESSAGE) -> KeySMessage 1321 | (#const KEY_SMOVE) -> KeySMove 1322 | (#const KEY_SNEXT) -> KeySNext 1323 | (#const KEY_SOPTIONS) -> KeySOptions 1324 | (#const KEY_SPREVIOUS) -> KeySPrevious 1325 | (#const KEY_SPRINT) -> KeySPrint 1326 | (#const KEY_SREDO) -> KeySRedo 1327 | (#const KEY_SREPLACE) -> KeySReplace 1328 | (#const KEY_SRIGHT) -> KeySRight 1329 | (#const KEY_SRSUME) -> KeySRsume 1330 | (#const KEY_SSAVE) -> KeySSave 1331 | (#const KEY_SSUSPEND) -> KeySSuspend 1332 | (#const KEY_SUNDO) -> KeySUndo 1333 | (#const KEY_SUSPEND) -> KeySuspend 1334 | (#const KEY_UNDO) -> KeyUndo 1335 | #ifdef KEY_RESIZE 1336 | (#const KEY_RESIZE) -> KeyResize 1337 | #endif 1338 | #ifdef KEY_MOUSE 1339 | (#const KEY_MOUSE) -> KeyMouse 1340 | #endif 1341 | _ -> KeyUnknown (fromIntegral key) 1342 | 1343 | keyResizeCode :: Maybe CInt 1344 | #ifdef KEY_RESIZE 1345 | keyResizeCode = Just (#const KEY_RESIZE) 1346 | #else 1347 | keyResizeCode = Nothing 1348 | #endif 1349 | 1350 | cERR :: CInt 1351 | cERR = #const ERR 1352 | 1353 | cKEY_UP, cKEY_DOWN, cKEY_LEFT, cKEY_RIGHT :: ChType 1354 | cKEY_UP = #const KEY_UP 1355 | cKEY_DOWN = #const KEY_DOWN 1356 | cKEY_LEFT = #const KEY_LEFT 1357 | cKEY_RIGHT = #const KEY_RIGHT 1358 | 1359 | cTRUE :: NBool 1360 | cTRUE = #const TRUE 1361 | 1362 | -- ncurses ungetch and Haskell's threadWaitRead do not work together well. 1363 | -- So I decided to implement my own input queue. 1364 | ungetCh :: (Integral a) => a -> IO () 1365 | ungetCh i = do 1366 | debug "ungetCh called" 1367 | writeChan inputBuf (BufDirect (fi i)) 1368 | 1369 | data BufData 1370 | = -- | Data directly available 1371 | BufDirect CInt 1372 | | -- | Data can be obtained by calling getch 1373 | DataViaGetch 1374 | 1375 | inputBuf :: Chan BufData 1376 | inputBuf = unsafePerformIO newChan 1377 | {-# NOINLINE inputBuf #-} 1378 | 1379 | getchToInputBuf :: IO () 1380 | getchToInputBuf = do 1381 | threadWaitRead (fi (0 :: Int)) 1382 | {- From the (n)curses manpage: 1383 | Programmers concerned about portability should be prepared for either 1384 | of two cases: (a) signal receipt does not interrupt getch; (b) signal 1385 | receipt interrupts getch and causes it to return ERR with errno set to 1386 | EINTR. Under the ncurses implementation, handled signals never inter$B!>(B 1387 | rupt getch. 1388 | -} 1389 | -- we only signalize that getch can now called without getting blocked. 1390 | -- directly calling `getch' might result in losing the character just 1391 | -- read (race condition). 1392 | debug "now input available on stdin" 1393 | writeChan inputBuf DataViaGetch 1394 | 1395 | -- | Read a single character from the window. 1396 | getCh :: IO Key 1397 | getCh = do 1398 | debug "getCh called" 1399 | tid <- forkIO getchToInputBuf 1400 | d <- readChan inputBuf 1401 | -- we can kill the thread safely, because the thread does not read any data 1402 | -- via getch 1403 | killThread tid 1404 | v <- case d of 1405 | BufDirect x -> 1406 | do debug "getCh: getting data directly from buffer" 1407 | return x 1408 | DataViaGetch -> 1409 | do debug "getCh: getting data via getch" 1410 | getch -- won't block! 1411 | case v of 1412 | (#const ERR) -> -- NO CODE IN THIS LINE 1413 | do e <- getErrno 1414 | if e `elem` [eAGAIN, eINTR] 1415 | then do debug "Curses.getCh returned eAGAIN or eINTR" 1416 | getCh 1417 | else throwErrno "HSCurses.Curses.getch" 1418 | k -> let k' = decodeKey k 1419 | in do debug ("getCh: result = " ++ show k') 1420 | return k' 1421 | 1422 | resizeTerminal :: Int -> Int -> IO () 1423 | 1424 | #ifdef HAVE_RESIZETERM 1425 | resizeTerminal a b = throwIfErr_ "resizeterm" $ resizeterm (fi a) (fi b) 1426 | 1427 | foreign import ccall unsafe "HSCurses.h resizeterm" 1428 | resizeterm :: CInt -> CInt -> IO CInt 1429 | #else 1430 | resizeTerminal _ _ = return () 1431 | #endif 1432 | 1433 | -- | The SIGWINCH signal is sent whenever the terminal size changes. This signal 1434 | -- is not available on all platforms, so it is a |Maybe| value. 1435 | 1436 | #ifdef mingw32_HOST_OS 1437 | type Signal = CInt 1438 | #endif 1439 | 1440 | cursesSigWinch :: Maybe Signal 1441 | #ifdef SIGWINCH 1442 | cursesSigWinch = Just (#const SIGWINCH) 1443 | #else 1444 | cursesSigWinch = Nothing 1445 | #endif 1446 | 1447 | -- | A test case printing out some common attributes. 1448 | cursesTest :: IO () 1449 | cursesTest = do 1450 | initScr 1451 | hc <- hasColors 1452 | when hc startColor 1453 | ccc <- canChangeColor 1454 | (ys,xs) <- scrSize 1455 | cp <- colorPairs 1456 | cs <- colors 1457 | endWin 1458 | putStrLn $ "ScreenSize: " ++ show (xs,ys) 1459 | putStrLn $ "hasColors: " ++ show hc 1460 | putStrLn $ "canChangeColor: " ++ show ccc 1461 | putStrLn $ "colorPairs: " ++ show cp 1462 | putStrLn $ "colors: " ++ show cs 1463 | 1464 | ----------------------------------------------------------------------------- 1465 | -- * Mouse routines 1466 | ----------------------------------------------------------------------------- 1467 | 1468 | data MouseEvent = MouseEvent 1469 | { mouseEventId :: CInt 1470 | , mouseEventX :: CInt 1471 | , mouseEventY :: CInt 1472 | , mouseEventZ :: CInt 1473 | , mouseEventButton :: [ButtonEvent] 1474 | } 1475 | deriving (Show) 1476 | 1477 | instance Storable MouseEvent where 1478 | sizeOf _ = (#size MEVENT) 1479 | alignment _ = (#alignment MEVENT) 1480 | peek ptr = do 1481 | id' <- (#peek MEVENT, id) ptr 1482 | x <- (#peek MEVENT, x) ptr 1483 | y <- (#peek MEVENT, y) ptr 1484 | z <- (#peek MEVENT, z) ptr 1485 | bstate :: (#type mmask_t) <- (#peek MEVENT, bstate) ptr 1486 | pure $! MouseEvent id' x y z (besFromMouseMask bstate) 1487 | poke ptr (MouseEvent id' x y z bstate) = do 1488 | (#poke MEVENT, id) ptr id' 1489 | (#poke MEVENT, x) ptr x 1490 | (#poke MEVENT, y) ptr y 1491 | (#poke MEVENT, z) ptr z 1492 | (#poke MEVENT, bstate) ptr (besToMouseMask bstate) 1493 | 1494 | foreign import ccall unsafe "HSCurses.h getmouse" 1495 | getmouse :: Ptr MouseEvent -> IO CInt 1496 | 1497 | getMouse :: (MonadIO m) => m (Maybe MouseEvent) 1498 | getMouse = liftIO $ alloca $ \ptr -> do 1499 | res <- getmouse ptr 1500 | if res == (# const OK) 1501 | then Just <$> peek ptr 1502 | else pure Nothing 1503 | 1504 | data ButtonEvent 1505 | = ButtonPressed Int 1506 | | ButtonReleased Int 1507 | | ButtonClicked Int 1508 | | ButtonDoubleClicked Int 1509 | | ButtonTripleClicked Int 1510 | | ButtonShift 1511 | | ButtonControl 1512 | | ButtonAlt 1513 | deriving (Eq, Show) 1514 | 1515 | withMouseEventMask :: (MonadIO m) => [ButtonEvent] -> m a -> m a 1516 | withAllMouseEvents :: (MonadIO m) => m a -> m a 1517 | 1518 | #ifdef KEY_MOUSE 1519 | 1520 | foreign import ccall unsafe "HSCurses.h mousemask" 1521 | mousemask :: (#type mmask_t) -> Ptr (#type mmask_t) -> IO (#type mmask_t) 1522 | 1523 | -- TODO: bracket instead? 1524 | withMouseEventMask bes action = do 1525 | ov <- liftIO $ alloca (\a -> mousemask (besToMouseMask bes) a >> peek a) 1526 | r <- action 1527 | liftIO $ mousemask ov nullPtr 1528 | return r 1529 | 1530 | withAllMouseEvents action = do 1531 | ov <- liftIO $ alloca (\a -> mousemask (#const ALL_MOUSE_EVENTS) a >> peek a) 1532 | r <- action 1533 | liftIO $ mousemask ov nullPtr 1534 | return r 1535 | 1536 | besToMouseMask :: [ButtonEvent] -> (#type mmask_t) 1537 | besToMouseMask bes = foldl' (.|.) 0 (map cb bes) where 1538 | cb (ButtonPressed 1) = (#const BUTTON1_PRESSED) 1539 | cb (ButtonPressed 2) = (#const BUTTON2_PRESSED) 1540 | cb (ButtonPressed 3) = (#const BUTTON3_PRESSED) 1541 | cb (ButtonPressed 4) = (#const BUTTON4_PRESSED) 1542 | cb (ButtonReleased 1) = (#const BUTTON1_RELEASED) 1543 | cb (ButtonReleased 2) = (#const BUTTON2_RELEASED) 1544 | cb (ButtonReleased 3) = (#const BUTTON3_RELEASED) 1545 | cb (ButtonReleased 4) = (#const BUTTON4_RELEASED) 1546 | cb (ButtonClicked 1) = (#const BUTTON1_CLICKED) 1547 | cb (ButtonClicked 2) = (#const BUTTON2_CLICKED) 1548 | cb (ButtonClicked 3) = (#const BUTTON3_CLICKED) 1549 | cb (ButtonClicked 4) = (#const BUTTON4_CLICKED) 1550 | cb (ButtonDoubleClicked 1) = (#const BUTTON1_DOUBLE_CLICKED) 1551 | cb (ButtonDoubleClicked 2) = (#const BUTTON2_DOUBLE_CLICKED) 1552 | cb (ButtonDoubleClicked 3) = (#const BUTTON3_DOUBLE_CLICKED) 1553 | cb (ButtonDoubleClicked 4) = (#const BUTTON4_DOUBLE_CLICKED) 1554 | cb (ButtonTripleClicked 1) = (#const BUTTON1_TRIPLE_CLICKED) 1555 | cb (ButtonTripleClicked 2) = (#const BUTTON2_TRIPLE_CLICKED) 1556 | cb (ButtonTripleClicked 3) = (#const BUTTON3_TRIPLE_CLICKED) 1557 | cb (ButtonTripleClicked 4) = (#const BUTTON4_TRIPLE_CLICKED) 1558 | #if NCURSES_MOUSE_VERSION > 1 1559 | cb (ButtonPressed 5) = (#const BUTTON5_PRESSED) 1560 | cb (ButtonReleased 5) = (#const BUTTON5_RELEASED) 1561 | cb (ButtonClicked 5) = (#const BUTTON5_CLICKED) 1562 | cb (ButtonDoubleClicked 5) = (#const BUTTON5_DOUBLE_CLICKED) 1563 | cb (ButtonTripleClicked 5) = (#const BUTTON5_TRIPLE_CLICKED) 1564 | #endif 1565 | cb ButtonShift = (#const BUTTON_SHIFT) 1566 | cb ButtonAlt = (#const BUTTON_ALT) 1567 | #ifdef BUTTON_CTRL 1568 | cb ButtonControl = (#const BUTTON_CTRL) 1569 | #else 1570 | cb ButtonControl = (#const BUTTON_CONTROL) 1571 | #endif 1572 | cb _ = 0 1573 | 1574 | besFromMouseMask :: (#type mmask_t) -> [ButtonEvent] 1575 | besFromMouseMask mmask = 1576 | foldl' 1577 | (\evts (c, evt) -> if mmask .&. c /= 0 then evt : evts else evts) 1578 | mempty 1579 | mappings 1580 | where 1581 | mappings = 1582 | [ ((#const BUTTON1_PRESSED), ButtonPressed 1) 1583 | , ((#const BUTTON2_PRESSED), ButtonPressed 2) 1584 | , ((#const BUTTON3_PRESSED), ButtonPressed 3) 1585 | , ((#const BUTTON4_PRESSED), ButtonPressed 4) 1586 | , ((#const BUTTON1_RELEASED), ButtonReleased 1) 1587 | , ((#const BUTTON2_RELEASED), ButtonReleased 2) 1588 | , ((#const BUTTON3_RELEASED), ButtonReleased 3) 1589 | , ((#const BUTTON4_RELEASED), ButtonReleased 4) 1590 | , ((#const BUTTON1_CLICKED), ButtonClicked 1) 1591 | , ((#const BUTTON2_CLICKED), ButtonClicked 2) 1592 | , ((#const BUTTON3_CLICKED), ButtonClicked 3) 1593 | , ((#const BUTTON4_CLICKED), ButtonClicked 4) 1594 | , ((#const BUTTON1_DOUBLE_CLICKED), ButtonDoubleClicked 1) 1595 | , ((#const BUTTON2_DOUBLE_CLICKED), ButtonDoubleClicked 2) 1596 | , ((#const BUTTON3_DOUBLE_CLICKED), ButtonDoubleClicked 3) 1597 | , ((#const BUTTON4_DOUBLE_CLICKED), ButtonDoubleClicked 4) 1598 | , ((#const BUTTON1_TRIPLE_CLICKED), ButtonTripleClicked 1) 1599 | , ((#const BUTTON2_TRIPLE_CLICKED), ButtonTripleClicked 2) 1600 | , ((#const BUTTON3_TRIPLE_CLICKED), ButtonTripleClicked 3) 1601 | , ((#const BUTTON4_TRIPLE_CLICKED), ButtonTripleClicked 4) 1602 | #if NCURSES_MOUSE_VERSION > 1 1603 | , ((#const BUTTON5_PRESSED), ButtonPressed 5) 1604 | , ((#const BUTTON5_RELEASED), ButtonReleased 5) 1605 | , ((#const BUTTON5_CLICKED), ButtonClicked 5) 1606 | , ((#const BUTTON5_DOUBLE_CLICKED), ButtonDoubleClicked 5) 1607 | , ((#const BUTTON5_TRIPLE_CLICKED), ButtonTripleClicked 5) 1608 | #endif 1609 | , ((#const BUTTON_SHIFT), ButtonShift) 1610 | , ((#const BUTTON_ALT), ButtonAlt) 1611 | #ifdef BUTTON_CTRL 1612 | , ((#const BUTTON_CTRL), ButtonControl) 1613 | #else 1614 | , ((#const BUTTON_CONTROL), ButtonControl) 1615 | #endif 1616 | ] 1617 | 1618 | #else 1619 | 1620 | withMouseEventMask _ a = a 1621 | withAllMouseEvents = id 1622 | 1623 | #endif 1624 | 1625 | ulCorner :: Char 1626 | ulCorner = chr 0x250C 1627 | 1628 | llCorner :: Char 1629 | llCorner = chr 0x2514 1630 | 1631 | urCorner :: Char 1632 | urCorner = chr 0x2510 1633 | 1634 | lrCorner :: Char 1635 | lrCorner = chr 0x2518 1636 | 1637 | rTee :: Char 1638 | rTee = chr 0x2524 1639 | 1640 | lTee :: Char 1641 | lTee = chr 0x251C 1642 | 1643 | bTee :: Char 1644 | bTee = chr 0x2534 1645 | 1646 | tTee :: Char 1647 | tTee = chr 0x252C 1648 | 1649 | hLine :: Char 1650 | hLine = chr 0x2500 1651 | 1652 | vLine :: Char 1653 | vLine = chr 0x2502 1654 | 1655 | plus :: Char 1656 | plus = chr 0x253C 1657 | 1658 | s1 :: Char 1659 | s1 = chr 0x23BA -- was: 0xF800 1660 | 1661 | s9 :: Char 1662 | s9 = chr 0x23BD -- was: 0xF804 1663 | 1664 | diamond :: Char 1665 | diamond = chr 0x25C6 1666 | 1667 | ckBoard :: Char 1668 | ckBoard = chr 0x2592 1669 | 1670 | degree :: Char 1671 | degree = chr 0x00B0 1672 | 1673 | plMinus :: Char 1674 | plMinus = chr 0x00B1 1675 | 1676 | bullet :: Char 1677 | bullet = chr 0x00B7 1678 | 1679 | lArrow :: Char 1680 | lArrow = chr 0x2190 1681 | 1682 | rArrow :: Char 1683 | rArrow = chr 0x2192 1684 | 1685 | dArrow :: Char 1686 | dArrow = chr 0x2193 1687 | 1688 | uArrow :: Char 1689 | uArrow = chr 0x2191 1690 | 1691 | board :: Char 1692 | board = chr 0x2591 1693 | 1694 | lantern :: Char 1695 | lantern = chr 0x256C 1696 | 1697 | block :: Char 1698 | block = chr 0x2588 1699 | 1700 | s3 :: Char 1701 | s3 = chr 0x23BB -- was: 0xF801 1702 | 1703 | s7 :: Char 1704 | s7 = chr 0x23BC -- was: 0xF803 1705 | 1706 | lEqual :: Char 1707 | lEqual = chr 0x2264 1708 | 1709 | gEqual :: Char 1710 | gEqual = chr 0x2265 1711 | 1712 | pi :: Char 1713 | pi = chr 0x03C0 1714 | 1715 | nEqual :: Char 1716 | nEqual = chr 0x2260 1717 | 1718 | sterling :: Char 1719 | sterling = chr 0x00A3 1720 | 1721 | recognize :: Char -> IO a -> (ChType -> IO a) -> IO a 1722 | recognize _ch noConvert _convert = noConvert -- Handle the most common case first. 1723 | -------------------------------------------------------------------------------- /UI/HSCurses/CursesHelper.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- 4 | -- Copyright (C) 2005-2011 Stefan Wehr 5 | -- 6 | -- Derived from: yi/Curses/UI.hs 7 | -- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons 8 | -- Released under the GPL, granted permission to release this module 9 | -- under the LGPL. 10 | -- 11 | -- Derived from: riot/UI.hs 12 | -- Copyright (c) Tuomo Valkonen 2004. 13 | -- Released under the GPL, granted permission to release this module 14 | -- under the LGPL. 15 | 16 | -- This library is free software; you can redistribute it and/or 17 | -- modify it under the terms of the GNU Lesser General Public 18 | -- License as published by the Free Software Foundation; either 19 | -- version 2.1 of the License, or (at your option) any later version. 20 | -- 21 | -- This library is distributed in the hope that it will be useful, 22 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of 23 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 24 | -- Lesser General Public License for more details. 25 | -- 26 | -- You should have received a copy of the GNU Lesser General Public 27 | -- License along with this library; if not, write to the Free Software 28 | -- Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 29 | 30 | module UI.HSCurses.CursesHelper ( 31 | -- UI initialisation 32 | start, 33 | end, 34 | suspend, 35 | resizeui, 36 | 37 | -- Input 38 | getKey, 39 | 40 | -- Drawing 41 | drawLine, 42 | drawCursor, 43 | 44 | -- Navigation 45 | gotoTop, 46 | 47 | -- Colors 48 | ForegroundColor (..), 49 | BackgroundColor (..), 50 | defaultColor, 51 | black, 52 | red, 53 | green, 54 | yellow, 55 | blue, 56 | magenta, 57 | cyan, 58 | white, 59 | 60 | -- Attributes 61 | Attribute (..), 62 | convertAttributes, 63 | 64 | -- Style 65 | Style (..), 66 | CursesStyle, 67 | mkCursesStyle, 68 | changeCursesStyle, 69 | setStyle, 70 | wSetStyle, 71 | resetStyle, 72 | wResetStyle, 73 | convertStyles, 74 | defaultStyle, 75 | defaultCursesStyle, 76 | withStyle, 77 | wWithStyle, 78 | 79 | -- Keys 80 | displayKey, 81 | 82 | -- Helpers 83 | withCursor, 84 | withProgram, 85 | ) where 86 | 87 | import UI.HSCurses.Curses as Curses 88 | import UI.HSCurses.Logging 89 | 90 | import Data.Char 91 | import Data.Maybe 92 | #if MIN_VERSION_exceptions(0,6,0) 93 | import Control.Monad.Catch (MonadMask, bracket, bracket_) 94 | #else 95 | import Control.Monad.Catch (MonadCatch, bracket, bracket_) 96 | #define MonadMask MonadCatch 97 | #endif 98 | 99 | import Control.Monad 100 | import Control.Monad.Trans 101 | 102 | #ifndef mingw32_HOST_OS 103 | import System.Posix.Signals 104 | #endif 105 | 106 | -- | @start@ initializes the UI and grabs the keyboard. 107 | -- 108 | -- This function installs a handler for the SIGWINCH signal 109 | -- which writes the KEY_RESIZE key to the input queue (if KEY_RESIZE and 110 | -- and SIGWINCH are both available). 111 | start :: IO () 112 | start = do 113 | Curses.initCurses -- initialise the screen 114 | Curses.resetParams 115 | Curses.keypad Curses.stdScr True -- grab the keyboard 116 | case (Curses.cursesSigWinch, Curses.keyResizeCode) of 117 | #ifndef mingw32_HOST_OS 118 | (Just sig, Just key) -> 119 | void $ installHandler sig (Catch $ sigwinch sig key) Nothing 120 | #endif 121 | _ -> 122 | debug $ 123 | "cannot install SIGWINCH handler: signal=" 124 | ++ show Curses.cursesSigWinch 125 | ++ ", KEY_RESIZE=" 126 | ++ show Curses.keyResizeCode 127 | #ifndef mingw32_HOST_OS 128 | where 129 | sigwinch sig key = do 130 | debug "SIGWINCH signal received" 131 | Curses.ungetCh key 132 | void $ installHandler sig (Catch $ sigwinch sig key) Nothing 133 | #endif 134 | 135 | -- | Clean up and go home. 136 | end :: IO () 137 | end = do Curses.endWin 138 | -- Refresh is needed on linux. grr. 139 | #if NCURSES_UPDATE_AFTER_END 140 | Curses.update 141 | #endif 142 | 143 | -- | Suspend the program. 144 | suspend :: IO () 145 | #ifndef mingw32_HOST_OS 146 | suspend = raiseSignal sigTSTP 147 | #else 148 | suspend = return () 149 | #endif 150 | 151 | -- | @getKey refresh@ reads a key. 152 | -- 153 | -- The @refresh@ function is used to redraw the screen when the terminal size 154 | -- changes (see the documentatio of @start@ for a discussion of the problem). 155 | getKey :: (MonadIO m) => m () -> m Key 156 | getKey refresh = do 157 | k <- liftIO $ Curses.getCh 158 | debug ("getKey: " ++ show k) 159 | case k of 160 | KeyResize -> 161 | do 162 | refresh 163 | getKey refresh 164 | _ -> return k 165 | 166 | -- | @drawLine n s@ draws @n@ characters of string @s@. 167 | drawLine :: Int -> String -> IO () 168 | -- lazy version is faster than calculating length of s 169 | drawLine w s = Curses.wAddStr Curses.stdScr $! take w (s ++ repeat ' ') 170 | 171 | -- | Draw the cursor at the given position. 172 | drawCursor :: (Int, Int) -> (Int, Int) -> IO () 173 | drawCursor (o_y, o_x) (y, x) = withCursor Curses.CursorVisible $ do 174 | gotoTop 175 | (h, w) <- scrSize 176 | Curses.wMove Curses.stdScr (min (h - 1) (o_y + y)) (min (w - 1) (o_x + x)) 177 | 178 | -- | Move cursor to origin of stdScr. 179 | gotoTop :: IO () 180 | gotoTop = Curses.wMove Curses.stdScr 0 0 181 | 182 | -- | Resize the window 183 | -- From "Writing Programs with NCURSES", by Eric S. Raymond and 184 | -- Zeyd M. Ben-Halim 185 | resizeui :: IO (Int, Int) 186 | resizeui = do 187 | Curses.endWin 188 | Curses.refresh 189 | Curses.scrSize 190 | 191 | -- | Basic colors. 192 | defaultColor :: Curses.Color 193 | defaultColor = fromJust $ Curses.color "default" 194 | 195 | black, red, green, yellow, blue, magenta, cyan, white :: Curses.Color 196 | black = fromJust $ Curses.color "black" 197 | red = fromJust $ Curses.color "red" 198 | green = fromJust $ Curses.color "green" 199 | yellow = fromJust $ Curses.color "yellow" 200 | blue = fromJust $ Curses.color "blue" 201 | magenta = fromJust $ Curses.color "magenta" 202 | cyan = fromJust $ Curses.color "cyan" 203 | white = fromJust $ Curses.color "white" 204 | 205 | -- | Converts a list of 'Curses.Color' pairs (foreground color and 206 | -- background color) into the curses representation 'Curses.Pair'. 207 | -- 208 | -- You should call this function exactly once, at application startup. 209 | -- 210 | -- (not visible outside this module) 211 | colorsToPairs :: [(Curses.Color, Curses.Color)] -> IO [Curses.Pair] 212 | colorsToPairs cs = do 213 | p <- Curses.colorPairs 214 | let nColors = length cs 215 | blackWhite = p < nColors 216 | if blackWhite 217 | then 218 | trace 219 | ( "Terminal does not support enough colors. Number of " 220 | ++ " colors requested: " 221 | ++ show nColors 222 | ++ ". Number of colors supported: " 223 | ++ show p 224 | ) 225 | return 226 | $ take nColors (repeat (Curses.Pair 0)) 227 | else mapM toPairs (zip [1 ..] cs) 228 | where 229 | toPairs (n, (fg, bg)) = 230 | let p = Curses.Pair n 231 | in do 232 | Curses.initPair p fg bg 233 | return p 234 | 235 | ------------------------------------------------------------------------ 236 | -- Nicer, user-visible color defs. 237 | -- 238 | -- We separate colors into dark and bright colors, to prevent users 239 | -- from erroneously constructing bright colors for dark backgrounds, 240 | -- which doesn't work. 241 | 242 | -- | Foreground colors. 243 | data ForegroundColor 244 | = BlackF 245 | | GreyF 246 | | DarkRedF 247 | | RedF 248 | | DarkGreenF 249 | | GreenF 250 | | BrownF 251 | | YellowF 252 | | DarkBlueF 253 | | BlueF 254 | | PurpleF 255 | | MagentaF 256 | | DarkCyanF 257 | | CyanF 258 | | WhiteF 259 | | BrightWhiteF 260 | | DefaultF 261 | deriving (Eq, Show) 262 | 263 | -- | Background colors. 264 | data BackgroundColor 265 | = BlackB 266 | | DarkRedB 267 | | DarkGreenB 268 | | BrownB 269 | | DarkBlueB 270 | | PurpleB 271 | | DarkCyanB 272 | | WhiteB 273 | | DefaultB 274 | deriving (Eq, Show) 275 | 276 | -- | Mapping abstract colours to ncurses attributes and colours 277 | -- 278 | -- (not visible outside this module) 279 | convertBg :: BackgroundColor -> ([Attribute], Curses.Color) 280 | convertBg c = case c of 281 | BlackB -> ([], black) 282 | DarkRedB -> ([], red) 283 | DarkGreenB -> ([], green) 284 | BrownB -> ([], yellow) 285 | DarkBlueB -> ([], blue) 286 | PurpleB -> ([], magenta) 287 | DarkCyanB -> ([], cyan) 288 | WhiteB -> ([], white) 289 | DefaultB -> ([], defaultColor) 290 | 291 | convertFg :: ForegroundColor -> ([Attribute], Curses.Color) 292 | convertFg c = case c of 293 | BlackF -> ([], black) 294 | GreyF -> ([Bold], black) 295 | DarkRedF -> ([], red) 296 | RedF -> ([Bold], red) 297 | DarkGreenF -> ([], green) 298 | GreenF -> ([Bold], green) 299 | BrownF -> ([], yellow) 300 | YellowF -> ([Bold], yellow) 301 | DarkBlueF -> ([], blue) 302 | BlueF -> ([Bold], blue) 303 | PurpleF -> ([], magenta) 304 | MagentaF -> ([Bold], magenta) 305 | DarkCyanF -> ([], cyan) 306 | CyanF -> ([Bold], cyan) 307 | WhiteF -> ([], white) 308 | BrightWhiteF -> ([Bold], white) 309 | DefaultF -> ([], defaultColor) 310 | 311 | -- | Abstractions for some commonly used attributes. 312 | data Attribute 313 | = Bold 314 | | Underline 315 | | Dim 316 | | Reverse 317 | | Blink 318 | deriving (Eq, Show) 319 | 320 | -- | Converts an abstract attribute list into its curses representation. 321 | convertAttributes :: [Attribute] -> Curses.Attr 322 | convertAttributes = 323 | foldr setAttrs Curses.attr0 324 | where 325 | setAttrs Bold = setBoldA 326 | setAttrs Underline = setUnderlineA 327 | setAttrs Dim = setDimA 328 | setAttrs Reverse = setReverseA 329 | setAttrs Blink = setBlinkA 330 | 331 | setBoldA 332 | , setUnderlineA 333 | , setDimA 334 | , setReverseA 335 | , setBlinkA :: 336 | Curses.Attr -> Curses.Attr 337 | setBoldA = flip Curses.setBold True 338 | setUnderlineA = flip Curses.setUnderline True 339 | setDimA = flip Curses.setDim True 340 | setReverseA = flip Curses.setReverse True 341 | setBlinkA = flip Curses.setBlink True 342 | 343 | -- | A human-readable style. 344 | data Style 345 | = Style ForegroundColor BackgroundColor 346 | | AttributeStyle [Attribute] ForegroundColor BackgroundColor 347 | | ColorlessStyle [Attribute] 348 | deriving (Eq, Show) 349 | 350 | defaultStyle :: Style 351 | defaultStyle = Style DefaultF DefaultB 352 | 353 | -- | A style which uses the internal curses representations for 354 | -- attributes and colors. 355 | data CursesStyle 356 | = CursesStyle Curses.Attr Curses.Pair 357 | | ColorlessCursesStyle Curses.Attr 358 | deriving (Eq, Show) 359 | 360 | mkCursesStyle :: [Attribute] -> CursesStyle 361 | mkCursesStyle attrs = ColorlessCursesStyle (convertAttributes attrs) 362 | 363 | -- | Changes the attributes of the given CursesStyle. 364 | changeCursesStyle :: CursesStyle -> [Attribute] -> CursesStyle 365 | changeCursesStyle (CursesStyle _ p) attrs = 366 | CursesStyle (convertAttributes attrs) p 367 | changeCursesStyle _ attrs = ColorlessCursesStyle (convertAttributes attrs) 368 | 369 | defaultCursesStyle :: CursesStyle 370 | defaultCursesStyle = CursesStyle Curses.attr0 (Curses.Pair 0) 371 | 372 | -- | Reset the screen to normal values 373 | resetStyle :: IO () 374 | resetStyle = wResetStyle Curses.stdScr 375 | 376 | wResetStyle :: Curses.Window -> IO () 377 | wResetStyle = flip wSetStyle defaultCursesStyle 378 | 379 | -- | Manipulate the current style of the standard screen 380 | setStyle :: CursesStyle -> IO () 381 | setStyle = wSetStyle Curses.stdScr 382 | 383 | wSetStyle :: Curses.Window -> CursesStyle -> IO () 384 | wSetStyle window (CursesStyle a p) = Curses.wAttrSet window (a, p) 385 | wSetStyle window (ColorlessCursesStyle a) = do 386 | (_, p) <- Curses.wAttrGet window 387 | Curses.wAttrSet window (a, p) 388 | 389 | withStyle :: (MonadIO m, MonadMask m) => CursesStyle -> m a -> m a 390 | withStyle = wWithStyle Curses.stdScr 391 | 392 | wWithStyle :: (MonadIO m, MonadMask m) => Curses.Window -> CursesStyle -> m a -> m a 393 | wWithStyle window style action = 394 | bracket 395 | ( liftIO $ do 396 | old <- Curses.wAttrGet window -- before 397 | wSetStyle window style 398 | return old 399 | ) 400 | (\old -> liftIO $ Curses.wAttrSet window old) -- after 401 | (\_ -> action) -- do this 402 | 403 | -- | Converts a list of human-readable styles into the corresponding 404 | -- curses representation. 405 | -- 406 | -- This function should be called exactly once at application startup 407 | -- for all styles of the application. 408 | convertStyles :: [Style] -> IO [CursesStyle] 409 | convertStyles styleList = do 410 | let (attrs, cs) = unzip $ map convertStyle styleList 411 | cursesAttrs = map convertAttributes attrs 412 | cursesPairs <- colorsToPairs' cs 413 | let res = zipWith toCursesStyle cursesAttrs cursesPairs 414 | trace ("convertStyles: " ++ show (zip styleList res)) (return res) 415 | where 416 | convertStyle (Style fg bg) = convertStyle (AttributeStyle [] fg bg) 417 | convertStyle (AttributeStyle attrs fg bg) = 418 | let (afg, cfg) = convertFg fg 419 | (abg, cbg) = convertBg bg 420 | in (afg ++ abg ++ attrs, Just (cfg, cbg)) 421 | convertStyle (ColorlessStyle attrs) = (attrs, Nothing) 422 | colorsToPairs' cs = do 423 | pairs <- colorsToPairs (catMaybes cs) 424 | return $ mergeNothing cs pairs 425 | mergeNothing (Just _ : crest) (p : prest) = 426 | Just p 427 | : mergeNothing crest prest 428 | mergeNothing (Nothing : crest) ps = Nothing : mergeNothing crest ps 429 | mergeNothing _ _ = [] 430 | toCursesStyle cursesAttrs Nothing = 431 | ColorlessCursesStyle cursesAttrs 432 | toCursesStyle cursesAttrs (Just cursesPair) = 433 | CursesStyle cursesAttrs cursesPair 434 | 435 | -- | Converting keys to human-readable strings 436 | displayKey :: Key -> String 437 | displayKey (KeyChar ' ') = "" 438 | displayKey (KeyChar '\t') = "" 439 | displayKey (KeyChar '\r') = "" 440 | displayKey (KeyChar c) 441 | | isPrint c = [c] 442 | displayKey (KeyChar c) -- Control 443 | | ord '\^A' <= ord c && ord c <= ord '\^Z' = 444 | let c' = chr $ ord c - ord '\^A' + ord 'a' 445 | in '^' : [toUpper c'] 446 | displayKey (KeyChar c) = show c 447 | displayKey KeyDown = "" 448 | displayKey KeyUp = "" 449 | displayKey KeyLeft = "" 450 | displayKey KeyRight = "" 451 | displayKey KeyHome = "" 452 | displayKey KeyBackspace = "" 453 | displayKey (KeyF i) = 'F' : show i 454 | displayKey KeyNPage = "" 455 | displayKey KeyPPage = "" 456 | displayKey KeyEnter = "" 457 | displayKey KeyEnd = "" 458 | displayKey KeyIC = "" 459 | displayKey KeyDC = "" 460 | displayKey k = show k 461 | 462 | 463 | ------------------------------------------------------------------------ 464 | -- 465 | -- Other helpers 466 | -- 467 | 468 | -- | Set the cursor, and do action 469 | withCursor :: (MonadIO m, MonadMask m) => CursorVisibility -> m a -> m a 470 | withCursor nv action = 471 | bracket 472 | (liftIO $ Curses.cursSet nv) -- before 473 | (\vis -> liftIO $ Curses.cursSet vis) -- after 474 | (\_ -> action) -- do this 475 | 476 | withProgram :: (MonadIO m, MonadMask m) => m a -> m a 477 | withProgram action = 478 | withCursor CursorVisible $ 479 | bracket_ (liftIO endWin) (liftIO flushinp) action 480 | -------------------------------------------------------------------------------- /UI/HSCurses/IConv.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | 3 | -- 4 | -- Copyright (c) 2004 Tuomo Valkonen 5 | -- Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons 6 | -- Copyright (c) 2005-2011 Stefan Wehr - http://www.stefanwehr.de 7 | -- 8 | -- This library is free software; you can redistribute it and/or 9 | -- modify it under the terms of the GNU Lesser General Public 10 | -- License as published by the Free Software Foundation; either 11 | -- version 2.1 of the License, or (at your option) any later version. 12 | -- 13 | -- This library is distributed in the hope that it will be useful, 14 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 16 | -- Lesser General Public License for more details. 17 | -- 18 | -- You should have received a copy of the GNU Lesser General Public 19 | -- License along with this library; if not, write to the Free Software 20 | -- Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 21 | 22 | 23 | -- | Iconv binding 24 | 25 | #if HAVE_ICONV_H 26 | #include 27 | #endif 28 | 29 | module UI.HSCurses.IConv where 30 | 31 | import UI.HSCurses.CWString (peekUTF8StringLen, withUTF8StringLen) 32 | 33 | import System.IO.Unsafe (unsafePerformIO) 34 | 35 | #if !MIN_VERSION_base(4,7,0) 36 | import Foreign hiding (unsafePerformIO) 37 | #else 38 | import Foreign 39 | #endif 40 | 41 | import Control.Exception (Exception, bracket, try) 42 | import Foreign.C 43 | 44 | type IConv = Ptr () -- (#type iconv_t) 45 | 46 | err_ptr :: Ptr b -> Bool 47 | err_ptr p = p == (plusPtr nullPtr (-1)) 48 | 49 | throw_if_not_2_big :: String -> IO CSize -> IO CSize 50 | throw_if_not_2_big s r_ = do 51 | r <- r_ 52 | if r == fromIntegral (-1 :: Int) 53 | then do 54 | errno <- getErrno 55 | if errno /= e2BIG 56 | then 57 | throwErrno s 58 | else 59 | return r 60 | else 61 | return r 62 | 63 | iconv_open :: String -> String -> IO IConv 64 | iconv_open to from = 65 | withCString to $ 66 | \cto -> withCString from $ 67 | \cfrom -> 68 | do 69 | throwErrnoIf err_ptr "iconv_open" 70 | $ c_iconv_open cto cfrom 71 | 72 | iconv_close :: IConv -> IO () 73 | iconv_close ic = 74 | throwErrnoIfMinus1_ "iconv_close" $ c_iconv_close ic 75 | 76 | outbuf_size :: Int 77 | outbuf_size = 1024 78 | 79 | do_iconv :: ((Ptr a, Int) -> IO String) -> IConv -> (Ptr b, Int) -> IO String 80 | do_iconv get_string_fn ic (inbuf, inbuf_bytes) = 81 | alloca $ \inbuf_ptr -> 82 | alloca $ \inbytesleft_ptr -> 83 | alloca $ \outbuf_ptr -> 84 | alloca $ \outbytesleft_ptr -> 85 | allocaBytes outbuf_size $ \outbuf -> do 86 | poke (inbytesleft_ptr :: Ptr CSize) (fromIntegral inbuf_bytes) 87 | poke inbuf_ptr inbuf 88 | let loop acc = do 89 | poke (outbytesleft_ptr :: Ptr CSize) (fromIntegral outbuf_size) 90 | poke outbuf_ptr outbuf 91 | ret <- 92 | throw_if_not_2_big "c_iconv" $ 93 | c_iconv 94 | ic 95 | inbuf_ptr 96 | inbytesleft_ptr 97 | outbuf_ptr 98 | outbytesleft_ptr 99 | left <- peek outbytesleft_ptr 100 | res <- get_string_fn (castPtr outbuf, outbuf_size - fromIntegral left) 101 | if ret == fromIntegral (-1 :: Int) 102 | then 103 | loop (acc ++ res) 104 | else 105 | return (acc ++ res) 106 | loop [] 107 | 108 | with_iconv :: String -> String -> (IConv -> IO a) -> IO a 109 | with_iconv to from fn = 110 | bracket (iconv_open to from) iconv_close fn 111 | 112 | iconv_ :: String -> IConv -> IO String 113 | iconv_ str ic = 114 | withCStringLen str $ do_iconv peekCStringLen ic 115 | 116 | -- between 8-bit encodings only 117 | iconv :: (Exception e) => String -> String -> String -> Either e String 118 | iconv to from str = 119 | unsafePerformIO $ try $ with_iconv to from (iconv_ str) 120 | 121 | #ifdef HAVE_WCHAR_H 122 | 123 | cuni_charset :: [Char] 124 | cuni_charset = "WCHAR_T" 125 | 126 | peek_cuni :: (Ptr (#type wchar_t), Int) -> IO String 127 | peek_cuni (buf, bytes) = do 128 | let (chars, rembytes) = bytes `divMod` (#size wchar_t) 129 | if rembytes /= 0 then 130 | error "Conversion result contains remainder bytes." 131 | else 132 | peekCWStringLen (buf, chars) 133 | 134 | with_cuni :: String -> ((Ptr (#type wchar_t), Int) -> IO String) -> IO String 135 | with_cuni str f = 136 | withCWStringLen str $ \(s, l) -> f (s, l*(#size wchar_t)) 137 | 138 | #else 139 | 140 | -- no CF_WCHAR_SUPPORT 141 | 142 | -- Due to endianness problems, it is easiest to do this through UTF-8 143 | 144 | cuni_charset :: [Char] 145 | cuni_charset = "UTF-8" 146 | 147 | peek_cuni :: CStringLen -> IO String 148 | peek_cuni = peekUTF8StringLen 149 | 150 | with_cuni :: [Char] -> (CStringLen -> IO a) -> IO a 151 | with_cuni = withUTF8StringLen 152 | 153 | #endif 154 | 155 | to_unicode_ :: String -> String -> IO String 156 | to_unicode_ from str = 157 | with_iconv cuni_charset from $ 158 | \ic -> withCStringLen str $ do_iconv peek_cuni ic 159 | 160 | to_unicode :: (Exception e) => String -> String -> Either e String 161 | to_unicode from str = 162 | unsafePerformIO $ try $ to_unicode_ from str 163 | 164 | from_unicode_ :: String -> String -> IO String 165 | from_unicode_ to str = 166 | with_iconv to cuni_charset $ 167 | \ic -> with_cuni str $ do_iconv peekCStringLen ic 168 | 169 | from_unicode :: (Exception e) => String -> String -> Either e String 170 | from_unicode from str = 171 | unsafePerformIO $ try $ from_unicode_ from str 172 | 173 | #ifndef ICONV_LIB_PREFIX 174 | 175 | foreign import ccall unsafe "iconv.h iconv_open" 176 | c_iconv_open :: 177 | CString -> CString -> IO IConv 178 | 179 | foreign import ccall unsafe "iconv.h iconv_close" 180 | c_iconv_close :: 181 | IConv -> IO CInt 182 | 183 | foreign import ccall unsafe "iconv.h iconv" 184 | c_iconv :: 185 | IConv -> Ptr a -> Ptr CSize -> Ptr b -> Ptr CSize -> IO CSize 186 | #else 187 | 188 | foreign import ccall unsafe "iconv.h libiconv_open" 189 | c_iconv_open :: 190 | CString -> CString -> IO IConv 191 | 192 | foreign import ccall unsafe "iconv.h libiconv_close" 193 | c_iconv_close :: 194 | IConv -> IO CInt 195 | 196 | foreign import ccall unsafe "iconv.h libiconv" 197 | c_iconv :: 198 | IConv -> Ptr a -> Ptr CSize -> Ptr b -> Ptr CSize -> IO CSize 199 | #endif 200 | -------------------------------------------------------------------------------- /UI/HSCurses/Logging.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- Copyright (c) 2005-2011 Stefan Wehr - http://www.stefanwehr.de 4 | -- 5 | -- This library is free software; you can redistribute it and/or 6 | -- modify it under the terms of the GNU Lesser General Public 7 | -- License as published by the Free Software Foundation; either 8 | -- version 2.1 of the License, or (at your option) any later version. 9 | -- 10 | -- This library is distributed in the hope that it will be useful, 11 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | -- Lesser General Public License for more details. 14 | -- 15 | -- You should have received a copy of the GNU Lesser General Public 16 | -- License along with this library; if not, write to the Free Software 17 | -- Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 18 | 19 | module UI.HSCurses.Logging (trace, debug) where 20 | 21 | import Control.Monad.Trans 22 | 23 | #if DEBUG 24 | 25 | import System.IO 26 | import System.IO.Unsafe (unsafePerformIO) 27 | import qualified Data.Time as Time 28 | 29 | #endif 30 | 31 | trace :: String -> a -> a 32 | debug :: (MonadIO m) => String -> m () 33 | 34 | #if DEBUG 35 | 36 | logFile :: Handle 37 | logFile = unsafePerformIO $ do h <- openFile ".hscurses.log" AppendMode 38 | debug_ h "logging initialized" 39 | return h 40 | {-# NOINLINE logFile #-} 41 | 42 | formatTime :: IO String 43 | formatTime = do 44 | let fmt = "%Y-%m-%d %H:%M:%S%03Q" 45 | now <- Time.getZonedTime 46 | return $ Time.formatTime Time.defaultTimeLocale fmt now 47 | 48 | debug_ :: Handle -> String -> IO () 49 | debug_ f s = 50 | do ts <- formatTime 51 | hPutStrLn f ("[" ++ ts ++ "] " ++ s) 52 | hFlush f 53 | 54 | trace s x = 55 | unsafePerformIO $ do debug s 56 | return x 57 | debug s = liftIO $ debug_ logFile s 58 | 59 | #else 60 | 61 | trace _ x = x 62 | debug _ = return () 63 | 64 | #endif 65 | -------------------------------------------------------------------------------- /UI/HSCurses/Widgets.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | -- Copyright (c) 2005-2011 Stefan Wehr - http://www.stefanwehr.de 6 | -- 7 | -- This library is free software; you can redistribute it and/or 8 | -- modify it under the terms of the GNU Lesser General Public 9 | -- License as published by the Free Software Foundation; either 10 | -- version 2.1 of the License, or (at your option) any later version. 11 | -- 12 | -- This library is distributed in the hope that it will be useful, 13 | -- but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | -- Lesser General Public License for more details. 16 | -- 17 | -- You should have received a copy of the GNU Lesser General Public 18 | -- License along with this library; if not, write to the Free Software 19 | -- Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 20 | 21 | module UI.HSCurses.Widgets where 22 | 23 | import Control.Exception (assert) 24 | #if MIN_VERSION_exceptions(0,6,0) 25 | import Control.Monad.Catch (MonadMask) 26 | #else 27 | import Control.Monad.Catch (MonadCatch) 28 | #define MonadMask MonadCatch 29 | #endif 30 | import Control.Monad.Trans 31 | import Data.Char 32 | import Data.List 33 | import Data.List.NonEmpty (NonEmpty ((:|))) 34 | import qualified Data.List.NonEmpty as NonEmpty 35 | import Data.Maybe 36 | 37 | import qualified UI.HSCurses.Curses as Curses 38 | import qualified UI.HSCurses.CursesHelper as CursesH 39 | import UI.HSCurses.Logging 40 | 41 | type Pos = (Int, Int) 42 | type Offset = (Int, Int) 43 | 44 | type Size = 45 | ( Int -- height 46 | , Int -- width 47 | ) 48 | 49 | getHeight :: Size -> Int 50 | getHeight = fst 51 | 52 | getWidth :: Size -> Int 53 | getWidth = snd 54 | 55 | getYOffset :: Offset -> Int 56 | getYOffset = fst 57 | 58 | getXOffset :: Offset -> Int 59 | getXOffset = snd 60 | 61 | getYPos :: Pos -> Int 62 | getYPos = fst 63 | 64 | getXPos :: Pos -> Int 65 | getXPos = snd 66 | 67 | data Direction = DirLeft | DirRight | DirUp | DirDown 68 | deriving (Eq, Show, Ord) 69 | 70 | data HAlignment = AlignLeft | AlignCenter | AlignRight 71 | deriving (Eq, Show) 72 | 73 | data Cont a = Cont a | Done a 74 | 75 | class Widget a where 76 | draw :: Pos -> Size -> DrawingHint -> a -> IO () 77 | minSize :: a -> Size 78 | 79 | class (Widget a) => ActiveWidget a where 80 | activate :: 81 | (MonadIO m, MonadMask m) => 82 | m () -> 83 | Pos -> 84 | Size -> 85 | a -> 86 | m (a, String) 87 | 88 | type KeyHandler a = Pos -> Size -> a -> IO (Cont a) 89 | 90 | mkKeyHandler :: 91 | (Pos -> Size -> a -> a) -> 92 | KeyHandler a 93 | mkKeyHandler f pos sz w = return (Cont (f pos sz w)) 94 | 95 | -- 96 | -- Drawing 97 | -- 98 | 99 | data DrawingHint 100 | = DHNormal 101 | | DHFocus 102 | | DHActive 103 | deriving (Eq, Show, Ord) 104 | 105 | data DrawingStyle = DStyle 106 | { dstyle_normal :: CursesH.CursesStyle 107 | , dstyle_focus :: CursesH.CursesStyle 108 | , dstyle_active :: CursesH.CursesStyle 109 | } 110 | deriving (Eq, Show) 111 | 112 | mkDrawingStyle :: CursesH.CursesStyle -> DrawingStyle 113 | mkDrawingStyle defStyle = 114 | let revStyle = CursesH.changeCursesStyle defStyle [CursesH.Reverse] 115 | in DStyle 116 | { dstyle_normal = defStyle 117 | , dstyle_focus = revStyle 118 | , dstyle_active = revStyle 119 | } 120 | 121 | defaultDrawingStyle :: DrawingStyle 122 | defaultDrawingStyle = mkDrawingStyle CursesH.defaultCursesStyle 123 | _draw :: DrawingHint -> DrawingStyle -> IO a -> IO a 124 | _draw DHActive sty io = CursesH.withStyle (dstyle_active sty) io 125 | _draw DHNormal sty io = CursesH.withStyle (dstyle_normal sty) io 126 | _draw DHFocus sty io = CursesH.withStyle (dstyle_focus sty) io 127 | 128 | -- 129 | -- Helper functions for scrolling 130 | -- 131 | 132 | scrollFactor :: Double 133 | scrollFactor = 0.8 134 | 135 | scrollBy :: Int -> Int 136 | scrollBy displayLen = 137 | let amount = floor ((fromInteger . toInteger) displayLen * scrollFactor) 138 | in max (displayLen - 1) (min 1 amount) 139 | 140 | -- returns the new offset for scrolling in forward direction 141 | -- dataLen: total number of data items 142 | -- offset: the index of the first data item shown on the current page 143 | -- displayLen: the number of data items that is shown in one page 144 | scrollForward :: Int -> Int -> Int -> Int 145 | scrollForward dataLen offset displayLen = 146 | if offset + displayLen >= dataLen 147 | then offset 148 | else min (offset + scrollBy displayLen) (dataLen - displayLen) 149 | 150 | -- returns the new offset for scrolling in backward direction. 151 | -- parameters as for scrollForward 152 | scrollBackward :: t -> Int -> Int -> Int 153 | scrollBackward _ offset displayLen = 154 | if offset == 0 155 | then offset 156 | else max (offset - scrollBy displayLen) 0 157 | 158 | -- 159 | -- EmptyWidget 160 | -- 161 | 162 | data EmptyWidget = EmptyWidget Size 163 | 164 | instance Widget EmptyWidget where 165 | draw _ _ _ _ = return () 166 | minSize (EmptyWidget sz) = sz 167 | 168 | -- 169 | -- An opaque widget 170 | -- 171 | 172 | data OpaqueWidget = OpaqueWidget Size 173 | 174 | instance Widget OpaqueWidget where 175 | draw (y, x) (h, w) _ _ = 176 | let draw' n = 177 | do 178 | Curses.wMove Curses.stdScr (y + n) x 179 | CursesH.drawLine w "" 180 | in do 181 | mapM draw' (take h [0 ..]) 182 | Curses.refresh 183 | minSize (OpaqueWidget sz) = sz 184 | 185 | -- 186 | -- Widget for text input 187 | -- 188 | 189 | data EditWidget = EditWidget 190 | { ew_content :: String 191 | , ew_xoffset :: Int -- content!!xoffset is the 1st char shown 192 | , ew_xcursor :: Int -- cursor position 193 | , ew_history :: [String] 194 | , ew_historyIndex :: Int 195 | , ew_historySavedContent :: Maybe String 196 | , ew_options :: EditWidgetOptions 197 | } 198 | 199 | ew_contentPos :: EditWidget -> Int 200 | ew_contentPos ew = ew_xcursor ew + ew_xoffset ew 201 | 202 | instance Widget EditWidget where 203 | draw = drawEditWidget 204 | minSize ew = (1, ewopt_minWidth $ ew_options ew) 205 | 206 | instance ActiveWidget EditWidget where 207 | activate = activateEditWidget 208 | 209 | data EditWidgetOptions = EWOptions 210 | { ewopt_keyHandlers :: [(Curses.Key, KeyHandler EditWidget)] 211 | , ewopt_minWidth :: Int 212 | , ewopt_style :: DrawingStyle 213 | } 214 | 215 | defaultEWOptions :: EditWidgetOptions 216 | defaultEWOptions = 217 | EWOptions 218 | { ewopt_keyHandlers = editWidgetKeyHandlers 219 | , ewopt_minWidth = 8 220 | , ewopt_style = defaultDrawingStyle 221 | } 222 | 223 | newEditWidget :: EditWidgetOptions -> String -> EditWidget 224 | newEditWidget opts = 225 | editWidgetSetContent 226 | ( EditWidget 227 | { ew_content = "" 228 | , ew_xoffset = 0 229 | , ew_xcursor = 0 230 | , ew_history = [] 231 | , ew_historyIndex = -1 232 | , ew_historySavedContent = Nothing 233 | , ew_options = opts 234 | } 235 | ) 236 | 237 | editWidgetGoLeft :: 238 | Pos -> 239 | Size -> 240 | EditWidget -> 241 | IO (Cont EditWidget) 242 | editWidgetGoLeft = mkKeyHandler editWidgetGoLeft' 243 | editWidgetGoRight :: 244 | Pos -> 245 | Size -> 246 | EditWidget -> 247 | IO (Cont EditWidget) 248 | editWidgetGoRight = mkKeyHandler editWidgetGoRight' 249 | editWidgetDeleteLeft :: 250 | Pos -> 251 | Size -> 252 | EditWidget -> 253 | IO (Cont EditWidget) 254 | editWidgetDeleteLeft = mkKeyHandler editWidgetDeleteLeft' 255 | editWidgetDeleteUnderCursor :: 256 | Pos -> 257 | Size -> 258 | EditWidget -> 259 | IO (Cont EditWidget) 260 | editWidgetDeleteUnderCursor = mkKeyHandler editWidgetDeleteUnderCursor' 261 | editWidgetDeleteToEnd :: 262 | Pos -> 263 | Size -> 264 | EditWidget -> 265 | IO (Cont EditWidget) 266 | editWidgetDeleteToEnd = mkKeyHandler editWidgetDeleteToEnd' 267 | editWidgetGoHome :: 268 | Pos -> 269 | Size -> 270 | EditWidget -> 271 | IO (Cont EditWidget) 272 | editWidgetGoHome = mkKeyHandler editWidgetGoHome' 273 | editWidgetGoEnd :: 274 | Pos -> 275 | Size -> 276 | EditWidget -> 277 | IO (Cont EditWidget) 278 | editWidgetGoEnd = mkKeyHandler editWidgetGoEnd' 279 | editWidgetHistoryUp :: 280 | Pos -> 281 | Size -> 282 | EditWidget -> 283 | IO (Cont EditWidget) 284 | editWidgetHistoryUp = mkKeyHandler editWidgetHistoryUp' 285 | editWidgetHistoryDown :: 286 | Pos -> 287 | Size -> 288 | EditWidget -> 289 | IO (Cont EditWidget) 290 | editWidgetHistoryDown = mkKeyHandler editWidgetHistoryDown' 291 | 292 | editWidgetKeyHandlers :: 293 | [ ( Curses.Key 294 | , Pos -> 295 | Size -> 296 | EditWidget -> 297 | IO (Cont EditWidget) 298 | ) 299 | ] 300 | editWidgetKeyHandlers = 301 | [ (Curses.KeyLeft, editWidgetGoLeft) 302 | , (Curses.KeyRight, editWidgetGoRight) 303 | , (Curses.KeyBackspace, editWidgetDeleteLeft) 304 | , (Curses.KeyChar '\^D', editWidgetDeleteUnderCursor) 305 | , (Curses.KeyDC, editWidgetDeleteUnderCursor) 306 | , (Curses.KeyChar '\^K', editWidgetDeleteToEnd) 307 | , (Curses.KeyHome, editWidgetGoHome) 308 | , (Curses.KeyChar '\^A', editWidgetGoHome) 309 | , (Curses.KeyEnd, editWidgetGoEnd) 310 | , (Curses.KeyChar '\^E', editWidgetGoEnd) 311 | , (Curses.KeyChar '\r', editWidgetFinish) 312 | , (Curses.KeyChar '\t', editWidgetFinish) 313 | , (Curses.KeyUp, editWidgetHistoryUp) 314 | , (Curses.KeyDown, editWidgetHistoryDown) 315 | ] 316 | 317 | editWidgetGetContent :: EditWidget -> String 318 | editWidgetGetContent ew = ew_content ew 319 | editWidgetSetContent :: 320 | EditWidget -> 321 | String -> 322 | EditWidget 323 | editWidgetSetContent ew s = 324 | addToHistory (ew {ew_content = s, ew_xoffset = 0, ew_xcursor = 0}) s 325 | 326 | editWidgetGetOptions :: 327 | EditWidget -> 328 | EditWidgetOptions 329 | editWidgetGetOptions ew = ew_options ew 330 | editWidgetSetOptions :: 331 | EditWidget -> 332 | EditWidgetOptions -> 333 | EditWidget 334 | editWidgetSetOptions ew opts = ew {ew_options = opts} 335 | 336 | drawEditWidget :: Pos -> Size -> DrawingHint -> EditWidget -> IO () 337 | drawEditWidget (y, x) (_, width) hint ew = 338 | _draw hint (ewopt_style . ew_options $ ew) $ 339 | do 340 | Curses.wMove Curses.stdScr y x 341 | CursesH.drawLine width (drop (ew_xoffset ew) $ ew_content ew) 342 | Curses.refresh 343 | 344 | activateEditWidget :: 345 | (MonadIO m, MonadMask m) => 346 | m () -> 347 | Pos -> 348 | Size -> 349 | EditWidget -> 350 | m (EditWidget, String) 351 | activateEditWidget refresh pos@(y, x) sz@(_, width) ew = 352 | CursesH.withCursor Curses.CursorVisible $ processKey ew 353 | where 354 | processKey ex = 355 | do 356 | liftIO $ drawLocal ex 357 | k <- CursesH.getKey refresh 358 | case lookup k (ewopt_keyHandlers $ ew_options ex) of 359 | Nothing -> 360 | case k of 361 | Curses.KeyChar c 362 | | isAscii c && isPrint c -> 363 | processKey $ insertChar ex c 364 | _ -> processKey ex 365 | Just f -> 366 | do 367 | x' <- liftIO $ f pos sz ex 368 | case x' of 369 | Cont ex' -> processKey ex' 370 | Done ex' -> do 371 | liftIO $ drawEditWidget pos sz DHActive ex' 372 | return (ex', editWidgetGetContent ex') 373 | insertChar ew' c = 374 | let pos' = ew_contentPos ew' 375 | oldContent = ew_content ew' 376 | newContent = take pos' oldContent ++ (c : drop pos' oldContent) 377 | in editWidgetGoRight' pos' sz (ew' {ew_content = newContent}) 378 | drawLocal ew' = _draw DHActive (ewopt_style . ew_options $ ew') $ 379 | do 380 | Curses.wMove Curses.stdScr y x 381 | CursesH.drawLine width (drop (ew_xoffset ew') $ ew_content ew') 382 | Curses.wMove Curses.stdScr y (x + ew_xcursor ew') 383 | Curses.refresh 384 | 385 | editWidgetGoLeft' :: t -> t1 -> EditWidget -> EditWidget 386 | editWidgetGoLeft' _ _ ew = 387 | let newXcursor = max (ew_xcursor ew - 1) 0 388 | newXoffset = 389 | if ew_xcursor ew == 0 390 | then max (ew_xoffset ew - 1) 0 391 | else ew_xoffset ew 392 | in ew 393 | { ew_xoffset = newXoffset 394 | , ew_xcursor = newXcursor 395 | } 396 | 397 | editWidgetGoRight' :: t -> (t1, Int) -> EditWidget -> EditWidget 398 | editWidgetGoRight' _ (_, width) ew = 399 | let len = length (ew_content ew) 400 | lastChar = len - ew_xoffset ew - 1 401 | newXcursor = minimum [ew_xcursor ew + 1, lastChar + 1, width - 1] 402 | newXoffset = 403 | if ew_xcursor ew == width - 1 404 | then min (ew_xoffset ew + 1) (len - width + 1) 405 | else ew_xoffset ew 406 | in ew 407 | { ew_xoffset = newXoffset 408 | , ew_xcursor = newXcursor 409 | } 410 | 411 | editWidgetDeleteLeft' :: Pos -> Size -> EditWidget -> EditWidget 412 | editWidgetDeleteLeft' pos sz ew = 413 | let cpos = ew_contentPos ew - 1 414 | oldContent = ew_content ew 415 | newContent = take cpos oldContent ++ drop (cpos + 1) oldContent 416 | ew' = editWidgetGoLeft' pos sz (ew {ew_content = newContent}) 417 | in if ew_xcursor ew == 0 && ew_xoffset ew /= 0 418 | then editWidgetGoRight' pos sz (editWidgetGoLeft' pos sz ew') 419 | else ew' 420 | 421 | editWidgetDeleteUnderCursor' :: t -> t1 -> EditWidget -> EditWidget 422 | editWidgetDeleteUnderCursor' _ _ ew = 423 | let pos = ew_contentPos ew 424 | oldContent = ew_content ew 425 | newContent = take pos oldContent ++ drop (pos + 1) oldContent 426 | in ew {ew_content = newContent} 427 | 428 | editWidgetDeleteToEnd' :: t -> t1 -> EditWidget -> EditWidget 429 | editWidgetDeleteToEnd' _ _ ew = 430 | let pos = ew_contentPos ew 431 | oldContent = ew_content ew 432 | newContent = take pos oldContent 433 | in ew {ew_content = newContent} 434 | 435 | editWidgetGoHome' :: t -> t1 -> EditWidget -> EditWidget 436 | editWidgetGoHome' _ _ ew = 437 | ew 438 | { ew_xcursor = 0 439 | , ew_xoffset = 0 440 | } 441 | 442 | editWidgetGoEnd' :: Pos -> Size -> EditWidget -> EditWidget 443 | editWidgetGoEnd' pos sz ew = 444 | let cpos = ew_contentPos ew 445 | len = length (ew_content ew) 446 | in if cpos == len 447 | then ew 448 | else editWidgetGoEnd' pos sz (editWidgetGoRight' pos sz ew) 449 | 450 | editWidgetFinish :: (Monad m) => t -> t1 -> EditWidget -> m (Cont EditWidget) 451 | editWidgetFinish _ _ ew = return (Done (addToHistory ew (ew_content ew))) 452 | 453 | maxHistoryLength :: Int 454 | maxHistoryLength = 50 455 | 456 | addToHistory :: EditWidget -> [Char] -> EditWidget 457 | addToHistory ew s = 458 | let newHist = 459 | if not (null s) 460 | then take maxHistoryLength (s : ew_history ew) 461 | else ew_history ew 462 | in ew 463 | { ew_history = newHist 464 | , ew_historyIndex = -1 465 | , ew_historySavedContent = Nothing 466 | } 467 | 468 | editWidgetHistoryUp' :: t -> t1 -> EditWidget -> EditWidget 469 | editWidgetHistoryUp' _ _ ew = editWidgetHistory (+) ew 470 | 471 | editWidgetHistoryDown' :: t -> t1 -> EditWidget -> EditWidget 472 | editWidgetHistoryDown' _ _ ew = editWidgetHistory (-) ew 473 | 474 | -- ew_historyList: list of history items, i.e. non-null strings which were 475 | -- entered into the widget and confirmed with ENTER or which were added 476 | -- via editWidgetSetContent. 477 | -- ew_historyIndex: the index of the history item shown in the widget. The 478 | -- value -1 means that the value saved in ew_historySavedContent should 479 | -- be shown. 480 | editWidgetHistory :: (Num t) => (Int -> t -> Int) -> EditWidget -> EditWidget 481 | editWidgetHistory op ew = 482 | let i = ew_historyIndex ew 483 | l = ew_history ew 484 | j = i `op` 1 485 | in if j >= 0 && j < length l 486 | then 487 | let savedContent = 488 | case ew_historySavedContent ew of 489 | Nothing -> Just (ew_content ew) 490 | x -> x 491 | in ew 492 | { ew_historyIndex = j 493 | , ew_content = l !! j 494 | , ew_historySavedContent = savedContent 495 | , ew_xcursor = 0 496 | , ew_xoffset = 0 497 | } 498 | else 499 | if j == -1 500 | then case ew_historySavedContent ew of 501 | Nothing -> ew 502 | Just x -> 503 | ew 504 | { ew_content = x 505 | , ew_historyIndex = j 506 | , ew_xcursor = 0 507 | , ew_xoffset = 0 508 | } 509 | else ew 510 | 511 | -- 512 | -- Text widget 513 | -- 514 | 515 | data TextWidget = TextWidget 516 | { tw_text :: String 517 | , tw_yoffset :: Int 518 | , tw_xoffset :: Int 519 | , tw_options :: TextWidgetOptions 520 | } 521 | deriving (Eq, Show) 522 | 523 | instance Widget TextWidget where 524 | draw = drawTextWidget 525 | minSize tw = 526 | case twopt_size $ tw_options tw of 527 | TWSizeDefault -> 528 | let l = lines (tw_text tw) 529 | in (length l, if null l then 0 else maximum (map length l)) 530 | TWSizeFixed sz -> sz 531 | 532 | data TextWidgetSize 533 | = TWSizeDefault -- minimal size determined by content 534 | | TWSizeFixed Size -- minimal size is fixed, content is 535 | -- possibly cut off 536 | deriving (Eq, Show) 537 | 538 | {- 539 | \| Autowrap -- minimal width determined by content, 540 | -- but lines are wrapped if necessary 541 | -} 542 | 543 | data TextWidgetOptions = TWOptions 544 | { twopt_size :: TextWidgetSize 545 | , twopt_style :: DrawingStyle 546 | , twopt_halign :: HAlignment 547 | } 548 | deriving (Eq, Show) 549 | 550 | defaultTWOptions :: TextWidgetOptions 551 | defaultTWOptions = 552 | TWOptions 553 | { twopt_size = TWSizeDefault 554 | , twopt_style = defaultDrawingStyle 555 | , twopt_halign = AlignLeft 556 | } 557 | 558 | newTextWidget :: TextWidgetOptions -> String -> TextWidget 559 | newTextWidget opts s = 560 | TextWidget 561 | { tw_text = s 562 | , tw_yoffset = 0 563 | , tw_xoffset = 0 564 | , tw_options = opts 565 | } 566 | 567 | drawTextWidget :: Pos -> Size -> DrawingHint -> TextWidget -> IO () 568 | drawTextWidget (y, x) (height, width) hint tw = 569 | let ly = take height $ drop (tw_yoffset tw) (lines (tw_text tw)) 570 | l = take height $ (map (drop (tw_xoffset tw)) ly ++ repeat []) 571 | l' = map (align (twopt_halign $ tw_options tw) width ' ') l 572 | in -- trace ("drawing text widget at " ++ show pos ++ " with size " ++ show sz) $ 573 | do 574 | _draw 575 | hint 576 | (twopt_style . tw_options $ tw) 577 | (mapM drawLine $ zip l' [0 ..]) 578 | Curses.refresh 579 | where 580 | drawLine (s, i) = 581 | do 582 | Curses.wMove Curses.stdScr (y + i) x 583 | CursesH.drawLine width s 584 | 585 | textWidgetGetText :: TextWidget -> String 586 | textWidgetGetText = tw_text 587 | 588 | textWidgetSetText :: TextWidget -> String -> TextWidget 589 | textWidgetSetText tw s = tw {tw_text = s} 590 | 591 | textWidgetScrollDown :: Size -> TextWidget -> TextWidget 592 | textWidgetScrollDown (h, _) tw = 593 | let dataLen = length $ lines (tw_text tw) 594 | offset = tw_yoffset tw 595 | in tw {tw_yoffset = scrollForward dataLen offset h} 596 | 597 | textWidgetScrollUp :: Size -> TextWidget -> TextWidget 598 | textWidgetScrollUp (h, _) tw = 599 | let dataLen = length $ lines (tw_text tw) 600 | offset = tw_yoffset tw 601 | in tw {tw_yoffset = scrollBackward dataLen offset h} 602 | 603 | textWidgetScrollLeft :: Size -> TextWidget -> TextWidget 604 | textWidgetScrollLeft (_, w) tw = 605 | let dataLen = length $ lines (tw_text tw) 606 | offset = tw_xoffset tw 607 | in tw {tw_xoffset = scrollBackward dataLen offset w} 608 | 609 | textWidgetScrollRight :: Size -> TextWidget -> TextWidget 610 | textWidgetScrollRight (_, w) tw = 611 | let dataLen = length $ lines (tw_text tw) 612 | offset = tw_xoffset tw 613 | in tw {tw_xoffset = scrollForward dataLen offset w} 614 | 615 | -- 616 | -- Table widget 617 | -- 618 | 619 | data TableCell 620 | = forall w. (Widget w) => TableCell w 621 | | forall w. (ActiveWidget w) => ActiveTableCell w 622 | 623 | isActive :: TableCell -> Bool 624 | isActive (TableCell _) = False 625 | isActive (ActiveTableCell _) = True 626 | 627 | instance Widget TableCell where 628 | draw pos sz hint (TableCell w) = draw pos sz hint w 629 | draw pos sz hint (ActiveTableCell w) = draw pos sz hint w 630 | minSize (TableCell w) = minSize w 631 | minSize (ActiveTableCell w) = minSize w 632 | 633 | _activateTableCell :: 634 | (MonadIO m, MonadMask m) => 635 | m () -> 636 | Pos -> 637 | Size -> 638 | TableCell -> 639 | m (TableCell, String) 640 | _activateTableCell _ _ _ (TableCell _) = 641 | error "_activateTableCell: cannot activate non-active cell!" 642 | _activateTableCell refresh pos sz (ActiveTableCell w) = 643 | do 644 | (new, res) <- activate refresh pos sz w 645 | return (ActiveTableCell new, res) 646 | 647 | type Row = [TableCell] 648 | 649 | singletonRow :: TableCell -> Row 650 | singletonRow tc = [tc] 651 | 652 | getCellWidget :: TableWidget -> (Int, Int) -> TableCell 653 | getCellWidget tbw (row, col) = (tbw_rows tbw) !! row !! col 654 | 655 | setCellWidget :: TableWidget -> (Int, Int) -> TableCell -> TableWidget 656 | setCellWidget tbw (rowIndex, colIndex) w = 657 | let rows = tbw_rows tbw 658 | row = rows !! rowIndex 659 | newRow = listReplace row w colIndex 660 | newRows = listReplace rows newRow rowIndex 661 | in tbw {tbw_rows = newRows} 662 | 663 | data TableWidget = TableWidget 664 | { tbw_rows :: [Row] 665 | , tbw_colOffset :: Int 666 | , tbw_pos :: Maybe Pos 667 | , tbw_options :: TableWidgetOptions 668 | } 669 | 670 | data FillRow = First | Last | None deriving (Eq, Show) 671 | 672 | data TableWidgetOptions = TBWOptions 673 | { tbwopt_fillCol :: Maybe Int 674 | , tbwopt_fillRow :: FillRow 675 | , tbwopt_activeCols :: [Int] 676 | , tbwopt_minSize :: Size 677 | } 678 | deriving (Eq, Show) 679 | 680 | defaultTBWOptions :: TableWidgetOptions 681 | defaultTBWOptions = 682 | TBWOptions 683 | { tbwopt_fillCol = Nothing 684 | , tbwopt_fillRow = None 685 | , tbwopt_activeCols = [] 686 | , tbwopt_minSize = (4, 10) 687 | } 688 | 689 | instance Widget TableWidget where 690 | draw = drawTableWidget 691 | minSize = tbwopt_minSize . tbw_options 692 | 693 | newTableWidget :: TableWidgetOptions -> [Row] -> TableWidget 694 | newTableWidget opts rows = 695 | TableWidget 696 | { tbw_rows = rows 697 | , tbw_colOffset = 0 698 | , tbw_pos = findFirstActiveCell rows opts 699 | , tbw_options = opts 700 | } 701 | 702 | data TableWidgetDisplayInfo 703 | = TBWDisplayInfo 704 | { tbwdisp_height :: Int -- height of the display area 705 | , tbwdisp_width :: Int -- width of the display area 706 | , tbwdisp_firstVis :: Int -- index of the first row visible 707 | , tbwdisp_lastVis :: Int -- index of the last row visible 708 | , tbwdisp_rows :: [Row] -- the rows which are visible 709 | , tbwdisp_nrows :: Int -- the number of rows visible 710 | , tbwdisp_heights :: [Int] -- the heights of the visible rows 711 | , tbwdisp_widths :: [Int] -- the widths of the visible rows 712 | -- free space at the right side (xoffset, size) 713 | , tbwdisp_rightMargin :: Maybe (Int, Size) 714 | } 715 | 716 | tableWidgetDisplayInfo :: Size -> TableWidget -> TableWidgetDisplayInfo 717 | tableWidgetDisplayInfo (height, width) tbw = 718 | assert (isQuadratic (tbw_rows tbw)) $ 719 | let allRows = tbw_rows tbw 720 | ncols = length (allRows !! 0) 721 | colOffset = tbw_colOffset tbw 722 | allHeights = minSpaces getHeight allRows 723 | heights' = drop colOffset allHeights 724 | nrows = getNRows heights' 0 0 725 | rows = take nrows $ drop colOffset allRows 726 | (heights, heightDummy) = 727 | let hs = take nrows heights' 728 | s = sum hs 729 | d = height - s 730 | in case tbwopt_fillRow $ tbw_options tbw of 731 | First -> (applyToFirst (+ d) hs, 0) 732 | Last -> (applyToLast (+ d) hs, 0) 733 | None -> (hs, d) 734 | widths' = minSpaces getWidth (transpose $ tbw_rows tbw) 735 | (widths, rightMargin) = 736 | if sum widths' > width 737 | then 738 | error 739 | ( "table too wide: width=" 740 | ++ show (sum widths') 741 | ++ ", available width=" 742 | ++ show width 743 | ) 744 | else case tbwopt_fillCol $ tbw_options tbw of 745 | Just i 746 | | i >= 0 && i < ncols -> 747 | ( take i widths' 748 | ++ case drop i widths' of 749 | [] -> error "rest unexpectedly empty" 750 | (w : ws) -> (w + width - sum widths') : ws 751 | , Nothing 752 | ) 753 | _ -> 754 | let diff = width - sum widths' 755 | msz = (height, diff) 756 | m = 757 | if diff > 0 758 | then Just (sum widths', msz) 759 | else Nothing 760 | in (widths', m) 761 | dummyHeights = if heightDummy == 0 then [] else [heightDummy] 762 | dummyRows = 763 | if heightDummy == 0 764 | then [] 765 | else 766 | [ map 767 | (\w -> TableCell (OpaqueWidget (heightDummy, w))) 768 | widths 769 | ] 770 | in TBWDisplayInfo 771 | { tbwdisp_height = height 772 | , tbwdisp_width = width 773 | , tbwdisp_firstVis = colOffset 774 | , tbwdisp_lastVis = colOffset + nrows - 1 775 | , tbwdisp_rows = rows ++ dummyRows 776 | , tbwdisp_nrows = nrows + length dummyRows 777 | , tbwdisp_heights = heights ++ dummyHeights 778 | , tbwdisp_widths = widths 779 | , tbwdisp_rightMargin = rightMargin 780 | } 781 | where 782 | minSpaces f ls = 783 | snd $ 784 | mapAccumL 785 | ( \acc ws -> 786 | (acc, acc + maximum (map (f . minSize) ws)) 787 | ) 788 | 0 789 | ls 790 | getNRows (h : hs) n acc | h + n <= height = getNRows hs (h + n) (acc + 1) 791 | getNRows _ _ acc = acc 792 | isQuadratic [] = True 793 | isQuadratic (x : xs) = isQuadratic' xs (length x) 794 | isQuadratic' (x : xs) n = length x == n && isQuadratic' xs n 795 | isQuadratic' [] _ = True 796 | applyToFirst _ [] = [] 797 | applyToFirst f (x : xs) = f x : xs 798 | applyToLast _ [] = [] 799 | applyToLast f (x : xs) = 800 | let rev = NonEmpty.reverse $ x :| xs 801 | (h, t) = (NonEmpty.head rev, NonEmpty.tail rev) 802 | in reverse $ f h : t 803 | 804 | getCellInfo :: Pos -> Size -> TableWidget -> (Int, Int) -> (Pos, Size) 805 | getCellInfo (y, x) sz tbw (row, col) = 806 | let info = tableWidgetDisplayInfo sz tbw 807 | heights = tbwdisp_heights info 808 | widths = tbwdisp_widths info 809 | h = heights !! row 810 | w = widths !! col 811 | yoff = sum $ take row heights 812 | xoff = sum $ take col widths 813 | in ((y + yoff, x + xoff), (h, w)) 814 | 815 | drawTableWidget :: Pos -> Size -> DrawingHint -> TableWidget -> IO () 816 | drawTableWidget (y, x) sz hint tbw = 817 | let info = tableWidgetDisplayInfo sz tbw 818 | heights = tbwdisp_heights info 819 | widths = tbwdisp_widths info 820 | firstVis = tbwdisp_firstVis info 821 | rows = tbwdisp_rows info 822 | rightMargin = tbwdisp_rightMargin info 823 | in do 824 | drawRows rows heights widths 0 firstVis hint 825 | case rightMargin of 826 | Nothing -> return () 827 | Just (xoff, s) -> draw (y, x + xoff) s hint (OpaqueWidget s) 828 | Curses.refresh 829 | where 830 | drawRows :: 831 | [Row] -> 832 | [Int] -> 833 | [Int] -> 834 | Int -> 835 | Int -> 836 | DrawingHint -> 837 | IO () 838 | drawRows [] _ _ _ _ _ = return () 839 | drawRows (r : rs) (h : hs) widths yoffset rowIndex hint' = 840 | do 841 | drawCols r h widths yoffset 0 (rowIndex, 0) hint' 842 | drawRows rs hs widths (yoffset + h) (rowIndex + 1) hint' 843 | drawRows _ _ _ _ _ _ = return () 844 | drawCols :: 845 | Row -> 846 | Int -> 847 | [Int] -> 848 | Int -> 849 | Int -> 850 | (Int, Int) -> 851 | DrawingHint -> 852 | IO () 853 | drawCols [] _ _ _ _ _ _ = return () 854 | drawCols (c : cs) h (w : ws) yoffset xoffset (rowIndex, colIndex) hint' = 855 | let hint'' = case tbw_pos tbw of 856 | Just (z, a) 857 | | z == rowIndex && a == colIndex -> 858 | DHFocus 859 | _ -> hint' 860 | in do 861 | draw (y + yoffset, x + xoffset) (h, w) hint'' c 862 | drawCols 863 | cs 864 | h 865 | ws 866 | yoffset 867 | (xoffset + w) 868 | (rowIndex, colIndex + 1) 869 | hint' 870 | drawCols _ _ _ _ _ _ _ = return () 871 | 872 | tableWidgetScrollDown :: Size -> TableWidget -> TableWidget 873 | tableWidgetScrollDown (h, _) tbw = 874 | let dataLen = length $ tbw_rows tbw 875 | offset = tbw_colOffset tbw 876 | newOffset = scrollForward dataLen offset h 877 | newTbw = tbw {tbw_colOffset = newOffset} 878 | in case tbw_pos newTbw of 879 | Nothing -> newTbw 880 | Just (y, x) -> newTbw {tbw_pos = Just (max newOffset y, x)} 881 | 882 | tableWidgetScrollUp :: Size -> TableWidget -> TableWidget 883 | tableWidgetScrollUp sz@(h, _) tbw = 884 | let dataLen = length $ tbw_rows tbw 885 | offset = tbw_colOffset tbw 886 | newOffset = scrollBackward dataLen offset h 887 | newTbw = tbw {tbw_colOffset = newOffset} 888 | newLastVis = tbwdisp_lastVis (tableWidgetDisplayInfo sz newTbw) 889 | in case tbw_pos newTbw of 890 | Nothing -> newTbw 891 | Just (y, x) -> 892 | newTbw {tbw_pos = Just (min newLastVis y, x)} 893 | 894 | tableWidgetActivateCurrent :: 895 | (MonadIO m, MonadMask m) => 896 | m () -> 897 | Pos -> 898 | Size -> 899 | DrawingHint -> 900 | TableWidget -> 901 | m (TableWidget, Maybe String) 902 | tableWidgetActivateCurrent refresh (y, x) sz _ tbw = 903 | case tbw_pos tbw of 904 | Nothing -> do 905 | debug "tableWidgetActivateCurrent: pos=Nothing" 906 | return (tbw, Nothing) 907 | Just p -> 908 | let w = getCellWidget tbw p 909 | in if not $ isActive w 910 | then do 911 | debug "tableWidgetActivateCurrent: not active" 912 | return (tbw, Nothing) 913 | else activate' w p 914 | where 915 | activate' widget colyx@(coly, colx) = 916 | let info = tableWidgetDisplayInfo sz tbw 917 | vcol = colx 918 | vrow = coly - tbwdisp_firstVis info 919 | heights = tbwdisp_heights info 920 | widths = tbwdisp_widths info 921 | h = heights !! vrow 922 | w = widths !! vcol 923 | yoffset = sum (take vrow heights) 924 | xoffset = sum (take vcol widths) 925 | in do 926 | (new, res) <- 927 | _activateTableCell 928 | refresh 929 | (y + yoffset, x + xoffset) 930 | (h, w) 931 | widget 932 | return (setCellWidget tbw colyx new, Just res) 933 | 934 | tableWidgetGoLeft :: Size -> TableWidget -> TableWidget 935 | tableWidgetGoLeft = tableWidgetMove DirLeft 936 | 937 | tableWidgetGoRight :: Size -> TableWidget -> TableWidget 938 | tableWidgetGoRight = tableWidgetMove DirRight 939 | 940 | tableWidgetGoUp :: Size -> TableWidget -> TableWidget 941 | tableWidgetGoUp = tableWidgetMove DirUp 942 | 943 | tableWidgetGoDown :: Size -> TableWidget -> TableWidget 944 | tableWidgetGoDown = tableWidgetMove DirDown 945 | 946 | tableWidgetMove :: 947 | Direction -> 948 | (Int, Int) -> 949 | TableWidget -> 950 | TableWidget 951 | tableWidgetMove dir sz tbw = 952 | let pos = tbw_pos tbw 953 | opts = tbw_options tbw 954 | nrows = length (tbw_rows tbw) 955 | in case pos of 956 | Nothing -> tbw 957 | Just p -> case findNextActiveCell opts nrows p dir of 958 | Nothing -> tbw 959 | newP@(Just (y, _)) -> 960 | tableWidgetMakeVisible (tbw {tbw_pos = newP}) sz y 961 | 962 | tableWidgetMakeVisible :: 963 | TableWidget -> 964 | (Int, Int) -> 965 | Int -> 966 | TableWidget 967 | tableWidgetMakeVisible tbw sz@(_, _) y = 968 | let info = tableWidgetDisplayInfo sz tbw 969 | firstVis = tbwdisp_firstVis info 970 | lastVis = tbwdisp_lastVis info 971 | in if y < firstVis 972 | then tableWidgetMakeVisible (tableWidgetScrollUp sz tbw) sz y 973 | else 974 | if y > lastVis 975 | then 976 | tableWidgetMakeVisible 977 | (tableWidgetScrollDown sz tbw) 978 | sz 979 | y 980 | else tbw 981 | 982 | findFirstActiveCell :: [Row] -> TableWidgetOptions -> Maybe Pos 983 | findFirstActiveCell rows opts = 984 | let nrows = length rows 985 | firstActiveCells = 986 | map 987 | ( \y -> 988 | findNextActiveCell 989 | opts 990 | nrows 991 | (y, -1) 992 | DirRight 993 | ) 994 | [0 .. nrows - 1] 995 | in case catMaybes firstActiveCells of 996 | [] -> Nothing 997 | (x : _) -> Just x 998 | 999 | findNextActiveCell :: 1000 | TableWidgetOptions -> 1001 | Int -> 1002 | Pos -> 1003 | Direction -> 1004 | Maybe Pos 1005 | findNextActiveCell opts nrows (y, x) dir = 1006 | -- trace ("findNextActiveCell (opts=" ++ show opts ++ ", nrows=" ++ show nrows 1007 | -- ++ ", pos=" ++ show pos ++ ", dir=" ++ show dir) $ 1008 | let rows = [0 .. (nrows - 1)] 1009 | cols = sort (tbwopt_activeCols opts) 1010 | horiz f = case f cols x rows y of 1011 | Nothing -> Nothing 1012 | Just z -> Just (y, z) 1013 | vert f = case f rows y cols x of 1014 | Nothing -> Nothing 1015 | Just z -> Just (z, x) 1016 | res = case dir of 1017 | DirLeft -> horiz goLeft 1018 | DirRight -> horiz goRight 1019 | DirUp -> vert goLeft 1020 | DirDown -> vert goRight 1021 | in -- trace ("result of findNextActiveCell: " ++ show res) 1022 | res 1023 | where 1024 | goLeft _ _ rows a | not (a `elem` rows) = Nothing 1025 | goLeft cols b _ _ = 1026 | case reverse (takeWhile (< b) cols) of 1027 | [] -> Nothing 1028 | (c : _) -> Just c 1029 | goRight _ _ rows a | not (a `elem` rows) = Nothing 1030 | goRight cols a _ _ = 1031 | case dropWhile (a >=) cols of 1032 | [] -> Nothing 1033 | (b : _) -> Just b 1034 | 1035 | tableWidgetDeleteRow :: Int -> TableWidget -> TableWidget 1036 | tableWidgetDeleteRow n tbw = 1037 | let rows = tbw_rows tbw 1038 | rows' = deleteAt n rows 1039 | pos' = 1040 | case tbw_pos tbw of 1041 | Nothing -> Nothing 1042 | Just (row, col) -> 1043 | let row' = min row (length rows' - 1) 1044 | in if row' >= 0 1045 | then Just (row', col) 1046 | else Nothing 1047 | in tbw {tbw_rows = rows', tbw_pos = pos'} 1048 | 1049 | -- 1050 | -- BorderWidget 1051 | -- 1052 | 1053 | -- 1054 | -- Selection Widget 1055 | -- 1056 | 1057 | -- 1058 | -- Utility functions 1059 | -- 1060 | 1061 | -- | Join a list by some delimiter 1062 | joinLists :: [[a]] -> [a] -> [a] 1063 | joinLists l s = if (null l) then [] else foldr1 (\x -> \y -> x ++ s ++ y) l 1064 | 1065 | -- | Split a list by some delimiter 1066 | splitList :: (Eq a) => [a] -> [a] -> [[a]] 1067 | splitList d l = 1068 | unfoldr 1069 | ( \x -> 1070 | if (null x) 1071 | then Nothing 1072 | else Just $ nextToken d [] (snd $ splitAt (length d) x) 1073 | ) 1074 | (d ++ l) 1075 | where 1076 | nextToken _ r [] = (r, []) 1077 | nextToken e r m@(h : t) 1078 | | (e `isPrefixOf` m) = (r, m) 1079 | | otherwise = nextToken e (r ++ [h]) t 1080 | 1081 | listReplace :: [a] -> a -> Int -> [a] 1082 | listReplace l a i = 1083 | case splitAt i l of 1084 | (_, []) -> 1085 | error 1086 | ( "listReplace: index to large. index=" 1087 | ++ show i 1088 | ++ ", length=" 1089 | ++ show (length l) 1090 | ) 1091 | ([], _) 1092 | | i < 0 -> 1093 | error 1094 | ( "listReplace: negative index. index=" 1095 | ++ show i 1096 | ) 1097 | (xs, (_ : ys)) -> xs ++ (a : ys) 1098 | 1099 | -- alignRows :: [[String]] -> Char -> String -> [String] 1100 | alignRows :: [[[a]]] -> a -> [a] -> [[a]] 1101 | alignRows rows fill delim = 1102 | let widths = foldr maxWidths (repeat 0) rows 1103 | in map (alignRow widths) rows 1104 | where 1105 | maxWidths :: [[a]] -> [Int] -> [Int] 1106 | maxWidths row acc = map (uncurry max) (zip acc (map length row)) 1107 | alignRow widths row = concatMap (uncurry alignCell) (zip widths row) 1108 | alignCell width cell = 1109 | let diff = width - length cell 1110 | in cell ++ (take diff $ repeat fill) ++ delim 1111 | 1112 | align :: HAlignment -> Int -> a -> [a] -> [a] 1113 | align a w f l = 1114 | let space = w - length l 1115 | in case a of 1116 | AlignLeft -> l ++ (fill space) 1117 | AlignRight -> (fill space) ++ l 1118 | AlignCenter -> 1119 | let left = space `div` 2 1120 | right = left + (space `mod` 2) 1121 | in fill left ++ l ++ fill right 1122 | where 1123 | fill n = take n (repeat f) 1124 | 1125 | deleteAt :: Int -> [a] -> [a] 1126 | deleteAt n l = 1127 | if n >= 0 && n < length l 1128 | then 1129 | let (a, b) = splitAt n l 1130 | in case b of 1131 | [] -> error "deleteAt: impossible" 1132 | (_ : rest) -> a ++ rest 1133 | else error ("deleteAt: illegal index: " ++ show n) 1134 | -------------------------------------------------------------------------------- /boring: -------------------------------------------------------------------------------- 1 | # Boring file regexps: 2 | \.hi$ 3 | \.o$ 4 | \.o\.cmd$ 5 | \.ko$ 6 | \.ko\.cmd$ 7 | \.mod\.c$ 8 | (^|/)\.tmp_versions($|/) 9 | (^|/)CVS($|/) 10 | (^|/)RCS($|/) 11 | ~$ 12 | #(^|/)\.[^/] 13 | (^|/)_darcs($|/) 14 | \.bak$ 15 | \.BAK$ 16 | \.orig$ 17 | (^|/)vssver\.scc$ 18 | \.swp$ 19 | (^|/)MT($|/) 20 | (^|/)\{arch\}($|/) 21 | (^|/).arch-ids($|/) 22 | (^|/), 23 | \.class$ 24 | \.prof$ 25 | (^|/)\.DS_Store$ 26 | (^|/)BitKeeper($|/) 27 | (^|/)ChangeSet($|/) 28 | (^|/)\.svn($|/) 29 | \.py[co]$ 30 | \# 31 | \.cvsignore$ 32 | (^|/)Thumbs\.db$ 33 | 34 | ^AUTHORS$ 35 | ^HSCurses/CWString\.hs$ 36 | ^HSCurses/CWString_hsc\.c$ 37 | ^HSCurses/CWString_hsc\.h$ 38 | ^HSCurses/Curses\.hs$ 39 | ^HSCurses/Curses_hsc\.c$ 40 | ^HSCurses/Curses_hsc\.h$ 41 | ^HSCurses/IConv\.hs$ 42 | ^HSCurses/IConv_hsc\.c$ 43 | ^aclocal\.m4$ 44 | ^autom4te\.cache 45 | ^cbits/config\.h$ 46 | ^depend$ 47 | ^example/\.hscurses\.log$ 48 | ^example/cm$ 49 | ^hscurses\.conf$ 50 | ^hscurses\.conf\.m4$ 51 | ^hscurses\.conf\.m4\.in$ 52 | ^libhscurses\.a$ 53 | ^mk/config\.mk$ 54 | ^tests/widget-test/edit-test$ 55 | ^tests/widget-test/table-test$ 56 | ^tests/widget-test/text-test$ 57 | ^dist/ 58 | ^dist$ 59 | ^hscurses.buildinfo$ 60 | ^config.log$ 61 | ^config.status$ 62 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | package hscurses 4 | ghc-options: -Werror=incomplete-patterns 5 | -Werror=missing-fields 6 | -------------------------------------------------------------------------------- /cabal.project.ci: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | package hscurses 4 | ghc-options: -Werror 5 | -Werror=incomplete-patterns 6 | -Werror=missing-fields 7 | -------------------------------------------------------------------------------- /cbits/HSCurses.h: -------------------------------------------------------------------------------- 1 | #ifndef HSCURSES_H 2 | #define HSCURSES_H 3 | 4 | #ifndef GHC_CONFIG_INCLUDED 5 | #define GHC_CONFIG_INCLUDED 6 | #undef PACKAGE_NAME 7 | #undef PACKAGE_STRING 8 | #undef PACKAGE_TARNAME 9 | #undef PACKAGE_VERSION 10 | #include "ghcconfig.h" 11 | #endif 12 | 13 | #ifndef CONFIG_INCLUDED 14 | #define CONFIG_INCLUDED 15 | #include "config.h" 16 | #endif 17 | 18 | #if HAVE_NCURSESW_NCURSES_H 19 | #include 20 | #elif HAVE_NCURSES_H 21 | #include 22 | #else 23 | #include 24 | #endif 25 | 26 | #if defined(initscr) 27 | #undef initscr 28 | #endif 29 | 30 | #if defined(cbreak) 31 | #undef cbreak 32 | #endif 33 | 34 | #if defined(clrtoeol) 35 | #undef clrtoeol 36 | #endif 37 | 38 | #if defined(touchwin) 39 | #undef touchwin 40 | #endif 41 | 42 | #if defined(beep) 43 | #undef beep 44 | #endif 45 | 46 | #if defined(flash) 47 | #undef flash 48 | #endif 49 | 50 | #if defined(wattr_set) 51 | #undef wattr_set 52 | #endif 53 | 54 | #if defined(wattr_get) 55 | #undef wattr_get 56 | #endif 57 | 58 | // Accessing macros from Haskell is problematic, this is a wrapper: 59 | void getmaxyx_fun(WINDOW* win, int* y, int* x) { 60 | getmaxyx(win,(*y),(*x)); 61 | } 62 | 63 | #endif // HSCURSES_H 64 | -------------------------------------------------------------------------------- /cbits/HSCursesUtils.c: -------------------------------------------------------------------------------- 1 | 2 | #include "HSCursesUtils.h" 3 | 4 | /* 5 | * A non-macro version of getyx(3), to make writing a Haskell binding 6 | * easier. Called in UI/HSCurses/Curses.hsc 7 | */ 8 | void hscurses_nomacro_getyx(WINDOW *win, int *y, int *x) 9 | { 10 | getyx(win, *y, *x); 11 | } 12 | 13 | chtype hs_curses_color_pair(HsInt pair) 14 | { 15 | return COLOR_PAIR (pair); 16 | } 17 | 18 | HsInt hs_get_mb_cur_max() 19 | { 20 | return MB_CUR_MAX; 21 | } 22 | 23 | #if defined(HAVE_LIBPDCURSES) || defined (HAVE_LIBPDCURSESW) 24 | int hscurses_nomacro_getch(void) 25 | { 26 | return getch(); 27 | } 28 | #endif 29 | -------------------------------------------------------------------------------- /cbits/HSCursesUtils.h: -------------------------------------------------------------------------------- 1 | #ifndef HSCURSESUTILS_H 2 | #define HSCURSESUTILS_H 3 | 4 | #include "HSCurses.h" 5 | #include "HsFFI.h" 6 | #include 7 | 8 | extern void hscurses_nomacro_getyx(WINDOW *win, int *y, int *x ); 9 | 10 | extern chtype hs_curses_color_pair(HsInt pair ); 11 | 12 | extern HsInt hs_get_mb_cur_max(); 13 | 14 | #if defined(HAVE_LIBPDCURSES) || defined (HAVE_LIBPDCURSESW) 15 | extern int hscurses_nomacro_getch(void); 16 | #endif 17 | 18 | #endif // HSCURSESUTILS_H 19 | -------------------------------------------------------------------------------- /cbits/config.h.in: -------------------------------------------------------------------------------- 1 | /* cbits/config.h.in. Generated from configure.ac by autoheader. */ 2 | 3 | /* Define to 1 if you have the header file. */ 4 | #undef HAVE_CURSES_H 5 | 6 | /* Define to 1 if you have the header file. */ 7 | #undef HAVE_ICONV_H 8 | 9 | /* Define to 1 if you have the header file. */ 10 | #undef HAVE_INTTYPES_H 11 | 12 | /* Define to 1 if you have the header file. */ 13 | #undef HAVE_LANGINFO_H 14 | 15 | /* Define to 1 if you have the 'curses' library (-lcurses). */ 16 | #undef HAVE_LIBCURSES 17 | 18 | /* Define to 1 if you have the 'libiconv' function. */ 19 | #undef HAVE_LIBICONV 20 | 21 | /* Define to 1 if you have the 'ncurses' library (-lncurses). */ 22 | #undef HAVE_LIBNCURSES 23 | 24 | /* Define to 1 if you have the 'ncursesw' library (-lncursesw). */ 25 | #undef HAVE_LIBNCURSESW 26 | 27 | /* Define to 1 if you have the 'pdcurses' library (-lpdcurses). */ 28 | #undef HAVE_LIBPDCURSES 29 | 30 | /* Define to 1 if you have the 'pdcursesw' library (-lpdcursesw). */ 31 | #undef HAVE_LIBPDCURSESW 32 | 33 | /* Define to 1 if you have the header file. */ 34 | #undef HAVE_LIMITS_H 35 | 36 | /* Define to 1 if you have the header file. */ 37 | #undef HAVE_LOCALE_H 38 | 39 | /* Define to 1 if you have the header file. */ 40 | #undef HAVE_NCURSESW_NCURSES_H 41 | 42 | /* Define to 1 if you have the header file. */ 43 | #undef HAVE_NCURSES_H 44 | 45 | /* Define to 1 if you have the header file. */ 46 | #undef HAVE_SIGNAL_H 47 | 48 | /* Define to 1 if you have the header file. */ 49 | #undef HAVE_STDINT_H 50 | 51 | /* Define to 1 if you have the header file. */ 52 | #undef HAVE_STDIO_H 53 | 54 | /* Define to 1 if you have the header file. */ 55 | #undef HAVE_STDLIB_H 56 | 57 | /* Define to 1 if you have the header file. */ 58 | #undef HAVE_STRINGS_H 59 | 60 | /* Define to 1 if you have the header file. */ 61 | #undef HAVE_STRING_H 62 | 63 | /* Define to 1 if you have the header file. */ 64 | #undef HAVE_SYS_STAT_H 65 | 66 | /* Define to 1 if you have the header file. */ 67 | #undef HAVE_SYS_TYPES_H 68 | 69 | /* Define to 1 if you have the header file. */ 70 | #undef HAVE_UNISTD_H 71 | 72 | /* Define to 1 if you have the header file. */ 73 | #undef HAVE_WCHAR_H 74 | 75 | /* Define to 1 if you need a 'lib' prefix to iconv functions */ 76 | #undef ICONV_LIB_PREFIX 77 | 78 | /* Define to 1 if you need to call doupdate after endwin */ 79 | #undef NCURSES_UPDATE_AFTER_END 80 | 81 | /* Define to the address where bug reports for this package should be sent. */ 82 | #undef PACKAGE_BUGREPORT 83 | 84 | /* Define to the full name of this package. */ 85 | #undef PACKAGE_NAME 86 | 87 | /* Define to the full name and version of this package. */ 88 | #undef PACKAGE_STRING 89 | 90 | /* Define to the one symbol short name of this package. */ 91 | #undef PACKAGE_TARNAME 92 | 93 | /* Define to the home page for this package. */ 94 | #undef PACKAGE_URL 95 | 96 | /* Define to the version of this package. */ 97 | #undef PACKAGE_VERSION 98 | 99 | /* Define to 1 if all of the C89 standard headers exist (not just the ones 100 | required in a freestanding environment). This macro is provided for 101 | backward compatibility; new code need not use it. */ 102 | #undef STDC_HEADERS 103 | -------------------------------------------------------------------------------- /configure.ac: -------------------------------------------------------------------------------- 1 | # use autoreconf to generate configure script and cbits/config.h 2 | 3 | # sanity 4 | AC_INIT 5 | AC_CONFIG_SRCDIR([UI/HSCurses/Curses.hsc]) 6 | 7 | # Prepare to generate the config.h.in file 8 | AC_CONFIG_HEADERS([cbits/config.h]) 9 | 10 | # this is arbitrary 11 | AC_PREREQ([2.72]) 12 | 13 | AC_ARG_WITH(compiler, 14 | [AS_HELP_STRING([--with-hc=ARG],[ignored])], 15 | true, true) 16 | # 17 | # Curses. If you don't have wchar_t-aware ncurses (Debian package: 18 | # libncursesw5-dev), uncomment the first line and comment-out the 19 | # two later. 20 | # 21 | # The shell variables should be added to, e.g., $LIBS 22 | # 23 | AC_CHECK_LIB(curses, addnstr) 24 | AC_CHECK_LIB(ncurses, addnstr) 25 | AC_CHECK_LIB(ncursesw, waddnwstr) 26 | AC_CHECK_LIB(pdcurses, addnstr) 27 | AC_CHECK_LIB(pdcursesw, waddnwstr) 28 | 29 | AC_CHECK_LIB(iconv, iconv) 30 | AC_CHECK_LIB(iconv, libiconv) 31 | 32 | # Bit weird. On OpenBSD you need the 'lib' suffix to iconv functions, it seems 33 | AC_CHECK_FUNCS(libiconv, AC_DEFINE( [ICONV_LIB_PREFIX],[1], 34 | [Define to 1 if you need a 'lib' prefix to iconv functions])) 35 | 36 | # On linux we need to call doupdate() after endwin() to restore the term 37 | if uname -s | grep Linux > /dev/null 2>&1 ; then 38 | AC_DEFINE( [NCURSES_UPDATE_AFTER_END],[1], 39 | [Define to 1 if you need to call doupdate after endwin]) 40 | fi 41 | 42 | # some special libs need to be set for package.conf files 43 | if echo "$LIBS" | grep iconv > /dev/null 2>&1 ; then 44 | ICONV=iconv 45 | fi 46 | 47 | if (echo "$LIBS" | grep ncursesw) >/dev/null 2>&1 ; then 48 | CURSES=ncursesw 49 | elif (echo "$LIBS" | grep ncurses) >/dev/null 2>&1 ; then 50 | CURSES=ncurses 51 | elif (echo "$LIBS" | grep pdcursesw) >/dev/null 2>&1 ; then 52 | CURSES=pdcursesw 53 | elif (echo "$LIBS" | grep pdcurses) >/dev/null 2>&1 ; then 54 | CURSES=pdcurses 55 | else 56 | CURSES=curses 57 | fi 58 | AC_SUBST(ICONV) 59 | AC_SUBST(CURSES) 60 | 61 | # 62 | # Specific headers to check for 63 | # 64 | AC_CHECK_HEADERS([iconv.h curses.h ncurses.h ncursesw/ncurses.h locale.h langinfo.h wchar.h limits.h signal.h ]) 65 | 66 | AC_SUBST(SYMS) 67 | 68 | current_directory=`pwd` 69 | AC_SUBST(current_directory) 70 | 71 | AC_CONFIG_FILES([hscurses.buildinfo]) 72 | AC_OUTPUT 73 | -------------------------------------------------------------------------------- /example/ContactManager.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) 2005-2011 Stefan Wehr (http://www.stefanwehr.de) 2 | -- 3 | -- Permission is hereby granted, free of charge, to any person obtaining a 4 | -- copy of this software and associated documentation files (the 5 | -- "Software"), to deal in the Software without restriction, including 6 | -- without limitation the rights to use, copy, modify, merge, publish, 7 | -- distribute, sublicense, and/or sell copies of the Software, and to 8 | -- permit persons to whom the Software is furnished to do so, subject to 9 | -- the following conditions: 10 | -- 11 | -- The above copyright notice and this permission notice shall be included 12 | -- in all copies or substantial portions of the Software. 13 | -- 14 | -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 15 | -- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | -- IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | -- CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | -- TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | -- SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | 22 | -- Simple addressbook application to show the capabilities of the hscurses 23 | -- library, especially its widget set. 24 | 25 | module Main where 26 | 27 | {- 28 | TODO: 29 | 30 | \* save 31 | \* add 32 | -} 33 | 34 | import Prelude hiding ((<>)) 35 | 36 | import Control.Exception 37 | import Control.Monad.State 38 | import Data.List (sort) 39 | import System.Environment (getArgs, getProgName) 40 | import System.Exit (exitFailure) 41 | import Text.PrettyPrint.HughesPJ 42 | 43 | import qualified UI.HSCurses.Curses as Curses 44 | import qualified UI.HSCurses.CursesHelper as CursesH 45 | import UI.HSCurses.Logging 46 | import UI.HSCurses.Widgets 47 | 48 | type Name = String 49 | type Email = String 50 | type Address = String 51 | type ZIPCode = String 52 | type City = String 53 | type Province = String 54 | type Country = String 55 | type PhoneNumber = String 56 | 57 | data Contact = Contact 58 | { lastName :: Name 59 | , firstName :: Name 60 | , emailAddress :: Email 61 | , address :: Address 62 | , zipCode :: ZIPCode 63 | , city :: City 64 | , province :: Province 65 | , country :: Country 66 | , phoneNumber :: PhoneNumber 67 | } 68 | deriving (Show, Read, Eq, Ord) 69 | 70 | emptyContact = 71 | Contact 72 | { lastName = "" 73 | , firstName = "" 74 | , emailAddress = "" 75 | , address = "" 76 | , zipCode = "" 77 | , city = "" 78 | , province = "" 79 | , country = "" 80 | , phoneNumber = "" 81 | } 82 | 83 | pprContact c = 84 | pprLine (combine (lastName c) ", " (firstName c)) $ 85 | pprLine (address c) $ 86 | pprLine (combine (zipCode c) " " (city c)) $ 87 | pprLine (province c) $ 88 | pprLine (country c) $ 89 | pprLine (phoneNumber c) $ 90 | pprLine (emailAddress c) $ 91 | empty 92 | where 93 | pprLine :: String -> Doc -> Doc 94 | pprLine [] = (<>) empty 95 | pprLine s = ($$) (text s) 96 | combine [] _ s2 = s2 97 | combine s1 _ [] = s1 98 | combine s1 delim s2 = s1 ++ delim ++ s2 99 | 100 | contactToLabelValueList :: Contact -> [(String, String)] 101 | contactToLabelValueList c = 102 | [ ("Last Name", lastName c) 103 | , ("First Name", firstName c) 104 | , ("Email", emailAddress c) 105 | , ("Address", address c) 106 | , ("ZIP Code", zipCode c) 107 | , ("City", city c) 108 | , ("State/Province", province c) 109 | , ("Country", country c) 110 | , ("Phone", phoneNumber c) 111 | ] 112 | 113 | readContacts :: FilePath -> IO [Contact] 114 | readContacts f = 115 | do 116 | s <- readFile f 117 | case reads s of 118 | [(contacts, [])] -> return (sort contacts) 119 | _ -> error ("corrupt contact file: " ++ f) 120 | 121 | writeContacts :: FilePath -> [Contact] -> IO () 122 | writeContacts f contacts = 123 | writeFile f (show contacts) 124 | 125 | sampleContacts = 126 | [ emptyContact 127 | { lastName = "Wehr" 128 | , firstName = "Stefan" 129 | , emailAddress = "mail AT stefanwehr DOT de" 130 | , address = "28 Loch Maree St" 131 | , zipCode = "2032" 132 | , city = "Kingsford" 133 | , province = "NSW" 134 | , country = "Australia" 135 | } 136 | , emptyContact 137 | { lastName = "Thorpe" 138 | , firstName = "Ian" 139 | , emailAddress = "ian@aol7.com.au" 140 | , city = "Perth" 141 | , country = "Australia" 142 | } 143 | , emptyContact 144 | { lastName = "Gates" 145 | , firstName = "Bill" 146 | , emailAddress = "billy@microsoft.com" 147 | } 148 | , emptyContact 149 | { lastName = "Stewart" 150 | , firstName = "Don" 151 | , address = "CSE, UNSW, 501-16, k17 building" 152 | , city = "Sydney" 153 | , country = "Australia" 154 | } 155 | ] 156 | 157 | title = "contact-manager" 158 | 159 | help = "q:quit, d:delete, a:add" 160 | 161 | data CMState = CMState 162 | { cm_styles :: [CursesH.CursesStyle] 163 | , cm_contacts :: [Contact] 164 | } 165 | type CM = StateT CMState IO 166 | 167 | runCM :: [CursesH.CursesStyle] -> [Contact] -> CM a -> IO a 168 | runCM stys contacts cm = 169 | evalStateT 170 | cm 171 | ( CMState 172 | { cm_styles = stys 173 | , cm_contacts = contacts 174 | } 175 | ) 176 | 177 | nthStyle :: Int -> CM CursesH.CursesStyle 178 | nthStyle n = 179 | do 180 | cs <- gets cm_styles 181 | return $ cs !! n 182 | 183 | getSize = liftIO $ Curses.scrSize 184 | 185 | styles = 186 | [ CursesH.defaultStyle 187 | , CursesH.AttributeStyle [CursesH.Bold] CursesH.GreenF CursesH.DarkBlueB 188 | ] 189 | 190 | defStyle = nthStyle 0 191 | lineStyle = nthStyle 1 192 | 193 | lineDrawingStyle = 194 | do 195 | sty <- lineStyle 196 | return $ mkDrawingStyle sty 197 | 198 | lineOptions = 199 | do 200 | sz <- getSize 201 | ds <- lineDrawingStyle 202 | return $ 203 | TWOptions 204 | { twopt_size = TWSizeFixed (1, getWidth sz) 205 | , twopt_style = ds 206 | , twopt_halign = AlignLeft 207 | } 208 | 209 | type ToplineWidget = TextWidget 210 | type MidlineWidget = TextWidget 211 | type BotlineWidget = TextWidget 212 | type MsglineWidget = TableWidget 213 | type ContactListWidget = TableWidget 214 | type ContactDetailsWidget = TextWidget 215 | type ContactEditWidget = TableWidget 216 | 217 | mkToplineWidget = 218 | do 219 | opts <- lineOptions 220 | return $ 221 | newTextWidget 222 | (opts {twopt_halign = AlignCenter}) 223 | title 224 | 225 | mkMidlineWidget :: ContactListWidget -> CM MidlineWidget 226 | mkMidlineWidget listWidget = 227 | do 228 | opts <- lineOptions 229 | contacts <- gets cm_contacts 230 | let s = case tbw_pos listWidget of 231 | Nothing -> show (length contacts) 232 | Just (row, _) -> show (1 + row) ++ "/" ++ show (length contacts) 233 | return $ newTextWidget (opts {twopt_halign = AlignRight}) s 234 | 235 | mkBotlineWidget = 236 | do 237 | opts <- lineOptions 238 | return $ newTextWidget opts help 239 | 240 | -- We need to insert a dummy widget at the lower-right corner of the window, 241 | -- i.e. at the lower-right corner of the message line. Otherwise, an 242 | -- error occurs because drawing a character to this position moves the 243 | -- cursor to the next line, which doesn't exist. 244 | mkMsglineWidget = 245 | do 246 | sz <- getSize 247 | let width = getWidth sz 248 | opts = 249 | TWOptions 250 | { twopt_size = TWSizeFixed (1, width - 1) 251 | , twopt_style = defaultDrawingStyle 252 | , twopt_halign = AlignLeft 253 | } 254 | tw = newTextWidget opts "msgline" 255 | row = [TableCell tw, TableCell $ EmptyWidget (1, 1)] 256 | tabOpts = defaultTBWOptions {tbwopt_minSize = (1, width)} 257 | return $ newTableWidget tabOpts [row] 258 | 259 | nlines = 4 260 | 261 | contactListHeight (h, _) = (h - nlines) `div` 2 262 | 263 | contactDetailsHeight (h, _) = 264 | let n = h - nlines 265 | in n `div` 2 + (n `mod` 2) 266 | 267 | contactListOptions = 268 | do 269 | sz <- getSize 270 | return $ 271 | TBWOptions 272 | { tbwopt_fillCol = Nothing 273 | , tbwopt_fillRow = None 274 | , tbwopt_activeCols = [0] 275 | , tbwopt_minSize = (contactListHeight sz, getWidth sz) 276 | } 277 | 278 | contactDetailsOptions = 279 | do 280 | sz <- getSize 281 | return $ 282 | TWOptions 283 | { twopt_size = 284 | TWSizeFixed 285 | ( contactDetailsHeight sz 286 | , getWidth sz 287 | ) 288 | , twopt_style = defaultDrawingStyle 289 | , twopt_halign = AlignLeft 290 | } 291 | 292 | mkContactListWidget :: CM ContactListWidget 293 | mkContactListWidget = 294 | do 295 | contacts <- gets cm_contacts 296 | sz <- getSize 297 | let lines = alignRows (map contactLine contacts) ' ' " " 298 | rows = map (contactRow $ getWidth sz) lines 299 | opts <- contactListOptions 300 | return $ newTableWidget opts rows 301 | where 302 | contactLine c = [lastName c, firstName c, emailAddress c] 303 | contactRow w s = 304 | [ TableCell $ 305 | newTextWidget 306 | (defaultTWOptions {twopt_size = TWSizeFixed (1, w)}) 307 | s 308 | ] 309 | lastRow = [TableCell (EmptyWidget (0, 0))] 310 | 311 | mkContactDetailsWidget :: ContactListWidget -> CM ContactDetailsWidget 312 | mkContactDetailsWidget listWidget = 313 | do 314 | contacts <- gets cm_contacts 315 | let contact = case tbw_pos listWidget of 316 | Nothing -> "" 317 | Just (row, _) -> 318 | let c = contacts !! row 319 | in show $ pprContact c 320 | opts <- contactDetailsOptions 321 | return $ newTextWidget opts contact 322 | 323 | mkContactEditWidget :: Contact -> CM ContactEditWidget 324 | mkContactEditWidget contact = 325 | let l = contactToLabelValueList contact 326 | rows = map mkRow l 327 | in do 328 | sz <- getSize 329 | let opts = 330 | TBWOptions 331 | { tbwopt_fillCol = Just 1 332 | , tbwopt_fillRow = None 333 | , tbwopt_activeCols = [1] 334 | , tbwopt_minSize = (getHeight sz - 3, getWidth sz) 335 | } 336 | return $ newTableWidget opts rows 337 | where 338 | mkRow (label, value) = 339 | let labelW = newTextWidget defaultTWOptions label 340 | valueW = newEditWidget defaultEWOptions value 341 | in [TableCell labelW, ActiveTableCell valueW] 342 | 343 | mkMainEditWidget contact = 344 | do 345 | tlw <- mkToplineWidget 346 | blw <- mkBotlineWidget 347 | msglw <- mkMsglineWidget 348 | ew <- mkContactEditWidget contact 349 | return $ MainEditWidget tlw blw msglw ew 350 | 351 | data MainEditWidget = MainEditWidget 352 | { toplineEditWidget :: ToplineWidget 353 | , botlineEditWidget :: BotlineWidget 354 | , msglineEditWidget :: MsglineWidget 355 | , contactEditWidget :: ContactEditWidget 356 | } 357 | 358 | mkMainWidget = 359 | do 360 | tlw <- mkToplineWidget 361 | clw <- mkContactListWidget 362 | mlw <- mkMidlineWidget clw 363 | cdw <- mkContactDetailsWidget clw 364 | blw <- mkBotlineWidget 365 | msglw <- mkMsglineWidget 366 | return $ MainWidget tlw mlw blw msglw clw cdw 367 | 368 | instance Widget MainEditWidget where 369 | draw pos sz hint w = draw pos sz hint (mkRealMainEditWidget (Just sz) w) 370 | minSize w = minSize (mkRealMainEditWidget Nothing w) 371 | 372 | mkRealMainEditWidget :: (Maybe Size) -> MainEditWidget -> TableWidget 373 | mkRealMainEditWidget msz w = 374 | let cells = 375 | [ TableCell $ toplineEditWidget w 376 | , TableCell $ contactEditWidget w 377 | , TableCell $ botlineEditWidget w 378 | , TableCell $ msglineEditWidget w 379 | ] 380 | rows = map singletonRow cells 381 | opts = case msz of 382 | Nothing -> defaultTBWOptions 383 | Just sz -> defaultTBWOptions {tbwopt_minSize = sz} 384 | in newTableWidget opts rows 385 | 386 | data MainWidget = MainWidget 387 | { toplineWidget :: ToplineWidget 388 | , midlineWidget :: MidlineWidget 389 | , botlineWidget :: BotlineWidget 390 | , msglineWidget :: MsglineWidget 391 | , contactListWidget :: ContactListWidget 392 | , contactDetailsWidget :: ContactDetailsWidget 393 | } 394 | 395 | instance Widget MainWidget where 396 | draw pos sz hint w = draw pos sz hint (mkRealMainWidget (Just sz) w) 397 | minSize w = minSize (mkRealMainWidget Nothing w) 398 | 399 | mkRealMainWidget msz w = 400 | let cells = 401 | [ TableCell $ toplineWidget w 402 | , TableCell $ contactListWidget w 403 | , TableCell $ midlineWidget w 404 | , TableCell $ contactDetailsWidget w 405 | , TableCell $ botlineWidget w 406 | , TableCell $ msglineWidget w 407 | ] 408 | rows = map singletonRow cells 409 | opts = case msz of 410 | Nothing -> defaultTBWOptions 411 | Just sz -> defaultTBWOptions {tbwopt_minSize = sz} 412 | in newTableWidget opts rows 413 | 414 | updateStateDependentWidgets :: MainWidget -> ContactListWidget -> CM MainWidget 415 | updateStateDependentWidgets w listWidget = 416 | do 417 | detailsWidget <- mkContactDetailsWidget listWidget 418 | midlineWidget <- mkMidlineWidget listWidget 419 | return $ 420 | w 421 | { contactListWidget = listWidget 422 | , contactDetailsWidget = detailsWidget 423 | , midlineWidget = midlineWidget 424 | } 425 | 426 | move :: Direction -> MainWidget -> CM MainWidget 427 | move dir w = 428 | do 429 | sz <- getSize 430 | let listWidget = tableWidgetMove dir sz (contactListWidget w) 431 | updateStateDependentWidgets w listWidget 432 | 433 | delete w = 434 | let lw = contactListWidget w 435 | in case tbw_pos lw of 436 | Nothing -> return w 437 | Just (row, _) -> 438 | let lw' = tableWidgetDeleteRow row lw 439 | in do 440 | modify 441 | ( \s -> 442 | s 443 | { cm_contacts = 444 | deleteAt row (cm_contacts s) 445 | } 446 | ) 447 | updateStateDependentWidgets w lw' 448 | 449 | {- 450 | editEventloop w ewm = 451 | do k <- CursesH.getKey (resize mkMainEditWidget) 452 | case k of 453 | Curses.KeyChar 'q' -> return w 454 | Curses.KeyChar '\r' -> 455 | do debug "editing..." 456 | sz <- getSize 457 | let ewm' = mkRealMainEditWidget (Just sz) ewm 458 | (epos, esz) = getCellInfo (0,0) sz ewm' (1,0) 459 | ew = contactEditWidget ewm 460 | (ew', res) <- 461 | tableWidgetActivateCurrent (redraw ewm) epos esz DHFocus ew 462 | editEventloop w ewm 463 | _ -> editEventloop w ewm 464 | -} 465 | 466 | edit w = 467 | let lw = contactListWidget w 468 | in case tbw_pos lw of 469 | Nothing -> return w 470 | Just (row, _) -> 471 | do 472 | contacts <- gets cm_contacts 473 | let c = contacts !! row 474 | ew <- mkMainEditWidget c 475 | redraw ew 476 | return w 477 | 478 | -- editEventloop w ew 479 | 480 | resize :: (Widget w) => CM w -> CM () 481 | resize f = 482 | do 483 | liftIO $ do 484 | Curses.endWin 485 | Curses.resetParams 486 | Curses.cursSet Curses.CursorInvisible 487 | Curses.refresh 488 | w <- f 489 | redraw w 490 | 491 | redraw :: (Widget w) => w -> CM () 492 | redraw w = 493 | do 494 | sz <- getSize 495 | liftIO $ draw (0, 0) sz DHNormal w 496 | liftIO $ Curses.refresh 497 | 498 | eventloop w = 499 | do 500 | k <- CursesH.getKey (resize mkMainWidget) 501 | debug ("Got key " ++ show k) 502 | case k of 503 | Curses.KeyChar 'q' -> return () 504 | Curses.KeyChar 'd' -> process $ delete w 505 | Curses.KeyChar 'e' -> process $ edit w 506 | Curses.KeyUp -> process $ move DirUp w 507 | Curses.KeyDown -> process $ move DirDown w 508 | _ -> eventloop w 509 | where 510 | process f = 511 | do 512 | w' <- f 513 | redraw w' 514 | eventloop w' 515 | cmMain :: CM () 516 | cmMain = 517 | do 518 | w <- mkMainWidget 519 | redraw w 520 | eventloop w 521 | 522 | main :: IO () 523 | main = 524 | do 525 | args <- getArgs 526 | contacts <- 527 | if length args /= 1 528 | then do 529 | p <- getProgName 530 | putStrLn ("Usage: " ++ p ++ " contact-file") 531 | exitFailure 532 | else readContacts (args !! 0) 533 | runCurses contacts `finally` CursesH.end 534 | where 535 | runCurses contacts = 536 | do 537 | CursesH.start 538 | cstyles <- CursesH.convertStyles styles 539 | Curses.cursSet Curses.CursorInvisible 540 | runCM cstyles contacts cmMain 541 | -------------------------------------------------------------------------------- /example/README.md: -------------------------------------------------------------------------------- 1 | # A contact manager example application 2 | 3 | Run this example from the top-level of `hscurses` by doing: 4 | 5 | ```shell 6 | cabal run -f examples -- example/contacts 7 | ``` 8 | -------------------------------------------------------------------------------- /example/contacts: -------------------------------------------------------------------------------- 1 | [Contact {lastName = "Wehr", firstName = "Stefan", emailAddress = "mail AT stefanwehr DOT de", address = "28 Loch Maree St", zipCode = "2032", city = "Kingsford", province = "NSW", country = "Australia", phoneNumber = ""},Contact {lastName = "Thorpe", firstName = "Ian", emailAddress = "ian@aol7.com.au", address = "", zipCode = "", city = "Perth", province = "", country = "Australia", phoneNumber = ""},Contact {lastName = "Gates", firstName = "Bill", emailAddress = "billy@microsoft.com", address = "", zipCode = "", city = "", province = "", country = "", phoneNumber = ""},Contact {lastName = "Stewart", firstName = "Don", emailAddress = "", address = "CSE, UNSW, 501-16, k17 building", zipCode = "", city = "Sydney", province = "", country = "Australia", phoneNumber = ""}] -------------------------------------------------------------------------------- /example/contacts2: -------------------------------------------------------------------------------- 1 | [Contact {lastName = "Wehr", firstName = "Stefan", emailAddress = "mail AT stefanwehr DOT de", address = "28 Loch Maree St", zipCode = "2032", city = "Kingsford", province = "NSW", country = "Australia", phoneNumber = ""},Contact {lastName = "Thorpe", firstName = "Ian", emailAddress = "ian@aol7.com.au", address = "", zipCode = "", city = "Perth", province = "", country = "Australia", phoneNumber = ""},Contact {lastName = "Gates", firstName = "Bill", emailAddress = "billy@microsoft.com", address = "", zipCode = "", city = "", province = "", country = "", phoneNumber = ""},Contact {lastName = "Stewart", firstName = "Don", emailAddress = "", address = "CSE, UNSW, 501-16, k17 building", zipCode = "", city = "Sydney", province = "", country = "Australia", phoneNumber = ""}] -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | # Generated from web app, for more information, see: https://fourmolu.github.io/config/ 2 | indentation: 4 3 | column-limit: none 4 | function-arrows: trailing 5 | comma-style: leading 6 | import-export-style: diff-friendly 7 | import-grouping: legacy 8 | indent-wheres: false 9 | record-brace-space: true 10 | newlines-between-decls: 1 11 | haddock-style: single-line 12 | haddock-style-module: null 13 | let-style: auto 14 | in-style: right-align 15 | single-constraint-parens: always 16 | single-deriving-parens: always 17 | sort-constraints: true 18 | sort-derived-classes: true 19 | sort-deriving-clauses: true 20 | trailing-section-operators: true 21 | unicode: never 22 | respectful: true 23 | -------------------------------------------------------------------------------- /hscurses.buildinfo.in: -------------------------------------------------------------------------------- 1 | extra-libraries: @CURSES@ 2 | -------------------------------------------------------------------------------- /hscurses.cabal: -------------------------------------------------------------------------------- 1 | name: hscurses 2 | version: 1.5.0.0 3 | license: LGPL 4 | license-file: LICENSE 5 | author: 6 | John Meacham 7 | Tuomo Valkonen 8 | Don Stewart 9 | Stefan Wehr 10 | 11 | extra-source-files: ChangeLog 12 | copyright: 13 | Stefan Wehr 2004 - 2011 14 | Don Stewart 2004 15 | Tuomo Valkonen 2004 16 | John Meacham 2002-2004 17 | 18 | maintainer: Stefan Wehr 19 | stability: Stable 20 | category: User-interface 21 | synopsis: NCurses bindings for Haskell 22 | description: 23 | Binding to NCurses, a library of functions that manage an 24 | application's display on character-cell terminals. Additionally, 25 | it contains some basic widgets such as a text input widget and 26 | a table widget. 27 | 28 | homepage: https://github.com/skogsbaer/hscurses 29 | cabal-version: >=1.10 30 | build-type: Configure 31 | tested-with: 32 | GHC ==7.6.1 33 | || ==7.8 34 | || ==8.4.4 35 | || ==8.6.5 36 | || ==8.8.4 37 | || ==8.10.7 38 | || ==9.4.8 39 | || ==9.6.6 40 | || ==9.8.4 41 | || ==9.10.1 42 | || ==9.12.1 43 | 44 | data-files: 45 | cbits/config.h.in 46 | cbits/HSCurses.h 47 | cbits/HSCursesUtils.h 48 | configure 49 | configure.ac 50 | example/contacts 51 | example/contacts2 52 | hscurses.buildinfo.in 53 | README.md 54 | TODO 55 | 56 | source-repository head 57 | type: git 58 | location: https://github.com/skogsbaer/hscurses 59 | 60 | flag examples 61 | description: Build test and example binaries 62 | default: False 63 | manual: True 64 | 65 | flag debug 66 | description: Compile with logging/tracing functions 67 | default: False 68 | manual: True 69 | 70 | library 71 | build-depends: 72 | base >=4 && <5 73 | , exceptions <0.11 74 | , mtl <2.4 75 | , time <1.15 76 | 77 | extra-libraries: ncurses 78 | 79 | if !os(windows) 80 | build-depends: unix <2.9 81 | 82 | if flag(debug) 83 | cpp-options: -DDEBUG=1 84 | 85 | exposed-modules: 86 | UI.HSCurses.Curses 87 | UI.HSCurses.CursesHelper 88 | UI.HSCurses.Logging 89 | UI.HSCurses.Widgets 90 | 91 | other-modules: 92 | UI.HSCurses.CWString 93 | UI.HSCurses.IConv 94 | 95 | c-sources: cbits/HSCursesUtils.c 96 | includes: 97 | HSCurses.h 98 | HSCursesUtils.h 99 | 100 | default-extensions: 101 | CPP 102 | ExistentialQuantification 103 | ForeignFunctionInterface 104 | GeneralizedNewtypeDeriving 105 | ScopedTypeVariables 106 | 107 | include-dirs: cbits 108 | ghc-options: 109 | -funbox-strict-fields -Wall -fno-warn-unused-do-bind 110 | -fno-warn-name-shadowing 111 | 112 | default-language: Haskell2010 113 | 114 | executable contact-manager 115 | if flag(examples) 116 | build-depends: 117 | base >=4.0 && <5 118 | , hscurses 119 | , mtl >=2.0 && <2.4 120 | , pretty >=1.0 && <1.2 121 | 122 | else 123 | buildable: False 124 | 125 | hs-source-dirs: example 126 | default-language: Haskell2010 127 | main-is: ContactManager.hs 128 | 129 | executable key-test 130 | if flag(examples) 131 | build-depends: 132 | base >=4.0 && <5 133 | , hscurses 134 | 135 | else 136 | buildable: False 137 | 138 | hs-source-dirs: tests/key-test 139 | default-language: Haskell2010 140 | main-is: KeyTest.hs 141 | 142 | executable widget-test-text 143 | if flag(examples) 144 | build-depends: 145 | base >=4.0 && <5 146 | , hscurses 147 | 148 | else 149 | buildable: False 150 | 151 | hs-source-dirs: tests/widget-test 152 | default-language: Haskell2010 153 | main-is: TextTest.hs 154 | 155 | executable widget-test-table 156 | if flag(examples) 157 | build-depends: 158 | base >=4.0 && <5 159 | , hscurses 160 | 161 | else 162 | buildable: False 163 | 164 | hs-source-dirs: tests/widget-test 165 | default-language: Haskell2010 166 | main-is: TableTest.hs 167 | 168 | executable widget-test-edit 169 | if flag(examples) 170 | build-depends: 171 | base >=4.0 172 | , hscurses 173 | 174 | else 175 | buildable: False 176 | 177 | hs-source-dirs: tests/widget-test 178 | default-language: Haskell2010 179 | main-is: EditTest.hs 180 | -------------------------------------------------------------------------------- /tests/key-test/KeyTest.hs: -------------------------------------------------------------------------------- 1 | import UI.HSCurses.Curses 2 | import qualified UI.HSCurses.CursesHelper as CursesH 3 | 4 | import Control.Exception 5 | import Control.Monad (forever) 6 | import Data.Char 7 | import System.Exit 8 | 9 | draw s = do 10 | (h, w) <- scrSize 11 | CursesH.gotoTop 12 | CursesH.drawLine w s 13 | refresh 14 | 15 | done = return () 16 | 17 | main :: IO () 18 | main = 19 | finally 20 | ( do 21 | CursesH.start 22 | draw "Press any key, click the mouse, or use the mouse wheel" 23 | withAllMouseEvents $ do 24 | forever $ do 25 | c <- CursesH.getKey done 26 | case c of 27 | KeyChar 'q' -> exitWith ExitSuccess 28 | KeyMouse -> do 29 | draw "mouse\n" 30 | me <- getMouse 31 | draw (show me) 32 | x -> draw ("Last key: " ++ CursesH.displayKey x ++ " (" ++ show x ++ ")") 33 | ) 34 | CursesH.end 35 | -------------------------------------------------------------------------------- /tests/widget-test/EditTest.hs: -------------------------------------------------------------------------------- 1 | import qualified UI.HSCurses.Curses as Curses 2 | import qualified UI.HSCurses.CursesHelper as CursesH 3 | import UI.HSCurses.Widgets 4 | 5 | import Control.Exception 6 | import System.Exit 7 | 8 | draw s = do 9 | (h, w) <- Curses.scrSize 10 | CursesH.gotoTop 11 | CursesH.drawLine w s 12 | Curses.refresh 13 | 14 | done = return () 15 | 16 | forever :: (Monad m) => m t -> m t 17 | forever x = x >> forever x 18 | 19 | exit ew _ _ = return (Done ew) 20 | 21 | options stys = 22 | let dsty = (mkDrawingStyle (stys !! 1)) {dstyle_active = stys !! 1} 23 | in defaultEWOptions {ewopt_style = dsty} 24 | 25 | editWidget stys = newEditWidget (options stys) "" 26 | 27 | edit ew = do 28 | (ew', s) <- activateEditWidget done (1, 10) (1, 10) ew 29 | Curses.wMove Curses.stdScr 5 0 30 | CursesH.drawLine 60 ("saved: " ++ s) 31 | Curses.refresh 32 | return ew' 33 | 34 | loop ew = do 35 | c <- CursesH.getKey done 36 | ew' <- case c of 37 | Curses.KeyChar 'q' -> exitWith ExitSuccess 38 | Curses.KeyChar 'e' -> edit ew 39 | _ -> return ew 40 | loop ew' 41 | 42 | styles = 43 | [ CursesH.defaultStyle 44 | , CursesH.Style CursesH.CyanF CursesH.PurpleB 45 | ] 46 | 47 | main :: IO () 48 | main = 49 | do 50 | CursesH.start 51 | cstyles <- CursesH.convertStyles styles 52 | Curses.cursSet Curses.CursorInvisible 53 | CursesH.gotoTop 54 | CursesH.drawLine 20 "Hit 'e'!" 55 | Curses.wMove Curses.stdScr 1 0 56 | CursesH.drawLine 9 "Input: " 57 | Curses.refresh 58 | loop (editWidget cstyles) 59 | `finally` CursesH.end 60 | -------------------------------------------------------------------------------- /tests/widget-test/TableTest.hs: -------------------------------------------------------------------------------- 1 | import Control.Exception 2 | import System.Exit 3 | import qualified UI.HSCurses.Curses as Curses 4 | import qualified UI.HSCurses.CursesHelper as CursesH 5 | import UI.HSCurses.Widgets 6 | 7 | row1 sty = map (TableCell . newTextWidget defaultTWOptions) ["1", "eins", "one"] 8 | row2 sty = 9 | TableCell 10 | ( newTextWidget 11 | ( defaultTWOptions 12 | { twopt_size = 13 | TWSizeFixed (2, 10) 14 | , twopt_style = 15 | mkDrawingStyle (sty !! 2) 16 | } 17 | ) 18 | "2" 19 | ) 20 | : map (TableCell . newTextWidget defaultTWOptions) ["zwei", "two"] 21 | row3 sty = 22 | map (TableCell . newTextWidget defaultTWOptions) ["3", "drei"] 23 | ++ [ ActiveTableCell $ 24 | newEditWidget 25 | ( defaultEWOptions 26 | { ewopt_style = 27 | mkDrawingStyle (sty !! 1) 28 | } 29 | ) 30 | "" 31 | ] 32 | row4 sty = 33 | map 34 | (TableCell . newTextWidget defaultTWOptions) 35 | ["4", "vier", "four"] 36 | row5 sty = 37 | map (TableCell . newTextWidget defaultTWOptions) ["5", "fuenf"] 38 | ++ [ TableCell 39 | ( newTextWidget 40 | ( defaultTWOptions 41 | { twopt_size = 42 | TWSizeFixed (1, 6) 43 | , twopt_style = 44 | mkDrawingStyle (sty !! 3) 45 | } 46 | ) 47 | "five56XXXXX" 48 | ) 49 | ] 50 | 51 | rows sty = [row1 sty, row2 sty, row3 sty, row4 sty, row5 sty] 52 | 53 | tableWidget sty = newTableWidget (TBWOptions (Just 1) None [0, 2] (10, 10)) (rows sty) 54 | 55 | tableSize = (2, 50) 56 | tablePos = (1, 0) 57 | 58 | msgSize = (1, 40) 59 | msgPos = (10, 0) 60 | 61 | text = "0 1 2 3 4 5" 62 | 63 | done = return () 64 | 65 | loop tbw msg = do 66 | drawTableWidget tablePos tableSize DHNormal tbw 67 | drawTextWidget msgPos msgSize DHNormal msg 68 | c <- CursesH.getKey done 69 | case c of 70 | Curses.KeyChar 'q' -> exitWith ExitSuccess 71 | Curses.KeyChar ' ' -> loop (tableWidgetScrollDown tableSize tbw) msg 72 | Curses.KeyChar '-' -> loop (tableWidgetScrollUp tableSize tbw) msg 73 | Curses.KeyRight -> loop (tableWidgetGoRight tableSize tbw) msg 74 | Curses.KeyLeft -> loop (tableWidgetGoLeft tableSize tbw) msg 75 | Curses.KeyUp -> loop (tableWidgetGoUp tableSize tbw) msg 76 | Curses.KeyDown -> loop (tableWidgetGoDown tableSize tbw) msg 77 | Curses.KeyChar '\r' -> do 78 | (new, res) <- 79 | tableWidgetActivateCurrent 80 | done 81 | tablePos 82 | tableSize 83 | DHNormal 84 | tbw 85 | let msg' = case res of 86 | Nothing -> 87 | textWidgetSetText 88 | msg 89 | "could not activate current cell" 90 | Just s -> 91 | textWidgetSetText 92 | msg 93 | ("new content: <" ++ s ++ ">") 94 | loop new msg' 95 | _ -> loop tbw msg 96 | 97 | styles = 98 | [ CursesH.defaultStyle 99 | , CursesH.Style CursesH.WhiteF CursesH.PurpleB 100 | , CursesH.AttributeStyle [CursesH.Dim] CursesH.CyanF CursesH.WhiteB 101 | , CursesH.ColorlessStyle [CursesH.Bold] 102 | ] 103 | 104 | main :: IO () 105 | main = 106 | do 107 | CursesH.start 108 | cstyles <- CursesH.convertStyles styles 109 | Curses.cursSet Curses.CursorInvisible 110 | drawTextWidget 111 | (0, 0) 112 | (1, 60) 113 | DHFocus 114 | (newTextWidget defaultTWOptions text) 115 | loop (tableWidget cstyles) (newTextWidget defaultTWOptions "") 116 | `finally` CursesH.end 117 | -------------------------------------------------------------------------------- /tests/widget-test/TextTest.hs: -------------------------------------------------------------------------------- 1 | import Control.Exception 2 | import System.Exit 3 | import qualified UI.HSCurses.Curses as Curses 4 | import qualified UI.HSCurses.CursesHelper as CursesH 5 | import UI.HSCurses.Widgets 6 | 7 | twOptions sty = defaultTWOptions {twopt_style = mkDrawingStyle sty} 8 | 9 | text sty = newTextWidget (twOptions sty) (reverse "1\n12\n123\n1234\n12345\n123456\n1234567\n12345678\n123456789\n1234567890") 10 | 11 | textSize = (4, 4) 12 | 13 | loop tw = do 14 | drawTextWidget (0, 0) textSize DHNormal tw 15 | c <- CursesH.getKey done 16 | case c of 17 | Curses.KeyChar 'q' -> exitWith ExitSuccess 18 | Curses.KeyChar ' ' -> loop $ textWidgetScrollDown textSize tw 19 | Curses.KeyChar '-' -> loop $ textWidgetScrollUp textSize tw 20 | Curses.KeyChar ',' -> loop $ textWidgetScrollLeft textSize tw 21 | Curses.KeyChar '.' -> loop $ textWidgetScrollRight textSize tw 22 | _ -> loop tw 23 | 24 | done :: IO () 25 | done = return () 26 | 27 | styles = [CursesH.defaultStyle, CursesH.Style CursesH.WhiteF CursesH.PurpleB] 28 | 29 | main :: IO () 30 | main = 31 | do 32 | CursesH.start 33 | cstyles <- CursesH.convertStyles styles 34 | Curses.cursSet Curses.CursorInvisible 35 | CursesH.gotoTop 36 | loop (text (cstyles !! 1)) 37 | `finally` CursesH.end 38 | --------------------------------------------------------------------------------