diff --git a/dune b/dune index 38fbc85..2f86cfe 100644 --- a/dune +++ b/dune @@ -15,6 +15,7 @@ zed lambda-term irmin-unix + nottui-pretty ocaml-compiler-libs.common ocaml-compiler-libs.bytecomp ocaml-compiler-libs.toplevel)) @@ -34,6 +35,8 @@ irc-client-lwt irc-client-unix irc-client-tls + nottui-lwt + nottui-pretty )) (executable @@ -58,7 +61,10 @@ zed lambda-term irmin-unix - inuit + nottui + nottui-pretty + nottui-lwt + uuseg irc-client irc-client-lwt irc-client-unix diff --git a/fonts/LICENSE.txt b/fonts/LICENSE.txt new file mode 100644 index 0000000..75b5248 --- /dev/null +++ b/fonts/LICENSE.txt @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/fonts/OFL.txt b/fonts/OFL.txt new file mode 100644 index 0000000..8964508 --- /dev/null +++ b/fonts/OFL.txt @@ -0,0 +1,94 @@ +Copyright (c) 1994-2021, SIL International (http://www.sil.org/), +with Reserved Font Names "Scheherazade" and "SIL". + +This Font Software is licensed under the SIL Open Font License, Version 1.1. +This license is copied below, and is also available with a FAQ at: +http://scripts.sil.org/OFL + + +----------------------------------------------------------- +SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007 +----------------------------------------------------------- + +PREAMBLE +The goals of the Open Font License (OFL) are to stimulate worldwide +development of collaborative font projects, to support the font creation +efforts of academic and linguistic communities, and to provide a free and +open framework in which fonts may be shared and improved in partnership +with others. + +The OFL allows the licensed fonts to be used, studied, modified and +redistributed freely as long as they are not sold by themselves. The +fonts, including any derivative works, can be bundled, embedded, +redistributed and/or sold with any software provided that any reserved +names are not used by derivative works. The fonts and derivatives, +however, cannot be released under any other type of license. The +requirement for fonts to remain under this license does not apply +to any document created using the fonts or their derivatives. + +DEFINITIONS +"Font Software" refers to the set of files released by the Copyright +Holder(s) under this license and clearly marked as such. This may +include source files, build scripts and documentation. + +"Reserved Font Name" refers to any names specified as such after the +copyright statement(s). + +"Original Version" refers to the collection of Font Software components as +distributed by the Copyright Holder(s). + +"Modified Version" refers to any derivative made by adding to, deleting, +or substituting -- in part or in whole -- any of the components of the +Original Version, by changing formats or by porting the Font Software to a +new environment. + +"Author" refers to any designer, engineer, programmer, technical +writer or other person who contributed to the Font Software. + +PERMISSION & CONDITIONS +Permission is hereby granted, free of charge, to any person obtaining +a copy of the Font Software, to use, study, copy, merge, embed, modify, +redistribute, and sell modified and unmodified copies of the Font +Software, subject to the following conditions: + +1) Neither the Font Software nor any of its individual components, +in Original or Modified Versions, may be sold by itself. + +2) Original or Modified Versions of the Font Software may be bundled, +redistributed and/or sold with any software, provided that each copy +contains the above copyright notice and this license. These can be +included either as stand-alone text files, human-readable headers or +in the appropriate machine-readable metadata fields within text or +binary files as long as those fields can be easily viewed by the user. + +3) No Modified Version of the Font Software may use the Reserved Font +Name(s) unless explicit written permission is granted by the corresponding +Copyright Holder. This restriction only applies to the primary font name as +presented to the users. + +4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font +Software shall not be used to promote, endorse or advertise any +Modified Version, except to acknowledge the contribution(s) of the +Copyright Holder(s) and the Author(s) or with their explicit written +permission. + +5) The Font Software, modified or unmodified, in part or in whole, +must be distributed entirely under this license, and must not be +distributed under any other license. The requirement for fonts to +remain under this license does not apply to any document created +using the Font Software. + +TERMINATION +This license becomes null and void if any of the above conditions are +not met. + +DISCLAIMER +THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT +OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE +COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL +DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM +OTHER DEALINGS IN THE FONT SOFTWARE. diff --git a/fonts/README.txt b/fonts/README.txt new file mode 100644 index 0000000..1bc1b1c --- /dev/null +++ b/fonts/README.txt @@ -0,0 +1,77 @@ +Roboto Mono Variable Font +========================= + +This download contains Roboto Mono as both variable fonts and static fonts. + +Roboto Mono is a variable font with this axis: + wght + +This means all the styles are contained in these files: + RobotoMono-VariableFont_wght.ttf + RobotoMono-Italic-VariableFont_wght.ttf + +If your app fully supports variable fonts, you can now pick intermediate styles +that aren’t available as static fonts. Not all apps support variable fonts, and +in those cases you can use the static font files for Roboto Mono: + static/RobotoMono-Thin.ttf + static/RobotoMono-ExtraLight.ttf + static/RobotoMono-Light.ttf + static/RobotoMono-Regular.ttf + static/RobotoMono-Medium.ttf + static/RobotoMono-SemiBold.ttf + static/RobotoMono-Bold.ttf + static/RobotoMono-ThinItalic.ttf + static/RobotoMono-ExtraLightItalic.ttf + static/RobotoMono-LightItalic.ttf + static/RobotoMono-Italic.ttf + static/RobotoMono-MediumItalic.ttf + static/RobotoMono-SemiBoldItalic.ttf + static/RobotoMono-BoldItalic.ttf + +Get started +----------- + +1. Install the font files you want to use + +2. Use your app's font picker to view the font family and all the +available styles + +Learn more about variable fonts +------------------------------- + + https://developers.google.com/web/fundamentals/design-and-ux/typography/variable-fonts + https://variablefonts.typenetwork.com + https://medium.com/variable-fonts + +In desktop apps + + https://theblog.adobe.com/can-variable-fonts-illustrator-cc + https://helpx.adobe.com/nz/photoshop/using/fonts.html#variable_fonts + +Online + + https://developers.google.com/fonts/docs/getting_started + https://developer.mozilla.org/en-US/docs/Web/CSS/CSS_Fonts/Variable_Fonts_Guide + https://developer.microsoft.com/en-us/microsoft-edge/testdrive/demos/variable-fonts + +Installing fonts + + MacOS: https://support.apple.com/en-us/HT201749 + Linux: https://www.google.com/search?q=how+to+install+a+font+on+gnu%2Blinux + Windows: https://support.microsoft.com/en-us/help/314960/how-to-install-or-remove-a-font-in-windows + +Android Apps + + https://developers.google.com/fonts/docs/android + https://developer.android.com/guide/topics/ui/look-and-feel/downloadable-fonts + +License +------- +Please read the full license text (LICENSE.txt) to understand the permissions, +restrictions and requirements for usage, redistribution, and modification. + +You can use them freely in your products & projects - print or digital, +commercial or otherwise. + +This isn't legal advice, please consider consulting a lawyer and see the full +license for all details. diff --git a/fonts/Roboto-Black.ttf b/fonts/Roboto-Black.ttf new file mode 100644 index 0000000..43a00e0 Binary files /dev/null and b/fonts/Roboto-Black.ttf differ diff --git a/fonts/Roboto-BlackItalic.ttf b/fonts/Roboto-BlackItalic.ttf new file mode 100644 index 0000000..5082cdc Binary files /dev/null and b/fonts/Roboto-BlackItalic.ttf differ diff --git a/fonts/Roboto-Bold.ttf b/fonts/Roboto-Bold.ttf old mode 100755 new mode 100644 index aaf374d..3742457 Binary files a/fonts/Roboto-Bold.ttf and b/fonts/Roboto-Bold.ttf differ diff --git a/fonts/Roboto-BoldItalic.ttf b/fonts/Roboto-BoldItalic.ttf new file mode 100644 index 0000000..e85e7fb Binary files /dev/null and b/fonts/Roboto-BoldItalic.ttf differ diff --git a/fonts/Roboto-Italic.ttf b/fonts/Roboto-Italic.ttf new file mode 100644 index 0000000..c9df607 Binary files /dev/null and b/fonts/Roboto-Italic.ttf differ diff --git a/fonts/Roboto-Light.ttf b/fonts/Roboto-Light.ttf old mode 100755 new mode 100644 index 664e1b2..0e97751 Binary files a/fonts/Roboto-Light.ttf and b/fonts/Roboto-Light.ttf differ diff --git a/fonts/Roboto-LightItalic.ttf b/fonts/Roboto-LightItalic.ttf new file mode 100644 index 0000000..3ad14fa Binary files /dev/null and b/fonts/Roboto-LightItalic.ttf differ diff --git a/fonts/Roboto-Medium.ttf b/fonts/Roboto-Medium.ttf new file mode 100644 index 0000000..e89b0b7 Binary files /dev/null and b/fonts/Roboto-Medium.ttf differ diff --git a/fonts/Roboto-MediumItalic.ttf b/fonts/Roboto-MediumItalic.ttf new file mode 100644 index 0000000..a5a41d3 Binary files /dev/null and b/fonts/Roboto-MediumItalic.ttf differ diff --git a/fonts/Roboto-Regular.ttf b/fonts/Roboto-Regular.ttf index 3e6e2e7..3d6861b 100644 Binary files a/fonts/Roboto-Regular.ttf and b/fonts/Roboto-Regular.ttf differ diff --git a/fonts/Roboto-Thin.ttf b/fonts/Roboto-Thin.ttf new file mode 100644 index 0000000..7d084ae Binary files /dev/null and b/fonts/Roboto-Thin.ttf differ diff --git a/fonts/Roboto-ThinItalic.ttf b/fonts/Roboto-ThinItalic.ttf new file mode 100644 index 0000000..c173389 Binary files /dev/null and b/fonts/Roboto-ThinItalic.ttf differ diff --git a/fonts/Roboto.zip b/fonts/Roboto.zip new file mode 100644 index 0000000..2e1aab6 Binary files /dev/null and b/fonts/Roboto.zip differ diff --git a/fonts/RobotoMono-Italic-VariableFont_wght.ttf b/fonts/RobotoMono-Italic-VariableFont_wght.ttf new file mode 100644 index 0000000..d30055a Binary files /dev/null and b/fonts/RobotoMono-Italic-VariableFont_wght.ttf differ diff --git a/fonts/RobotoMono-VariableFont_wght.ttf b/fonts/RobotoMono-VariableFont_wght.ttf new file mode 100644 index 0000000..d2b4746 Binary files /dev/null and b/fonts/RobotoMono-VariableFont_wght.ttf differ diff --git a/fonts/Roboto_Mono.zip b/fonts/Roboto_Mono.zip new file mode 100644 index 0000000..3774262 Binary files /dev/null and b/fonts/Roboto_Mono.zip differ diff --git a/fonts/ScheherazadeNew-Bold.ttf b/fonts/ScheherazadeNew-Bold.ttf new file mode 100644 index 0000000..cd926c9 Binary files /dev/null and b/fonts/ScheherazadeNew-Bold.ttf differ diff --git a/fonts/ScheherazadeNew-Regular.ttf b/fonts/ScheherazadeNew-Regular.ttf new file mode 100644 index 0000000..316bb7c Binary files /dev/null and b/fonts/ScheherazadeNew-Regular.ttf differ diff --git a/fonts/Scheherazade_New.zip b/fonts/Scheherazade_New.zip new file mode 100644 index 0000000..ecba8f7 Binary files /dev/null and b/fonts/Scheherazade_New.zip differ diff --git a/fonts/static/RobotoMono-Bold.ttf b/fonts/static/RobotoMono-Bold.ttf new file mode 100644 index 0000000..900fce6 Binary files /dev/null and b/fonts/static/RobotoMono-Bold.ttf differ diff --git a/fonts/static/RobotoMono-BoldItalic.ttf b/fonts/static/RobotoMono-BoldItalic.ttf new file mode 100644 index 0000000..4bfe29a Binary files /dev/null and b/fonts/static/RobotoMono-BoldItalic.ttf differ diff --git a/fonts/static/RobotoMono-ExtraLight.ttf b/fonts/static/RobotoMono-ExtraLight.ttf new file mode 100644 index 0000000..d535884 Binary files /dev/null and b/fonts/static/RobotoMono-ExtraLight.ttf differ diff --git a/fonts/static/RobotoMono-ExtraLightItalic.ttf b/fonts/static/RobotoMono-ExtraLightItalic.ttf new file mode 100644 index 0000000..b28960a Binary files /dev/null and b/fonts/static/RobotoMono-ExtraLightItalic.ttf differ diff --git a/fonts/static/RobotoMono-Italic.ttf b/fonts/static/RobotoMono-Italic.ttf new file mode 100644 index 0000000..4ee4dc4 Binary files /dev/null and b/fonts/static/RobotoMono-Italic.ttf differ diff --git a/fonts/static/RobotoMono-Light.ttf b/fonts/static/RobotoMono-Light.ttf new file mode 100644 index 0000000..276af4c Binary files /dev/null and b/fonts/static/RobotoMono-Light.ttf differ diff --git a/fonts/static/RobotoMono-LightItalic.ttf b/fonts/static/RobotoMono-LightItalic.ttf new file mode 100644 index 0000000..a2801c2 Binary files /dev/null and b/fonts/static/RobotoMono-LightItalic.ttf differ diff --git a/fonts/static/RobotoMono-Medium.ttf b/fonts/static/RobotoMono-Medium.ttf new file mode 100644 index 0000000..8461be7 Binary files /dev/null and b/fonts/static/RobotoMono-Medium.ttf differ diff --git a/fonts/static/RobotoMono-MediumItalic.ttf b/fonts/static/RobotoMono-MediumItalic.ttf new file mode 100644 index 0000000..a3bfaa1 Binary files /dev/null and b/fonts/static/RobotoMono-MediumItalic.ttf differ diff --git a/fonts/static/RobotoMono-Regular.ttf b/fonts/static/RobotoMono-Regular.ttf new file mode 100644 index 0000000..7c4ce36 Binary files /dev/null and b/fonts/static/RobotoMono-Regular.ttf differ diff --git a/fonts/static/RobotoMono-SemiBold.ttf b/fonts/static/RobotoMono-SemiBold.ttf new file mode 100644 index 0000000..15ee6c6 Binary files /dev/null and b/fonts/static/RobotoMono-SemiBold.ttf differ diff --git a/fonts/static/RobotoMono-SemiBoldItalic.ttf b/fonts/static/RobotoMono-SemiBoldItalic.ttf new file mode 100644 index 0000000..8e21497 Binary files /dev/null and b/fonts/static/RobotoMono-SemiBoldItalic.ttf differ diff --git a/fonts/static/RobotoMono-Thin.ttf b/fonts/static/RobotoMono-Thin.ttf new file mode 100644 index 0000000..ee8a3fd Binary files /dev/null and b/fonts/static/RobotoMono-Thin.ttf differ diff --git a/fonts/static/RobotoMono-ThinItalic.ttf b/fonts/static/RobotoMono-ThinItalic.ttf new file mode 100644 index 0000000..40b01e4 Binary files /dev/null and b/fonts/static/RobotoMono-ThinItalic.ttf differ diff --git a/human.ml b/human.ml index ae0e667..f34b52e 100644 --- a/human.ml +++ b/human.ml @@ -380,10 +380,10 @@ module Event = struct | `Sys_wm_event -> `Unknown "`Sys_wm_event " | `Unknown e -> `Unknown (Format.sprintf "`Unknown %d " e) | `User_event -> `Unknown "`User_event " - | `Window_event -> `Unknown "`Window_event " | `Display_event -> `Unknown "`Display_event " - | `Sensor_update -> `Unknown "`Sensor_update " in - (*F.epr "event_of_sdlevent: %s@." (to_string r) ;*) + | `Sensor_update -> `Unknown "`Sensor_update " + | `Window_event -> `Unknown "`Window_event " in + (* F.epr "event_of_sdlevent: %s@." (to_string r) ;*) r let key_up : Sdl.keycode = 0x40000052 @@ -492,7 +492,6 @@ module Display = struct ; wall= frame.wall } in Sdl.gl_make_current frame.sdl_win frame.gl >>>= fun () -> - let width, height = Sdl.gl_get_drawable_size frame.sdl_win in Gl.viewport 0 0 width height ; Gl.clear_color 0.0 0.0 0.0 1.0 ; Gl.( @@ -566,6 +565,25 @@ module Display = struct let font_sans = lazy (load_font "fonts/Roboto-Regular.ttf") let font_sans_bold = lazy (load_font "fonts/Roboto-Bold.ttf") let font_sans_light = lazy (load_font "fonts/Roboto-Light.ttf") + let font_sans_italic = lazy (load_font "fonts/Roboto-Italic.ttf") + + let font_sans_bold_italic = + lazy (load_font "fonts/Roboto-BoldItalic.ttf") + + let font_serif = + lazy (load_font "fonts/ScheherazadeNew-Regular.ttf") + + let font_serif_bold = + lazy (load_font "fonts/ScheherazadeNew-Bold.ttf") + + let font_mono = lazy (load_font "fonts/static/RobotoMono-Regular") + + let font_mono_bold = + lazy (load_font "fonts/static/RobotoMono-Regular") + + let font_mono_light = + lazy (load_font "fonts/static/RobotoMono-Regular") + let font_emoji = lazy (load_font "fonts/NotoEmoji-Regular.ttf") let str_of_box b = @@ -1049,872 +1067,6 @@ module Panel = struct ; tag= "binding-state" } end - module InuitTextedit = struct - (* Most of this module stolen from https://github.com/let-def/inuit and heavily modified: - - Copyright (c) 2016 Frédéric Bour - - Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. - - THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - - open Format - - type 'a clickable = [> `Clickable | `Clicked] as 'a - type 'a editable = [> `Editable | `Prompt] as 'a - - module Patch = struct - type symbols = symbolic_output_item list - - type operation = - | Remove of int - | Insert of symbols - | Replace of int * symbols - | Propertize of int - - type 'flags t = - { offset: int (** Starting at [offset]'th unicode sequence *) - ; operation: operation - ; text_len: int - ; flags: 'flags list - (** A list of backend defined [flags]. *) } - - let make ~offset flags operation = - { flags - ; offset - ; operation - ; text_len= - ( match operation with - | Insert text | Replace (_, text) -> List.length text - | _ -> 0 ) } - - let with_flags flags t = - if t.flags == flags then t else {t with flags} - - let removed t = - match t.operation with - | Insert _ | Propertize _ -> 0 - | Remove n | Replace (n, _) -> n - - let inserted t = - match t.operation with - | Insert _ | Replace _ -> t.text_len - | Propertize _ | Remove _ -> 0 - - let inserted_text t = - match t.operation with - | Insert txt | Replace (_, txt) -> txt - | Propertize _ | Remove _ -> [] - end - - type 'flags patch = 'flags Patch.t - type side = [`Local | `Remote] - - let cons_some x xs = match x with None -> xs | Some x -> x :: xs - - module Socket = Inuit.Socket - - module Region = struct - type status = Ready | Locked - - type 'flags t = - { buffer: 'flags buffer - ; left: Trope.cursor - ; right: Trope.cursor - ; parent: 'flags t - ; observers: - ( side - -> 'flags patch - -> 'flags list * (unit -> unit) option ) - lazy_t - list - ; mutable closed: bool } - - and 'flags buffer = - { mutable trope: 'flags t Trope.t - ; mutable status: status - ; mutable socket: 'flags Patch.t Socket.controller } - - let unsafe_left_offset t = Trope.position t.buffer.trope t.left - - let unsafe_right_offset t = - Trope.position t.buffer.trope t.right - - let is_open t = - (not t.closed) - && ( Trope.member t.buffer.trope t.right - || - ( t.closed <- true ; - false ) ) - - let is_closed t = not (is_open t) - - let notify_observers buffer side region ~stop_at patch = - assert (buffer.status = Ready) ; - let rec aux patch acc = function - | [] -> acc - | fs when fs == stop_at -> acc - | (lazy f) :: fs -> - let flags, f' = f side patch in - let patch = Patch.with_flags flags patch in - let acc = cons_some f' acc in - aux patch acc fs in - buffer.status <- Locked ; - let fs = - try aux patch [] region.observers - with exn -> - buffer.status <- Ready ; - raise exn in - buffer.status <- Ready ; - fs - - let exec_observed fs = List.iter (fun f -> f ()) fs - - let check_local_change name buffer = - match buffer.status with - | Locked -> - invalid_arg - ( "Inuit_base.Region." ^ name - ^ ": attempt to change locked buffer (buffer under \ - observation)" ) - | Ready -> () - - let region_parent region = - let parent = region.parent in - if parent == region then None else Some parent - - let region_before trope cursor = - match Trope.find trope cursor with - | region when region.right == cursor -> Some region - | region -> region_parent region - | exception Not_found -> None - - let region_after trope cursor = - match Trope.find trope cursor with - | region when region.left == cursor -> Some region - | region -> region_parent region - | exception Not_found -> None - - let rec look_for_empty trope position cursor0 = - match Trope.seek_before trope cursor0 with - | Some (cursor, region) - when Trope.position trope cursor = position -> - if region.right == cursor0 then Some cursor - else look_for_empty trope position cursor - | _ -> None - - let insertion_cursor ~left_leaning trope position = - match Trope.find_before trope position with - | None -> (position, None) - | Some (cursor0, region) -> ( - match position - Trope.position trope cursor0 with - | n when n < 0 -> assert false - | 0 when left_leaning -> ( - match look_for_empty trope position cursor0 with - | Some cursor -> (0, Some cursor) - | None -> ( - if region.left == cursor0 then (0, Some cursor0) - else - match Trope.seek_before trope cursor0 with - | None -> (position, None) - | Some (cursor, _) -> - ( position - Trope.position trope cursor - , Some cursor ) ) ) - | n -> (n, Some cursor0) ) - - let replacement_bound trope position = - match Trope.find_after trope position with - | None -> None - | Some (cursor, _region) -> - Some (Trope.position trope cursor - position, cursor) - - let ancestor_region l r = - let rec aux l r = - let c = Trope.compare l.left r.left in - if c < 0 then - match region_parent r with - | None -> None - | Some r' -> aux l r' - else if c > 0 then - match region_parent l with - | None -> None - | Some l' -> aux l' r - else Some l in - aux l r - - let remote_replace b ({Patch.offset; _} as patch) old_len - new_len = - let trope = b.trope in - (* Find bounds *) - let left_offset, left_cursor = - insertion_cursor ~left_leaning:true trope offset in - let right_bound = replacement_bound trope (offset + old_len) in - (* Find affected regions and ancestor *) - let left_region = - match left_cursor with - | None -> None - | Some c -> region_after trope c in - let right_region = - match right_bound with - | None -> None - | Some (_, c) -> region_before trope c in - let ancestor = - match (left_region, right_region) with - | None, _ | _, None -> None - | Some l, Some r -> ancestor_region l r in - (* Notify observers *) - let left_o = - match left_region with - | None -> [] - | Some region -> - notify_observers b `Remote region ~stop_at:[] patch - and right_o = - match right_region with - | None -> [] - | Some right -> - let stop_at = - match ancestor with - | None -> [] - | Some region -> region.observers in - notify_observers b `Remote right ~stop_at patch in - (* Update trope *) - let trope = - let trope = - match (left_cursor, right_bound) with - | Some l, Some (_, r) -> Trope.remove_between trope l r - | Some l, None -> - Trope.remove_after trope l (left_offset + old_len) - | None, Some (right_offset, r) -> - Trope.remove_before trope r - (left_offset + old_len + right_offset) - | None, None -> - Trope.remove trope ~at:0 ~len:(left_offset + old_len) - in - (* Reinsert cursors *) - let check = - match ancestor with - | None -> fun _ -> true - | Some region -> ( != ) region in - let rec reinsert_from_left trope = function - | Some region when check region -> - reinsert_from_left - (Trope.put_left trope region.right region) - (region_parent region) - | _ -> trope in - let rec reinsert_from_right trope = function - | Some region when check region -> - reinsert_from_right - (Trope.put_left trope region.left region) - (region_parent region) - | _ -> trope in - let trope = reinsert_from_left trope left_region in - let trope = reinsert_from_right trope right_region in - (* Fix padding *) - let trope = - match right_bound with - | None -> trope - | Some (offset, r) -> Trope.insert_before trope r offset - in - let trope = - match left_cursor with - | None -> - Trope.insert trope ~at:0 ~len:(left_offset + new_len) - | Some c -> - Trope.insert_after trope c (left_offset + new_len) - in - trope in - b.trope <- trope ; - exec_observed right_o ; - exec_observed left_o - - let remote_propertize b ({Patch.offset; _} as patch) len = - let trope = b.trope in - (* Find bounds *) - let _left_offset, left_cursor = - insertion_cursor ~left_leaning:false trope offset in - let right_bound = replacement_bound trope (offset + len) in - (* Find affected regions and ancestor *) - let left_region = - match left_cursor with - | None -> None - | Some c -> region_after trope c in - let right_region = - match right_bound with - | None -> None - | Some (_, c) -> region_before trope c in - let ancestor = - match (left_region, right_region) with - | None, _ | _, None -> None - | Some l, Some r -> ancestor_region l r in - (* Notify observers *) - let left_o = - match left_region with - | None -> [] - | Some region -> - notify_observers b `Remote region ~stop_at:[] patch - and right_o = - match right_region with - | None -> [] - | Some right -> - let stop_at = - match ancestor with - | None -> [] - | Some region -> region.observers in - notify_observers b `Remote right ~stop_at patch in - exec_observed right_o ; exec_observed left_o - - let remote_insert b ({Patch.offset; _} as patch) new_len = - let trope = b.trope in - let left_offset, left_cursor = - insertion_cursor ~left_leaning:true trope offset in - let left_region = - match left_cursor with - | None -> None - | Some cursor -> region_after trope cursor in - let trope = - match left_cursor with - | None -> Trope.insert trope ~at:left_offset ~len:new_len - | Some cursor -> Trope.insert_after trope cursor new_len - in - let observed = - match left_region with - | None -> [] - | Some region -> - notify_observers b `Remote region ~stop_at:[] patch - in - b.trope <- trope ; - exec_observed observed - - let remote_change b patch = - match b.status with - | Locked -> - invalid_arg - "Inuit_base.Region.remote_change: attempt to change \ - locked buffer (buffer under observation)" - | Ready -> ( - let {Patch.operation; offset= _; text_len; flags= _} = - patch in - match operation with - | Patch.Remove n | Patch.Replace (n, _) -> - remote_replace b patch n text_len - | Patch.Insert _ -> remote_insert b patch text_len - | Patch.Propertize n -> remote_propertize b patch n ) - - let append t flags text = - if is_open t then ( - let buffer = t.buffer in - check_local_change "append" buffer ; - let trope = buffer.trope in - let offset = Trope.position trope t.right in - let patch = Patch.make ~offset flags (Patch.Insert text) in - let observed = - notify_observers buffer `Local t ~stop_at:[] patch in - buffer.trope <- - Trope.insert_before trope t.right patch.Patch.text_len ; - Socket.send buffer.socket patch ; - exec_observed observed ) - - let generic_clear f t = - if is_open t then ( - let buffer = t.buffer in - check_local_change "clear" buffer ; - let trope = buffer.trope in - let offset = Trope.position trope t.left in - let length = Trope.position trope t.right - offset in - F.epr " generic_clear: t.right=%d t.left=%d@." - (Trope.position trope t.left) - (Trope.position trope t.right) ; - let patch = Patch.make ~offset [] (Patch.Remove length) in - let observed = - notify_observers buffer `Local t ~stop_at:[] patch in - buffer.trope <- f t buffer.trope ; - Socket.send buffer.socket patch ; - exec_observed observed ) - - let clear t = - generic_clear - (fun t trope -> Trope.remove_between trope t.left t.right) - t - - let kill t = - generic_clear - (fun t trope -> - let trope = Trope.remove_between trope t.left t.right in - let trope = Trope.rem_cursor trope t.left in - let trope = Trope.rem_cursor trope t.right in - trope ) - t - - let propertize flags t = - if is_open t then ( - let buffer = t.buffer in - let trope = buffer.trope in - let offset = Trope.position trope t.left in - let length = Trope.position trope t.right - offset in - let patch = - Patch.make ~offset flags (Patch.Propertize length) in - let observed = - notify_observers buffer `Local t ~stop_at:[] patch in - Socket.send buffer.socket patch ; - exec_observed observed ) - - let sub ?(at = `Right) ?observer parent = - if is_open parent then ( - let left = - match at with - | `Before -> Trope.cursor_before parent.left - | `Left -> Trope.cursor_after parent.left - | `Right -> Trope.cursor_before parent.right - | `After -> Trope.cursor_after parent.right in - let right = Trope.cursor_after left in - let parent = - match at with - | `Before | `After -> parent.parent - | `Left | `Right -> parent in - let buffer = parent.buffer in - let t' = - match observer with - | None -> - { left - ; right - ; parent - ; buffer - ; closed= false - ; observers= parent.observers } - | Some observer -> - let rec t' = - { left - ; right - ; parent - ; buffer - ; closed= false - ; observers= lazy (observer t') :: parent.observers - } in - t' in - let trope = buffer.trope in - let trope = - match at with - | `Right | `Before -> Trope.put_right trope left t' - | `Left | `After -> Trope.put_left trope left t' in - buffer.trope <- Trope.put_left trope right t' ; - (match t'.observers with [] -> () | (lazy _x) :: _ -> ()) ; - t' ) - else parent - - let make () = - let socket = Socket.make ~receive:ignore in - let trope = Trope.create () in - let left = Trope.cursor_at_origin trope in - let right = Trope.cursor_after left in - let rec t' = - { left - ; right - ; buffer= {trope; status= Ready; socket} - ; closed= false - ; parent= t' - ; observers= [] } in - let buffer = t'.buffer in - buffer.trope <- - Trope.put_left (Trope.put_left trope left t') right t' ; - Socket.set_receive socket (remote_change buffer) ; - Socket.set_on_closed socket (fun () -> - buffer.trope <- Trope.clear buffer.trope ) ; - (t', Socket.endpoint socket) - - type 'flags observer = - 'flags t - -> side - -> 'flags patch - -> 'flags list * (unit -> unit) option - end - - module Inuit_region = Region - - module Cursor = struct - type 'flags cursor = - { region: 'flags Inuit_region.t - ; flags: 'flags list - ; indent: int } - - type 'flags clickable = [> `Clickable | `Clicked] as 'flags - - let indent_text col text = - if col <= 0 then text - else - List.flatten - (List.map - (function - | Format.Output_newline as r -> - [r; Format.Output_indent col] - | x -> [x] ) - text ) - - let text t ?(flags = t.flags) text = - Inuit_region.append t.region flags (indent_text t.indent text) - - let clear t = Inuit_region.clear t.region - let kill t = Inuit_region.kill t.region - let sub t = {t with region= Inuit_region.sub t.region} - - let observe {region; flags; indent} f = - let observer region = - let t' = {region; flags; indent} in - fun side patch -> f t' side patch in - {region= Inuit_region.sub ~observer region; flags; indent} - - let is_closed t = Inuit_region.is_closed t.region - let mem_flag flag cursor = List.mem flag cursor.flags - - let add_flag flag cursor = - if mem_flag flag cursor then cursor - else {cursor with flags= flag :: cursor.flags} - - let rem_flag flag cursor = - if mem_flag flag cursor then - {cursor with flags= List.filter (( <> ) flag) cursor.flags} - else cursor - - let get_flags t = t.flags - let with_flags flags t = {t with flags} - let region t = t.region - - let clickable t f = - let t = add_flag `Clickable t in - observe t (fun t' _side patch -> - let {Patch.flags; offset; _} = patch in - if - Inuit_region.unsafe_right_offset t'.region > offset - && List.mem `Clicked flags - then - ( List.filter (( <> ) `Clicked) flags - , Some (fun () -> f t') ) - else (flags, None) ) - - let printf t ?flags fmt = - let sob = Format.make_symbolic_output_buffer () in - let pp = Format.formatter_of_symbolic_output_buffer sob in - Format.fprintf pp fmt ; - Format.pp_print_flush pp () ; - List.iter - (function - | Output_string s -> F.epr "printf: %s @." s | _ -> () ) - (Format.get_symbolic_output_buffer sob) ; - text t ?flags (Format.flush_symbolic_output_buffer sob) - - let link t ?flags fmt f = - let sob = Format.make_symbolic_output_buffer () in - let pp = Format.formatter_of_symbolic_output_buffer sob in - Format.fprintf pp fmt ; - Format.pp_print_flush pp () ; - text (clickable t f) ?flags - (Format.flush_symbolic_output_buffer sob) - - let cursor_of_region ?(flags = []) ?(indent = 0) region = - {region; flags; indent} - - let make () = - let region, pipe = Inuit_region.make () in - (cursor_of_region region, pipe) - - let get_indent t = t.indent - let with_indent t indent = {t with indent} - - let shift_indent t indent = - {t with indent= max 0 (t.indent + indent)} - end - - let rec list_split i ?(left = []) = function - | [] -> (left, []) - | x :: xs -> - if i <= 0 then (left, x :: xs) - else list_split (i - 1) ~left:(left @ [x]) xs - - module Edit = struct - open Cursor - - type 'flags t = - { mutable cursor: 'flags cursor - ; mutable state: Format.symbolic_output_buffer } - - let make ?(state = []) ?on_change cursor = - let t = - {cursor; state= Format.make_symbolic_output_buffer ()} in - let on_change = - match on_change with - | None -> None - | Some f -> Some (fun _ -> f t) in - printf (add_flag `Prompt cursor) "# " ; - t.cursor <- - observe cursor (fun cursor' side p -> - let s = Format.flush_symbolic_output_buffer t.state in - let offset = - p.Patch.offset - - Inuit_region.unsafe_left_offset (region cursor') - in - let sl, sr = list_split offset s in - List.iter - (Format.add_symbolic_output_item t.state) - (sl @ Patch.inserted_text p @ sr) ; - let callback = - if side = `Remote then on_change else None in - (p.Patch.flags, callback) ) ; - text t.cursor state ; - t - - let change t ~state = clear t.cursor ; text t.cursor state - let state t = t.state - end - - module Nav = struct - open Cursor - - type 'flags t = - { mutable prev: 'flags page list - ; mutable page: 'flags page - ; mutable next: 'flags page list - ; frame: 'flags frame option } - - and 'flags page = Patch.symbols * ('flags frame -> unit) - - and 'flags frame = - {title: 'flags cursor; body: 'flags cursor; nav: 'flags t} - - let make title body = - let page = (title, body) in - {prev= []; page; next= []; frame= None} - - let update_frame t = - match t.frame with - | None -> () - | Some ({title; body; nav= _} as frame) -> - clear title ; - text title (fst t.page) ; - F.epr "Nav.update_frame clear body@." ; - clear body ; - (snd t.page) frame - - let goto t title body = - t.page <- (title, body) ; - t.next <- [] ; - update_frame t - - let push t title body = - t.prev <- t.page :: t.prev ; - goto t title body - - let next t = - match t.next with - | [] -> () - | page :: pages -> - t.prev <- t.page :: t.prev ; - t.page <- page ; - t.next <- pages ; - update_frame t - - let prev t = - match t.prev with - | [] -> () - | page :: pages -> - t.next <- t.page :: t.next ; - t.page <- page ; - t.prev <- pages ; - update_frame t - - let render_header t cursor = - (*⏪*) - (*↻*) - (*⏩*) - link cursor "[<<]" (fun _ -> prev t) ; - text cursor [Output_string " "] ; - link cursor "[reload]" (fun _ -> update_frame t) ; - text cursor [Output_string " "] ; - link cursor "[>>]" (fun _ -> next t) - - let render t cursor = - let open Cursor in - if not (is_closed cursor) then ( - let header = sub cursor in - printf cursor " " ; - let title = sub cursor in - printf cursor "\n\n" ; - let body = sub cursor in - let rec nav = {t with frame= Some frame} - and frame = {title; body; nav} in - render_header nav header ; - update_frame nav ) - end - - type flag = - [ `Clickable - | `Clicked - | `Editable - | `Prompt - | `Focus - | `Custom of string ] - - type t = - { mutable edit: flag Cursor.cursor - ; mutable sock: flag Patch.t Socket.t - ; mutable buf: Format.symbolic_output_item list - ; mutable view: flag Nav.t - ; mutable bind: Input.Bind.state } - - let clear t = Cursor.clear t.edit - let insert t = Cursor.text t.edit - let contents t : Format.symbolic_output_item list = t.buf - - let pr_sob s = - let sob = make_symbolic_output_buffer () in - let pp = formatter_of_symbolic_output_buffer sob in - F.pf pp s ; - flush_symbolic_output_buffer sob - - let bindings _t = - let open Input.Bind in - add [([], Code Left)] [Zed Prev_char] - @@ add [([], Code Right)] [Zed Next_char] - @@ add [([], Code Up)] [Zed Prev_line] - @@ add [([], Code Down)] [Zed Next_line] - @@ add [([], Code Home)] [Zed Goto_bol] - @@ add [([], Code End)] [Zed Goto_eol] - @@ add [([], Code Insert)] [Zed Switch_erase_mode] - @@ add [([], Code Delete)] [Zed Delete_next_char] - @@ add [([], Code Enter)] [Zed Newline] - @@ add [([Ctrl], Char ' ')] [Zed Set_mark] - @@ add [([Ctrl], Char 'a')] [Zed Goto_bol] - @@ add [([Ctrl], Char 'e')] [Zed Goto_eol] - @@ add [([Ctrl], Char 'd')] [Zed Delete_next_char] - @@ add [([Ctrl], Char 'h')] [Zed Delete_prev_char] - @@ add [([Ctrl], Char 'k')] [Zed Kill_next_line] - @@ add [([Ctrl], Char 'u')] [Zed Kill_prev_line] - @@ add [([Ctrl], Char 'n')] [Zed Next_line] - @@ add [([Ctrl], Char 'p')] [Zed Prev_line] - @@ add [([Ctrl], Char 'w')] [Zed Kill] - @@ add [([Ctrl], Char 'y')] [Zed Yank] - @@ add [([], Code Backspace)] [Zed Delete_prev_char] - @@ add [([Meta], Char 'w')] [Zed Copy] - @@ add [([Meta], Char 'c')] [Zed Capitalize_word] - @@ add [([Meta], Char 'l')] [Zed Lowercase_word] - @@ add [([Meta], Char 'u')] [Zed Uppercase_word] - @@ add [([Meta], Char 'b')] [Zed Prev_word] - @@ add [([Meta], Char 'f')] [Zed Next_word] - @@ add [([Meta], Code Right)] [Zed Next_word] - @@ add [([Meta], Code Left)] [Zed Prev_word] - @@ add [([Ctrl], Code Right)] [Zed Next_word] - @@ add [([Ctrl], Code Left)] [Zed Prev_word] - @@ add [([Meta], Code Backspace)] [Zed Kill_prev_word] - @@ add [([Meta], Code Delete)] [Zed Kill_prev_word] - @@ add [([Ctrl], Code Delete)] [Zed Kill_next_word] - @@ add [([Meta], Char 'd')] [Zed Kill_next_word] - @@ add [([Ctrl], Char '/')] [Zed Undo] - @@ add [([Ctrl], Char 'x'); ([], Char 'u')] [Zed Undo] - @@ add [([Ctrl], Char 'v')] [Custom (fun () -> ())] - @@ add [([Meta], Char 'v')] [Custom (fun () -> ())] - @@ empty - - let make ?(bindings = bindings) ?on_change main = - let open Cursor in - let edit, sock = Cursor.make () in - let t = - { edit - ; sock - ; buf= [] - ; view= - ( F.epr "Nav.make@." ; - Nav.make (pr_sob "MR. DERPSALOT") - @@ fun {Nav.title= _; body; nav} -> - let open Cursor in - printf body "Je mens.@.@." ; - link body "- C'est vrai." (fun _ -> - Nav.push nav (pr_sob "C'est vrai !") - @@ fun {Nav.body; _} -> printf body "C'est faux." ) ; - printf body "@." ; - link body "- C'est faux." (fun _ -> - Nav.push nav (pr_sob "C'est faux !") - @@ fun {Nav.body; _} -> printf body "C'est vrai." ) ; - printf body "@." ; - printf body main ; - F.epr "Nav.make callback@." ) - ; bind= Input.Bind.init Input.Bind.empty } in - let sock' = - Socket.make (*~receive:ignore*) - ~receive: - Patch.( - fun p -> - F.epr "Patch.t {offset=%d, operation=" p.offset ; - match p.operation with - | Insert s -> - F.epr "Insert (sob len %d) \"" (List.length s) ; - format_symbolic_output_items F.stderr s ; - F.epr "\"@." - | Replace (i, s) -> - F.epr "Replace %d \"" i ; - format_symbolic_output_items F.stderr s ; - F.epr "\"@." - | Remove i -> F.epr "Remove %d@." i - | Propertize i -> - F.epr "Propertize %d@." i ; - F.epr ", text_len=%d}@." p.text_len) in - Socket.connect ~a:t.sock ~b:(Socket.endpoint sock') ; - printf (add_flag `Prompt edit) "# " ; - Cursor.printf edit main ; - t.edit <- - observe edit (fun cursor' side p -> - let offset = - p.Patch.offset - - Inuit_region.unsafe_left_offset (region cursor') in - F.epr - "observe edit: (length t.buf)=%d; offset=(p.offset=%d \ - - unsafe_left_offset=%d)=%d @." - (List.length t.buf) p.Patch.offset - (Inuit_region.unsafe_left_offset (region cursor')) - offset ; - ( match p.operation with - | Insert _ -> - let sl, sr = list_split offset t.buf in - t.buf <- sl @ Patch.inserted_text p @ sr - | Replace (i, _) | Remove i -> - let sl, sr = list_split offset t.buf in - let _, sr = list_split i sr in - t.buf <- sl @ Patch.inserted_text p @ sr - | Propertize i -> F.epr "Propertize %d@." i ) ; - let callback = - if side = `Remote then on_change else None in - (p.Patch.flags, callback) ) ; - t.bind.bindings <- bindings t ; - t - - let panel ?(height = !g_text_height) t = - Lwt.return - { act= - (fun _panel events -> - (* collect events and update Zed context *) - let open Input.Bind in - Lwt_list.iter_s - (function - | Custom f -> f () ; Lwt.return_unit - | CustomLwt f -> f () - | _ -> Lwt.return_unit ) - (actions_of_events t.bind events) - >>= fun () -> - Lwt_list.iter_s - (function - | `Text_input _s -> Lwt.return_unit - | _ -> Lwt.return_unit ) - events - >>= fun () -> - Nav.render t.view t.edit ; - Lwt.return - (draw_pp height (fun pp -> - Format.pp_open_hvbox pp 0 ; - format_symbolic_output_items pp (contents t) ; - F.pf pp "@." ; - Format.pp_close_box pp () ) ) ) - ; subpanels= [] - ; tag= "textedit" } - end - module Modal = struct type t = { te: Textedit.t @@ -1963,6 +1115,676 @@ module Panel = struct let is_active me = match me.input with Some _ -> true | None -> false end + + module Nottui = struct + open Nottui + open Notty + module P = Nottui_pretty + + let convert_events events : Nottui_lwt.event option list = + let key_of_keystate + (Input.{ctrl; meta; shift; super= _; code} as k) : + Notty.Unescape.key option = + F.epr "Nottui.convert_events: %s@." + (Input.to_string_compact k) ; + match code with + | None | Unknown -> None + | code -> + Some + ( ( match code with + | UChar c -> + let d = + Uchar.of_int (CamomileLibrary.UChar.code c) + in + if Uchar.is_char d then `ASCII (Uchar.to_char d) + else `Uchar d + | Enter -> `Enter + | Escape -> `Escape + | Tab -> `Tab + | Up -> `Arrow `Up + | Down -> `Arrow `Down + | Left -> `Arrow `Left + | Right -> `Arrow `Right + | F1 -> `Function 1 + | F2 -> `Function 2 + | F3 -> `Function 3 + | F4 -> `Function 4 + | F5 -> `Function 5 + | F6 -> `Function 6 + | F7 -> `Function 7 + | F8 -> `Function 8 + | F9 -> `Function 9 + | F10 -> `Function 10 + | F11 -> `Function 11 + | F12 -> `Function 12 + | Next_page -> `Page `Down + | Prev_page -> `Page `Up + | Home -> `Home + | End -> `End + | Insert -> `Insert + | Delete -> `Delete + | Backspace -> `Backspace + | _ -> `Uchar (Uchar.of_int 0) ) + , (if ctrl then [`Ctrl] else []) + @ (if meta then [`Meta] else []) + @ if shift then [`Shift] else [] ) in + List.filter_map + (function + | `Key_down k -> ( + match key_of_keystate k with + | None -> None + | Some k -> Some (Some (`Key k)) ) + | _ -> None ) + events + + module Attr = struct + type attr = + { fg: Wall.color + ; bg: Wall.color + ; size: float + ; font: [`Sans | `Serif | `Mono] + ; weight: [`Bold | `Regular | `Light] + ; italic: [`Italic | `None] + ; underline: [`Underline | `None] } + + let empty = + { fg= Color.void + ; bg= Color.void + ; size= 0. + ; font= `Sans + ; weight= `Regular + ; italic= `None + ; underline= `None } + + let equal = ( == ) + + let ( ++ ) a1 a2 = + if a1 == empty then a2 + else if a2 == empty then a1 + else + { a1 with + fg= Color.blend a1.fg a2.fg + ; bg= Color.blend a1.bg a2.bg } + + let fg fg = {empty with fg} + let bg bg = {empty with bg} + + let get_font a = + Text.Font.make ~size:a.size + (load_font + ( match (a.font, a.weight, a.italic) with + | `Sans, `Regular, `None -> "fonts/Roboto-Regular.ttf" + | `Sans, `Bold, `None -> "fonts/Roboto-Bold.ttf" + | `Sans, `Light, `None -> "fonts/Roboto-Light.ttf" + | `Sans, `Regular, `Italic -> "fonts/Roboto-Italic.ttf" + | `Sans, `Bold, `Italic -> "fonts/Roboto-BoldItalic.ttf" + | `Sans, `Light, `Italic -> + "fonts/Roboto-LightItalic.ttf" + | `Serif, `Bold, _ -> "fonts/ScheherazadeNew-Bold.ttf" + | `Serif, _, _ -> "fonts/ScheherazadeNew-Regular.ttf" + | `Mono, `Regular, `None -> + "fonts/static/RobotoMono-Regular.ttf" + | _, _, _ -> "fonts/Roboto-Regular.ttf" ) ) + end + + open Notty + + let invalid_arg fmt = Format.kasprintf invalid_arg fmt + let ( &. ) f g x = f (g x) + let btw (x : int) a b = a <= x && x <= b + let bit n b = b land (1 lsl n) > 0 + let max (a : int) b = if a > b then a else b + let min (a : int) b = if a < b then a else b + + let is_C0 x = x < 0x20 || x = 0x7f + and is_C1 x = 0x80 <= x && x < 0xa0 + + let is_ctrl x = is_C0 x || is_C1 x and is_ascii x = x < 0x80 + + let rec concatm z ( @ ) xs = + let rec accum ( @ ) = function + | ([] | [_]) as xs -> xs + | a :: b :: xs -> (a @ b) :: accum ( @ ) xs in + match xs with + | [] -> z + | [x] -> x + | xs -> concatm z ( @ ) (accum ( @ ) xs) + + let rec linspcm z ( @ ) x n f = + match n with + | 0 -> z + | 1 -> f x + | _ -> + let m = n / 2 in + linspcm z ( @ ) x m f @ linspcm z ( @ ) (x + m) (n - m) f + + let memo (type a) ?(hash = Hashtbl.hash) ?(eq = ( = )) ~size f = + let module H = Ephemeron.K1.Make (struct + type t = a + + let hash, equal = (hash, eq) + end) in + let t = H.create size in + fun x -> + try H.find t x + with Not_found -> + let y = f x in + H.add t x y ; y + + module List = struct + include List + + let init n f = + let rec go a n = if n < 0 then a else go (f n :: a) (n - 1) in + go [] (n - 1) + end + + module Buffer = struct + include Buffer + + let buf = Buffer.create 1024 + + let mkstring f = + f buf ; + let res = contents buf in + reset buf ; res + + let add_decimal b = function + | x when btw x 0 999 -> + let d1 = x / 100 + and d2 = x mod 100 / 10 + and d3 = x mod 10 in + if d1 > 0 then 0x30 + d1 |> Char.unsafe_chr |> add_char b ; + if d1 + d2 > 0 then + 0x30 + d2 |> Char.unsafe_chr |> add_char b ; + 0x30 + d3 |> Char.unsafe_chr |> add_char b + | x -> string_of_int x |> add_string b + + let add_chars b c n = + for _ = 1 to n do + add_char b c + done + end + + module Text = struct + let err_ctrl u = + invalid_arg "Notty: control char: U+%02X, %S" (Char.code u) + + let err_malformed = invalid_arg "Notty: malformed UTF-8: %s, %S" + + type t = + | Ascii of string * int * int + | Utf8 of string * int array * int * int + + let equal t1 t2 = + match (t1, t2) with + | Utf8 (s1, _, i1, n1), Utf8 (s2, _, i2, n2) + |Ascii (s1, i1, n1), Ascii (s2, i2, n2) -> + i1 = i2 && n1 = n2 && s1 = s2 + | _ -> false + + let width = function + | Utf8 (_, _, _, w) -> w + | Ascii (_, _, w) -> w + + let empty = Ascii ("", 0, 0) + + let graphemes str = + let seg = Uuseg.create `Grapheme_cluster in + let rec f ((is, w) as acc) i evt = + match Uuseg.add seg evt with + | `Await | `End -> acc + | `Uchar u -> + f (is, w + Uucp.Break.tty_width_hint u) i `Await + | `Boundary -> + let is = + match w with + | 0 -> is + | 1 -> i :: is + | _ -> i :: -1 :: is in + f (is, 0) i `Await in + let acc = + Uutf.String.fold_utf_8 + (fun acc i -> function + | `Malformed err -> err_malformed err str + | `Uchar _ as u -> f acc i u ) + ([0], 0) + str in + f acc (String.length str) `End + |> fst |> List.rev |> Array.of_list + + let dead = ' ' + + let to_buffer buf = function + | Ascii (s, off, w) -> Buffer.add_substring buf s off w + | Utf8 (s, ix, off, w) -> + let x1 = + match ix.(off) with + | -1 -> + Buffer.add_char buf dead ; + ix.(off + 1) + | x -> x + and x2 = ix.(off + w) in + Buffer.add_substring buf s x1 + @@ ((if x2 = -1 then ix.(off + w - 1) else x2) - x1) ; + if x2 = -1 then Buffer.add_char buf dead + + let sub t x w = + let w1 = width t in + if w = 0 || x >= w1 then empty + else + let w = min w (w1 - x) in + if w = w1 then t + else + match t with + | Ascii (s, off, _) -> Ascii (s, off + x, w) + | Utf8 (s, ix, off, _) -> Utf8 (s, ix, off + x, w) + + let is_ascii_or_raise_ctrl s = + let ( @! ) s i = String.unsafe_get s i |> Char.code in + let rec go s acc i n = + if n = 0 then acc + else + let x = s @! i in + if is_C0 x then err_ctrl s.[i] s + else if x = 0xc2 && n > 1 && is_C1 (s @! (i + 1)) then + err_ctrl s.[i + 1] s + else go s (acc && is_ascii x) (i + 1) (n - 1) in + go s true 0 (String.length s) + + let of_ascii s = Ascii (s, 0, String.length s) + + and of_unicode s = + let x = graphemes s in + Utf8 (s, x, 0, Array.length x - 1) + + let of_unicode = memo ~eq:String.equal ~size:128 of_unicode + + let of_string = function + | "" -> empty + | s -> + if is_ascii_or_raise_ctrl s then of_ascii s + else of_unicode s + + let of_uchars ucs = + of_string @@ Buffer.mkstring + @@ fun buf -> Array.iter (Buffer.add_utf_8_uchar buf) ucs + + let replicateu w u = + if is_ctrl (Uchar.to_int u) then + err_ctrl (Uchar.unsafe_to_char u) "" + else if w < 1 then empty + else if is_ascii (Uchar.to_int u) then + of_ascii (String.make w (Uchar.unsafe_to_char u)) + else + of_unicode @@ Buffer.mkstring + @@ fun buf -> + for _ = 1 to w do + Buffer.add_utf_8_uchar buf u + done + + let replicatec w c = replicateu w (Uchar.of_char c) + end + + module I = struct + type dim = int * int + + type t = + | Empty + | Segment of Text.t + | Attr of (t * Attr.attr) * dim + | Hcompose of (t * t) * dim + | Vcompose of (t * t) * dim + | Zcompose of (t * t) * dim + | Hcrop of (t * int * int) * dim + | Vcrop of (t * int * int) * dim + | Void of dim + + let width = function + | Empty -> 0 + | Segment text -> Text.width text + | Attr (_, (w, _)) -> w + | Hcompose (_, (w, _)) -> w + | Vcompose (_, (w, _)) -> w + | Zcompose (_, (w, _)) -> w + | Hcrop (_, (w, _)) -> w + | Vcrop (_, (w, _)) -> w + | Void (w, _) -> w + [@@inline] + + let height = function + | Empty -> 0 + | Segment _ -> 1 + | Attr (_, (_, h)) -> h + | Hcompose (_, (_, h)) -> h + | Vcompose (_, (_, h)) -> h + | Zcompose (_, (_, h)) -> h + | Hcrop (_, (_, h)) -> h + | Vcrop (_, (_, h)) -> h + | Void (_, h) -> h + [@@inline] + + let equal t1 t2 = + let rec eq t1 t2 = + match (t1, t2) with + | Empty, Empty -> true + | Segment t1, Segment t2 -> Text.equal t1 t2 + | Attr ((a, a1), _), Attr ((b, a2), _) -> + Attr.equal a1 a2 && eq a b + | Hcompose ((a, b), _), Hcompose ((c, d), _) + |Vcompose ((a, b), _), Vcompose ((c, d), _) + |Zcompose ((a, b), _), Zcompose ((c, d), _) -> + eq a c && eq b d + | Hcrop ((a, i1, n1), _), Hcrop ((b, i2, n2), _) + |Vcrop ((a, i1, n1), _), Vcrop ((b, i2, n2), _) -> + i1 = i2 && n1 = n2 && eq a b + | Void (a, b), Void (c, d) -> a = c && b = d + | _ -> false in + width t1 = width t2 && height t1 = height t2 && eq t1 t2 + + let empty = Empty + + let void w h = + if w < 1 && h < 1 then Empty else Void (max 0 w, max 0 h) + + let attr a = function + | Attr ((t, a0), dim) -> Attr ((t, Attr.(a ++ a0)), dim) + | t -> Attr ((t, a), (width t, height t)) + + let ( <|> ) t1 t2 = + match (t1, t2) with + | _, Empty -> t1 + | Empty, _ -> t2 + | _ -> + let w = width t1 + width t2 + and h = max (height t1) (height t2) in + Hcompose ((t1, t2), (w, h)) + + let ( <-> ) t1 t2 = + match (t1, t2) with + | _, Empty -> t1 + | Empty, _ -> t2 + | _ -> + let w = max (width t1) (width t2) + and h = height t1 + height t2 in + Vcompose ((t1, t2), (w, h)) + + let ( ) t1 t2 = + match (t1, t2) with + | _, Empty -> t1 + | Empty, _ -> t2 + | _ -> + let w = max (width t1) (width t2) + and h = max (height t1) (height t2) in + Zcompose ((t1, t2), (w, h)) + + let lincropinv crop void ( ++ ) init fini img = + match (init >= 0, fini >= 0) with + | true, true -> crop init fini img + | true, _ -> crop init 0 img ++ void (-fini) + | _, true -> void (-init) ++ crop 0 fini img + | _ -> void (-init) ++ img ++ void (-fini) + + let hcrop = + let ctor left right img = + let h = height img and w = width img - left - right in + if w > 0 then Hcrop ((img, left, right), (w, h)) + else void w h in + lincropinv ctor (fun w -> void w 0) ( <|> ) + + let vcrop = + let ctor top bottom img = + let w = width img and h = height img - top - bottom in + if h > 0 then Vcrop ((img, top, bottom), (w, h)) + else void w h in + lincropinv ctor (void 0) ( <-> ) + + let crop ?(l = 0) ?(r = 0) ?(t = 0) ?(b = 0) img = + let img = if l <> 0 || r <> 0 then hcrop l r img else img in + if t <> 0 || b <> 0 then vcrop t b img else img + + let hpad left right img = hcrop (-left) (-right) img + let vpad top bottom img = vcrop (-top) (-bottom) img + + let pad ?(l = 0) ?(r = 0) ?(t = 0) ?(b = 0) img = + crop ~l:(-l) ~r:(-r) ~t:(-t) ~b:(-b) img + + let hcat = concatm empty ( <|> ) + let vcat = concatm empty ( <-> ) + let zcat xs = List.fold_right ( ) xs empty + + let text attr tx = + match (Text.width tx, attr) with + | 0, _ -> void 0 1 + | w, Some a -> Attr ((Segment tx, a), (w, 1)) + | _, _ -> Segment tx + + let string ?attr s = text attr (Text.of_string s) + let uchars ?attr a = text attr (Text.of_uchars a) + + let tabulate m n f = + let m = max m 0 and n = max n 0 in + linspcm empty ( <-> ) 0 n (fun y -> + linspcm empty ( <|> ) 0 m (fun x -> f x y) ) + + let chars ctor ?attr c w h = + let w = max 0 w and h = max 0 h in + if w < 1 || h < 1 then void w h + else + let line = text attr (ctor w c) in + tabulate 1 h (fun _ _ -> line) + end + + (* let string ?(attr = Attr.empty) str = + let control_character_index str i = + let len = String.length str in + let i = ref i in + while + let i = !i in + i < len && str.[i] >= ' ' + do + incr i + done ; + if !i = len then raise Not_found ; + !i in + let rec split str i = + match control_character_index str i with + | j -> + let img = I.string ~attr (String.sub str i (j - i)) in + img :: split str (j + 1) + | exception Not_found -> + [ I.string ~attr + ( if i = 0 then str + else String.sub str i (String.length str - i) ) ] + in + Ui.atom (I.vcat (split str 0))*) + + let attr_menu_main = Attr.(bg (Color.gray 0.7) ++ fg Color.black) + let attr_menu_sub = Attr.(bg (Color.gray 0.5) ++ fg Color.black) + let attr_clickable = Attr.(bg Color.blue) + + let sub' str p l = + if p = 0 && l = String.length str then str + else String.sub str p l + + (* let edit_field ?(focus = Focus.make ()) state ~on_change = + let update focus_h focus (text, pos) = + let pos = min (max 0 pos) (String.length text) in + let content = + Ui.atom @@ I.hcat + @@ + if Focus.has_focus focus then + let attr = attr_clickable in + let len = String.length text in + ( if pos >= len then [I.string attr text] + else [I.string attr (sub' text 0 pos)] ) + @ + if pos < String.length text then + [ I.string Attr.(bg lightred) (sub' text pos 1) + ; I.string attr (sub' text (pos + 1) (len - pos - 1)) ] + else [I.string Attr.(bg lightred) " "] + else + [ I.string + Attr.(st underline) + (if text = "" then " " else text) ] in + let handler = function + | `ASCII 'U', [`Ctrl] -> + on_change ("", 0) ; + `Handled (* clear *) + | `ASCII 'k', [`Ctrl] -> + on_change (String.sub text 0 pos, pos) ; + `Handled (* clear *) + | `Escape, [] | `ASCII 'n', [`Ctrl] -> + Focus.release focus_h ; `Handled + | `ASCII k, [] -> + let text = + if pos < String.length text then + String.sub text 0 pos ^ String.make 1 k + ^ String.sub text pos (String.length text - pos) + else text ^ String.make 1 k in + on_change (text, pos + 1) ; + `Handled + | `Backspace, _ -> + let text = + if pos > 0 then + if pos < String.length text then + String.sub text 0 (pos - 1) + ^ String.sub text pos (String.length text - pos) + else if String.length text > 0 then + String.sub text 0 (String.length text - 1) + else text + else text in + let pos = max 0 (pos - 1) in + on_change (text, pos) ; + `Handled + | `Arrow `Left, [] | `ASCII 'b', [`Ctrl] -> + if pos > 0 && pos < String.length text then ( + on_change (text, pos - 1) ; + `Handled ) + else `Unhandled + | `Arrow `Right, [] | `ASCII 'f', [`Ctrl] -> + let pos = pos + 1 in + if pos <= String.length text then ( + on_change (text, pos) ; + `Handled ) + else `Unhandled + | `ASCII 'e', [`Ctrl] -> + on_change (text, String.length text) ; + `Handled + | `ASCII 'a', [`Ctrl] -> + on_change (text, 0) ; + `Handled + | _ -> `Unhandled in + Ui.keyboard_area ~focus handler content in + let node = + Lwd.map2 ~f:(update focus) (Focus.status focus) state in + let mouse_grab (text, pos) ~x ~y:_ = function + | `Left -> + if x <> pos then on_change (text, x) ; + Nottui.Focus.request focus ; + `Handled + | _ -> `Unhandled in + Lwd.map2 state node ~f:(fun state content -> + Ui.mouse_area (mouse_grab state) content ) + + let simple_edit s = + let var = Lwd.var (s, 0) in + edit_field (Lwd.get var) ~on_change:(Lwd.set var) + *) + (* let render (img : Notty.I.t) w h : Wall.Image.t = + let module WI = Wall.Image in + let open Operation in + let simple_text ~x ~y s a : Wall.image = + let font = get_font a in + let fm = Text.Font.font_metrics font in + let font_height = fm.ascent -. fm.descent +. fm.line_gap in + (* let _, (_, redbox) = path_box Color.red bextent s in*) + WI.paint (Wall.Paint.color a.fg) + Text.(simple_text font ~valign:`TOP ~halign:`LEFT ~x ~y s) + in + let a' = ref attr_default in + let rec line (x, y) (op : Operation.t) : Wall.Image.t = + match op with + | End -> Image.empty + | Skip (n, End) -> Image.empty + | Text (a, x, End) -> erase cap buf ; text_op cap buf a x + | Skip (n, ops) -> + WI.stack + (simple_text !a' (String.make n ' ')) + (line (x, y) 0) + | Text (a, x, ops) -> + a' := a ; + WI.stack (simple_text a x) (line (x, y) ops) in + let rec lines = function + | [] -> () + | [ln] -> line cap buf ln ; cap.sgr Attr.empty buf + | ln :: lns -> + line cap buf ln ; cap.newline buf ; lines cap buf lns + in + simple_text + Operation.of_image (0 0) (w h) img |> lines*) + + let scroll_area ?(offset = (0, 0)) ?(scroll_step = 1) t = + let offset = Lwd.var offset in + let scroll d_x d_y = + let s_x, s_y = Lwd.peek offset in + let s_x = max 0 (s_x + d_x) in + let s_y = max 0 (s_y + d_y) in + Lwd.set offset (s_x, s_y) ; + `Handled in + let focus_handler = function + | `Arrow `Left, [] -> scroll (-scroll_step) 0 + | `Arrow `Right, [] -> scroll (+scroll_step) 0 + | `Arrow `Up, [] -> scroll 0 (-scroll_step) + | `Arrow `Down, [] -> scroll 0 (+scroll_step) + | `Page `Up, [] | `ASCII 'v', [`Ctrl] -> + scroll 0 (-scroll_step * 8) + | `Page `Down, [] | `ASCII 'v', [`Meta] -> + scroll 0 (+scroll_step * 8) + | _ -> `Unhandled in + let scroll_handler ~x:_ ~y:_ = function + | `Scroll `Up -> scroll 0 (-scroll_step) + | `Scroll `Down -> scroll 0 (+scroll_step) + | _ -> `Unhandled in + Lwd.map2 t (Lwd.get offset) ~f:(fun t (s_x, s_y) -> + t |> Ui.shift_area s_x s_y + |> Ui.mouse_area scroll_handler + |> Ui.keyboard_area focus_handler ) + + (* let menu (items : 'a Lwd_table.t) : ui Lwd.t = + Lwd_table.map_reduce + (fun row r -> Ui.keyboard_area) + Ui.pack_y items*) + + let panel wm () = + let events, push_event = Lwt_stream.create () in + let size = ref (200, 200) in + let check_size ?(scale = 10.) {box; _} = + let newsize = + ( int_of_float (Box2.w box /. scale) + , int_of_float (Box2.h box /. scale) ) in + if newsize <> !size then size := newsize ; + push_event (Some (`Resize !size)) in + let pane = ref Display.pane_empty in + let images = Nottui_lwt.render ~size:!size events wm in + Lwt.return + { act= + (fun _panel ev -> + List.iter push_event (convert_events ev) ; + Lwt_stream.last_new images + >>= fun img -> + (pane := + fun s -> + check_size s ; + draw_pp 20.0 + (fun pp -> + (Notty.Render.pp Notty.Cap.dumb pp) img ; + F.flush pp () ) + s ) ; + Lwt.return !pane ) + ; subpanels= [] + ; tag= "binding-state" } + end end module Toplevel = struct @@ -2302,14 +2124,9 @@ let std_actor (root_panel : Panel.t Lwt.t) = let root_actor = ref (std_actor (Store.editor "../rootstore")) -open Panel - -let inuit_test = - let t = InuitTextedit.make " TEST @. What @. Help @." in - InuitTextedit.panel t - let start () = - root_actor := std_actor inuit_test ; + (* root_actor := + std_actor Panel.Nottui.(panel (simple_edit "hello edit") ()) ;*) Display.( run (make_frame ~title:"hi" ~w:1440 ~h:900 ()) root_actor ()) diff --git a/irc.ml b/irc.ml index 4df3b52..ab38f3a 100644 --- a/irc.ml +++ b/irc.ml @@ -14,102 +14,244 @@ open Lwt_react module F = Fmt module Communicator = struct - type msg = {content: string; time: string; mutable seen: bool} + module Message = struct + type t = {content: string; time: string; mutable seen: bool} - let create_msg ?(time = "") content = - {content; time; seen= false} + let make ?(time = "") content = {content; time; seen= false} + end - type channel = - { mutable name: string - ; mutable content: msg list - ; mutable recv: msg -> unit } + module Channel = struct + type t = {name: string; content: Message.t list Lwd.var} - let add_msg (c : channel) msg = c.content <- msg :: c.content + let add_msg (c : t) (msg : Message.t) = + F.epr "Channel.add_msg msg.content=\"%s\"@." msg.content ; + let cn = Lwd.peek c.content in + Lwd.set c.content (msg :: cn) - type t = {mutable channel: channel; mutable subs: t list} - type protocol = Irc | Email | Rss | Mublog + let make name = {name; content= Lwd.var []} + end - let make_channel ?(recv = add_msg) name = - let c = {name; content= []; recv= (fun _ -> ())} in - {c with recv= recv c} + module Tree = struct + open Channel + open Message - let make () : t = - let channel = make_channel "top" in - channel.recv (create_msg "Wecome to the Communicator") ; - channel.recv (create_msg "Currently only IRC is implemented") ; - {channel; subs= []} + type t = + { channel: Channel.t + ; subs: t Lwd_table.t + ; focus: Nottui.Focus.handle } - type connection = unit Lwt.t + type protocol = Irc | Email | Rss | Mublog | ActivityPub + + let add (comm : t) ch : unit = + let c' = + { channel= ch + ; subs= Lwd_table.make () + ; focus= Nottui.Focus.make () } in + Lwd_table.append' comm.subs c' + + let make_top () = + let channel = Channel.make "communicator-top" in + add_msg channel (Message.make "Welcome to the Communicator") ; + add_msg channel + (Message.make "Currently only IRC is implemented") ; + {channel; subs= Lwd_table.make (); focus= Nottui.Focus.make ()} + end module Irc = struct module C = Irc_client_tls module M = Irc_message - let connection (c : t) server port nick channels : unit Lwt.t = - let add_msg cn str = add_msg cn.channel (create_msg str) in - C.reconnect_loop ~after:30 - ~connect:(fun () -> - Lwt_io.printl "Connecting..." - >>= fun () -> - C.connect_by_name ~server ~port ~nick () - >>= fun c -> - Lwt_io.printl "connect_by_name returned" - >>= fun () -> Lwt.return c ) - ~f:(fun connection -> - Lwt_io.printl "Connected" - >>= fun () -> - Lwt_list.iter_p - (fun channel -> - let joiner = C.send_join ~connection ~channel in - (* make_channel c ~sender:(fun s -> - C.send_privmsg ~target:channel ~message:s) channel ; *) - joiner ) - channels ) - ~callback:(fun _connection result -> - match result with - | Result.Ok ({M.command= M.Other _; _} as msg) -> - add_msg c - (F.str "Got unknown message: %s\n" (M.to_string msg)) ; - Lwt.return_unit - | Result.Ok ({M.command= M.PRIVMSG (target, data); _} as msg) - -> - add_msg c - (F.str "Got PRIVMSG: target=%s, data=%s; %s\n" target - data (M.to_string msg) ) ; - Lwt.return_unit - | Result.Ok msg -> - add_msg c (M.to_string msg) ; - Lwt.return_unit - | Result.Error e -> Lwt_io.printl e ) - () + let connection (c : Tree.t) server port nick + (channels : string list) : Channel.t = + let channel = + Channel.make ("IRC: " ^ server ^ ":" ^ string_of_int port) + in + let _c' = Tree.add c channel in + let add_msg str = Channel.add_msg channel (Message.make str) in + let channel_assoc = ref [] in + let make_ch name = + let ch = Channel.make name in + Tree.add c ch ; + channel_assoc := (name, ch) :: !channel_assoc ; + ch in + Lwt.async + (C.reconnect_loop ~after:30 + ~connect:(fun () -> + add_msg "Connecting..." ; + C.connect_by_name ~server ~port ~nick () + >>= fun c -> + Lwt_io.printl "connect_by_name returned" + >>= fun () -> Lwt.return c ) + ~f:(fun connection -> + add_msg "Connected" ; + Lwt_list.iter_p + (fun chname -> + C.send_join ~connection ~channel:chname + >>= fun () -> + ignore (make_ch chname) ; + Lwt.return_unit ) + channels ) + ~callback:(fun _connection result -> + match result with + | Result.Ok ({M.command= M.Other _; _} as msg) -> + add_msg (M.to_string msg) ; + Lwt.return_unit + | Result.Ok + {M.command= M.PRIVMSG (target, data); prefix= user} + -> + let user = + match user with + | Some u -> List.hd (String.split_on_char '!' u) + | None -> "unknown" in + ( match List.assoc_opt target !channel_assoc with + | Some ch -> Channel.add_msg ch + | None -> Channel.add_msg (make_ch target) ) + (Message.make (F.str "<%s> %s" user data)) ; + Lwt.return_unit + | Result.Ok msg -> + add_msg (M.to_string msg) ; + Lwt.return_unit + | Result.Error e -> Lwt_io.printl e ) ) ; + channel end module Panel = struct - let panel (c : t) = - let open Panel in - let te = Textedit.make "" () in - Textedit.panel ~height:20. te - >>= fun p -> - Lwt.return - { p with - act= - (fun panel events -> - Textedit.clear te ; - List.iter - (fun m -> - Textedit.insert te - (F.str "[%s] %s\n" m.time m.content) ) - c.channel.content ; - p.act panel events ) } + open Nottui + module P = Nottui_pretty + + let string ?attr text = P.ui (Nottui_widgets.string ?attr text) + let ( ^^ ) = P.( ^^ ) + let ( ^/^ ) a b = P.(a ^^ break 1 ^^ b) + + let messagelist (ch : Channel.t) : P.t Lwd.t = + Lwd.map (Lwd.get ch.content) ~f:(fun (msgs : Message.t list) -> + List.fold_left + (fun doc (msg : Message.t) -> + F.epr "Communicator.Panel.messagelist ch.content=%s@." + msg.content ; + doc + ^^ P.group + ( string msg.time ^/^ string " | " + ^/^ string msg.content ) + ^^ P.hardline ) + P.empty msgs ) + + open Nottui_widgets + + (*type focustree = + {channel: Channel.t; subs: focustree list; focus: Focus.handle} + + let channeltree (tree : Tree.t) : focustree Lwd.t = + let rec fold (tree : Tree.t) : focustree list Lwd.t = + Lwd_table.map_reduce + (fun _row (tree : Tree.t) -> + Lwd.map (fold tree) ~f:(fun (subs : focustree list) -> + { channel= tree.channel + ; subs + ; focus= Focus.make () } )) + ([], fun a b -> List.append a b) + tree.subs in + let {channel= tree.channel; subs= fold tree; focus= Focus.make ()} *) + + let channelview (tree : Tree.t) : 'a Lwd.t * Channel.t Lwd.var = + let channel = Lwd.var tree.channel in + let rec fold ?(indent = 0) ?superfocus (tree : Tree.t) : + 'a Lwd.t = + let subfocus = Focus.make () in + Lwd.join + (Lwd_table.map_reduce + (fun row (tree : Tree.t) -> + let focus = + match superfocus with + | Some sf -> + Lwd.map2 (Focus.status sf) + (Focus.status tree.focus) + ~f:(fun superfocus' focus' -> + if Focus.has_focus superfocus' then + F.epr + "Focus.has_focus superfocus' = true@." ; + Focus.release sf ; + Focus.request tree.focus ; + focus' ) + | None -> Focus.status tree.focus in + Lwd.map2 + (Lwd.map focus ~f:(fun focus -> + if Focus.has_focus focus then + Lwd.set channel tree.channel ; + Ui.keyboard_area ~focus + (fun key -> + match key with + | `ASCII 'w', [] -> ( + match Lwd_table.prev row with + | Some r -> ( + match Lwd_table.get r with + | Some r -> + Focus.release tree.focus ; + Focus.request r.focus ; + `Handled + | None -> `Unhandled ) + | None -> `Unhandled ) + | `ASCII 'a', [] -> ( + match superfocus with + | Some f -> + Focus.release tree.focus ; + Focus.request f ; + `Handled + | None -> `Unhandled ) + | `ASCII 's', [] -> ( + match Lwd_table.next row with + | Some r -> ( + match Lwd_table.get r with + | Some r -> + Focus.release tree.focus ; + Focus.request r.focus ; + `Handled + | None -> `Unhandled ) + | None -> `Unhandled ) + | `ASCII 'd', [] -> + Focus.release tree.focus ; + Focus.request subfocus ; + `Handled + | _ -> `Unhandled ) + (Ui.join_x + (Ui.join_x + ( if Focus.has_focus focus then + string "+" + else string "" ) + (string (String.make indent '-')) ) + (string Tree.(tree.channel.name)) ) ) ) + (fold ~indent:(indent + 1) ~superfocus:subfocus tree) + ~f:(fun parent subs -> Ui.join_y parent subs) ) + (Lwd_utils.lift_monoid Ui.pack_y) + tree.subs ) in + (fold tree, channel) + + let messageview (ch : Channel.t Lwd.var) = + Panel.Nottui.scroll_area + (Lwd.map + (Lwd.bind (Lwd.get ch) ~f:messagelist) + ~f:(P.pretty 200) ) + + let commview c = + let cv, ch = channelview c in + Nottui_widgets.h_pane + (Panel.Nottui.scroll_area cv) + (messageview ch) + + type view = Channel of (Channel.t * view list) | Cursor of view + + let panel (comm : Tree.t) = + let base = Lwd.var Nottui_widgets.empty_lwd in + Lwd.set base (commview comm) ; + Panel.Nottui.panel (Lwd.join (Lwd.get base)) () end end let _ = - let comm = Communicator.make () in - let hackint = + let comm = Communicator.Tree.make_top () in + let _irc = Communicator.Irc.connection comm "irc.hackint.org" 6697 "cqcaml" ["#CQC"] in - Lwt.async (fun () -> hackint) ; root_actor := std_actor (Communicator.Panel.panel comm) (**