diff --git a/.nix-helpers/nixops.nix b/.nix-helpers/nixops.nix deleted file mode 100644 --- a/.nix-helpers/nixops.nix +++ /dev/null @@ -1,110 +0,0 @@ -# This file can be used with `nixops` to create a virtual machine that has -# Termonad installed. -# -# I use this to test out Termonad in a desktop environment with a menubar. -# -# On my development machine, I use XMonad as a Window Manager, so there are -# no Window decorations for any X application. This file creates a VM -# with Termonad installed in Gnome 3. This lets you see what Termonad -# looks like when it has Window decorations, a title bar, etc. -# -# A virtual machine can be created based on this file with the following -# commands: -# -# $ nixops create --deployment termonad-test .nix-helpers/nixops.nix -# $ nixops deploy --deployment termonad-test -# -# This should open up a VirtualBox machine and start installing Gnome 3, -# Termonad, etc. -# -# You should be able to login with the username "myuser" and password "foobar". -# -# When you are done you can destroy the machine and delete the deployment: -# -# $ nixops destroy --deployment termonad-test -# $ nixops delete --deployment termonad-test -# - -{ - network.description = "Gnome With Termonad"; - - termonad-machine = - { config, pkgs, ...}: - { - imports = [ ]; - - deployment = { - targetEnv = "virtualbox"; - virtualbox = { - disks.disk1.size = 20480; - headless = false; - memorySize = 2024; - vcpu = 1; - }; - }; - - environment = { - systemPackages = - let - pkgList = with pkgs; [ - acpi aspell aspellDicts.en autojump bash bash-completion bc - chromium curl dmenu emacs evince file firefoxWrapper gcc geeqie - gimp gitAndTools.gitFull gitAndTools.hub gnumake gnupg hexchat - htop imagemagick jq k2pdfopt ltrace manpages ncurses - nix-bash-completions nixops p7zip pkgconfig psmisc python3 - redshift roxterm screen strace tree unzip usbutils vimHugeX wget - wirelesstools xfce.terminal xorg.xbacklight xorg.xmodmap - xscreensaver xterm zlib - ]; - termonad = import ../default.nix { }; - in [ termonad ] ++ pkgList; - variables.EDITOR = "vim"; - }; - - fonts.fonts = with pkgs; [ - dejavu_fonts ipafont source-code-pro ttf_bitstream_vera - ]; - - i18n = { - consoleFont = "Lat2-Terminus16"; - consoleKeyMap = "us"; - defaultLocale = "en_US.UTF-8"; - inputMethod = { - enabled = "fcitx"; - fcitx.engines = with pkgs.fcitx-engines; [ mozc ]; - }; - }; - - programs.bash.enableCompletion = true; - - services = { - xserver = { - enable = true; - layout = "us"; - desktopManager.gnome3.enable = true; - }; - openssh = { - enable = true; - forwardX11 = true; - challengeResponseAuthentication = true; - passwordAuthentication = true; - permitRootLogin = "yes"; - }; - }; - - security.sudo = { - enable = true; - extraConfig = '' - %wheel ALL=(ALL:ALL) NOPASSWD: ${pkgs.systemd}/bin/poweroff - %wheel ALL=(ALL:ALL) NOPASSWD: ${pkgs.systemd}/bin/reboot - %wheel ALL=(ALL:ALL) NOPASSWD: ${pkgs.systemd}/bin/systemctl suspend - ''; - }; - - users.extraUsers.myuser = { - extraGroups = [ "audio" "systemd-journal" "video" "wheel" ]; - initialPassword = "foobar"; - isNormalUser = true; - }; - }; -} diff --git a/.nix-helpers/nixos-vm.nix b/.nix-helpers/nixos-vm.nix new file mode 100644 --- /dev/null +++ b/.nix-helpers/nixos-vm.nix @@ -0,0 +1,110 @@ + +# This file is used to build a NixOS VM that can be used to test Termonad in a +# known-working desktop environment (DE) / window manager (WM). +# +# This is helpful for developers using a minimal WM (like XMonad), but want to +# check how Termonad looks in a more full-featured desktop environment. +# +# You can build the VM with the following command: +# +# $ nix-build "$(nix-instantiate --eval -E 'with import ./nixpkgs.nix {}; path')"/nixos -A vm -I nixpkgs=./nixpkgs.nix -I nixos-config=./nixos-vm.nix +# +# You can run the resulting VM with the following command: +# +# $ ./result/bin/run-termonad-nixos-vm-vm -m 4G +# +# The `-m` flag allows you to specify how much RAM is used. + +{ config, pkgs, lib, ... }: + +{ + nixpkgs.overlays = import ./overlays.nix; + + boot.loader.systemd-boot.enable = true; + boot.loader.efi.canTouchEfiVariables = true; + + networking.hostName = "termonad-nixos-vm"; + networking.networkmanager.enable = true; + networking.useDHCP = lib.mkDefault true; + + time.timeZone = "UTC"; + + environment.systemPackages = with pkgs; [ + curl + file + firefox + htop + jq + ltrace + nix-bash-completions + pkg-config + psmisc + screen + strace + termonad + tree + unzip + vimHugeX + wget + xterm + ]; + + environment.variables = { + EDITOR = "vim"; + }; + + fonts.fonts = with pkgs; [ + dejavu_fonts ipafont + ]; + + i18n = { + defaultLocale = "en_US.UTF-8"; + supportedLocales = [ "C.UTF-8/UTF-8" "en_US.UTF-8/UTF-8" "ja_JP.UTF-8/UTF-8" ]; + inputMethod = { + enabled = "fcitx5"; + fcitx5.addons = with pkgs; [ fcitx5-mozc fcitx5-rime fcitx5-chinese-addons ]; + }; + }; + + console = { + font = "Lat2-Terminus16"; + keyMap = "us"; + }; + + programs.bash.enableCompletion = true; + + services.xserver = { + enable = true; + layout = "us"; + desktopManager.gnome.enable = true; + }; + + services.openssh = { + enable = true; + settings = { + X11Forwarding = true; + KbdInteractiveAuthentication = true; + ChallengeResponseAuthentication = true; + PasswordAuthentication = true; + PermitRootLogin = "yes"; + MaxAuthTries = 12; + }; + }; + + security.sudo = { + enable = true; + extraConfig = '' + %wheel ALL=(ALL:ALL) NOPASSWD: ${pkgs.systemd}/bin/poweroff + %wheel ALL=(ALL:ALL) NOPASSWD: ${pkgs.systemd}/bin/reboot + %wheel ALL=(ALL:ALL) NOPASSWD: ${pkgs.systemd}/bin/systemctl suspend + ''; + }; + + users.extraUsers.myuser = { + extraGroups = [ "audio" "systemd-journal" "video" "wheel" ]; + initialPassword = "foobar"; + isNormalUser = true; + }; + + system.stateVersion = "23.05"; # Did you read the comment? +} diff --git a/.nix-helpers/overlays.nix b/.nix-helpers/overlays.nix --- a/.nix-helpers/overlays.nix +++ b/.nix-helpers/overlays.nix @@ -78,7 +78,7 @@ # # Either this, or termonadKnownWorkingHaskellPkgSet can be changed in an overlay # if you want to use a different GHC to build Termonad. - termonadCompilerVersion = "ghc92"; + termonadCompilerVersion = "ghc94"; # A Haskell package set where we know the GHC version works to compile # Termonad. This is basically just a shortcut so that other Nix files @@ -146,7 +146,7 @@ lens ]; - termonad-with-packages = + termonad = let # GHC environment that has termonad available, as well as the packages # specified above in extraHaskellPackages. @@ -155,7 +155,7 @@ (hpkgs: [ hpkgs.termonad ] ++ self.termonadExtraHaskellPackages hpkgs); in self.stdenv.mkDerivation { - name = "termonad-with-packages-ghc-${env.version}"; + name = "termonad-${self.termonadKnownWorkingHaskellPkgSet.termonad.version}-ghc-${env.version}"; buildInputs = [ self.gdk-pixbuf self.gnome.adwaita-icon-theme @@ -178,6 +178,10 @@ preferLocalBuild = true; allowSubstitutes = false; }; + + # This is just a small compatibility layer for people that used to use + # termonad-with-packages instead of just termonad. + termonad-with-packages = self.termonad; }; in diff --git a/.nix-helpers/termonad-with-packages.nix b/.nix-helpers/termonad-with-packages.nix --- a/.nix-helpers/termonad-with-packages.nix +++ b/.nix-helpers/termonad-with-packages.nix @@ -100,4 +100,4 @@ }; in -pkgs.termonad-with-packages +pkgs.termonad diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,49 @@ +## 4.6.0.0 + +* The thing that may affect end users the most in this release is that the + **`defaultMain` function moved from `Termonad.App` to `Termonad.Startup`**. + (_However, it is also exported from the top-level `Termonad` module, so most + users will likely want to get it from the top-level `Termonad` module_.) + [#239](https://github.com/cdepillabout/termonad/pull/239) + +* There has been a big refactoring of the guts of Termonad. As an end user, + if you reach into any modules like `Termonad.App`, `Termonad.Term`, or + `Termonad.Types`, you may notice some functions have moved around or gained + new arguments. Some data types have changed as well. Most end users don't + use these modules, so I don't expect that this refactoring will affect most + users. + +* Add support for setting Termonad options with CLI arguments. Add a whole + CLI argument parser based on optparse-applicative. + [#234](https://github.com/cdepillabout/termonad/pull/234) + + Check out `termonad --help` to see the options available to be set from the CLI. + + By default, passing CLI options will override options specified in the + `termonad.hs` file, as well as options specified in the Preferences dialog. + + In your own `termonad.hs` file, if you want to not use this CLI argument + funtionality, you should be able to use the `Termonad.start` function (in + place of `Termonad.defaultMain`). + +* Embed the Termonad icon into the Termonad library (instead of having it set + as a `data-file` in `termonad.cabal`). + + This fixes a problem some users were seeing when garbaging-collecting their + Nix store and losing the required `termonad-lambda.png` file that their + Termonad binary was referencing: + [#165](https://github.com/cdepillabout/termonad/issues/165) + + Thanks [@refaelsh](https://github.com/refaelsh)! [#236](https://github.com/cdepillabout/termonad/pull/236) + +* Rename the `Termonad.PreferencesFile` module to `Termonad.Preferences.File`. + + Also, add a `Termonad.Preferences` module that re-exports everything helpful + from the `Termonad.Preferences.File` module. Also, some of the + preferences-related functionality from `Termonad.App` has been moved into + `Termonad.Preferences`. + [#238](https://github.com/cdepillabout/termonad/pull/238) + ## 4.5.0.0 * Add an `allowBold` option (which defaults to `True`). This can be used if diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -292,35 +292,34 @@ Termonad is similar to XMonad. The above steps will install a `termonad` binary somewhere on your system. If you have installed Termonad using `stack`, the -`termonad` binary will be in `~/.local/bin/`. This binary is a version of -Termonad configured with default settings. You can try running it to get an idea -of what Termonad is like: +`termonad` binary will be in `~/.local/bin/`. If you have installed Termonad using +your Linux distro, the `termonad` binary will likely be in `/usr/bin/`. This +binary is a version of Termonad configured with default settings. You can try +running it to get an idea of what Termonad is like: ```sh -$ ~/.local/bin/termonad +$ /usr/bin/termonad ``` -The following section describes the default key bindings. - If you would like to configure Termonad with your own settings, first you will need to create a Haskell file called `~/.config/termonad/termonad.hs`. A following section gives an example configuration file. -If this configuration file exists, when the `~/.local/bin/termonad` binary +If this configuration file exists, when the `/usr/bin/termonad` binary launches, it will try to use GHC to compile the configuration file. If GHC is able to successfully compile the configuration file, a separate binary will be created called something like `~/.cache/termonad/termonad-linux-x86_64`. This binary file can be thought of as your own personal Termonad, configured with all your own settings. -When you run `~/.local/bin/termonad`, it will re-exec +When you run `/usr/bin/termonad`, it will re-exec `~/.cache/termonad/termonad-linux-x86_64` if it exists. However, there is one difficulty with this setup. In order for the -`~/.local/bin/termonad` binary to be able to compile your +`/usr/bin/termonad` binary to be able to compile your `~/.config/termonad/termonad.hs` configuration file, Termonad needs to know where GHC is, as well as where all your Haskell packages live. This presents -some difficulties that will be discussed in a following section. +some difficulties that will be discussed in one of the following sections. ### Default Key Bindings @@ -341,31 +340,40 @@ ### Configuring Termonad -Termonad has two different ways to be configured. +Termonad has three different ways to be configured. -The first way is to use the built-in Preferences editor. You can find this in -the `Preferences` menu under `Edit` in the menubar. +1. Pass arguments on the command line. For instance, run + `termonad --no-show-menu` to never show the `File` menubar. -When opening Termonad for the first time, it will create a preferences file at -`~/.config/termonad/termonad.yaml`. When you change a setting in the -Preferences editor, Termonad will update the setting in the preferences file. + Arguments passed on the command line will normally override other + configuration methods. -When running Termonad, it will load settings from the preferences file. -Do not edit the preferences file by hand, because it will be overwritten when -updating settings in the Preferences editor. +2. Use the built-in Preferences editor. You can find this in + the `Preferences` menu under `Edit` in the menubar. -This method is perfect for users who only want to make small changes to the -Termonad settings, like the default font size. + When opening Termonad for the first time, it will create a preferences file + at `~/.config/termonad/termonad.yaml`. When you change a setting in the + Preferences editor, Termonad will update the setting in the preferences + file. -The second way to configure Termonad is to use a Haskell-based settings file, -called `~/.config/termonad/termonad.hs` by default. This method allows you to -make large, sweeping changes to Termonad. This method is recommended for power -users. + When running Termonad, it will load settings from the preferences file. Do + not edit the preferences file by hand, because it will be overwritten when + updating settings in the Preferences editor. + This method is perfect for users who only want to make small changes to the + Termonad settings, like the default font size. + +3. Use a Haskell-based settings file, called `~/.config/termonad/termonad.hs` by default. + This method allows you to make large, sweeping changes to Termonad. This + method is recommended for power users. + + The rest of this section explains the `~/.config/termonad/termonad.hs` file. + **WARNING: If you have a `~/.config/termonad/termonad.hs` file, then all settings from `~/.config/termonad/termonad.yaml` will be ignored. If you want to set *ANY* settings in `~/.config/termonad/termonad.hs`, then you must -set *ALL* settings in `~/.config/termonad/termonad.hs`.** +set *ALL* settings in `~/.config/termonad/termonad.hs`. However, as stated above, +CLI arguments will override settings in `~/.config/termonad/termonad.hs` by default.** The following is an example Termonad configuration file. You should save this to `~/.config/termonad/termonad.hs`. You can find more information on the available @@ -378,11 +386,11 @@ module Main where -import Termonad.App (defaultMain) -import Termonad.Config +import Termonad ( FontConfig, FontSize(FontSizePoints), Option(Set) , ShowScrollbar(ShowScrollbarAlways), defaultConfigOptions, defaultFontConfig - , defaultTMConfig, fontConfig, fontFamily, fontSize, options, showScrollbar + , defaultMain, defaultTMConfig, fontConfig, fontFamily, fontSize, options + , showScrollbar ) import Termonad.Config.Colour ( AlphaColour, ColourConfig, addColourExtension, createColour @@ -439,9 +447,9 @@ ### Compiling Local Settings -If you launch Termonad by calling `~/.local/bin/termonad`, it will try to +If you launch Termonad by calling `/usr/bin/termonad`, it will try to compile the `~/.config/termonad/termonad.hs` file if it exists. The problem is -that `~/.local/bin/termonad` needs to be able to see GHC and the required +that `/usr/bin/termonad` needs to be able to see GHC and the required Haskell libraries to be able to compile `~/.config/termonad/termonad.hs`. There are a couple solutions to this problem, listed in the sections below. @@ -452,9 +460,10 @@ #### Running with `stack` -If you originally compiled Termonad with `stack`, you can use `stack` to -execute Termonad. First, you must change to the directory with the Termonad -source code. From there, you can run `stack exec`: +If you originally compiled Termonad with `stack` and installed it to +`~/.local/bin/termonad`, you can use `stack` to execute Termonad. First, you +must change to the directory with the Termonad source code. From there, you +can run `stack exec`: ```sh $ cd termonad/ # change to the termonad source code directory diff --git a/default.nix b/default.nix --- a/default.nix +++ b/default.nix @@ -24,5 +24,4 @@ , enableSixelSupport ? false }@args: -(import .nix-helpers/nixpkgs.nix args).termonad-with-packages - +(import .nix-helpers/nixpkgs.nix args).termonad diff --git a/flake.lock b/flake.lock --- a/flake.lock +++ b/flake.lock @@ -2,11 +2,11 @@ "nodes": { "nixpkgs": { "locked": { - "lastModified": 1680213900, - "narHash": "sha256-cIDr5WZIj3EkKyCgj/6j3HBH4Jj1W296z7HTcWj1aMA=", + "lastModified": 1704194953, + "narHash": "sha256-RtDKd8Mynhe5CFnVT8s0/0yqtWFMM9LmCzXv/YKxnq4=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "e3652e0735fbec227f342712f180f4f21f0594f2", + "rev": "bd645e8668ec6612439a9ee7e71f7eac4099d4f6", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix --- a/flake.nix +++ b/flake.nix @@ -44,7 +44,7 @@ let pkgs = nixpkgsFor.${system}; in { - termonad = pkgs.termonad-with-packages; + termonad = pkgs.termonad; } ); diff --git a/src/Termonad.hs b/src/Termonad.hs --- a/src/Termonad.hs +++ b/src/Termonad.hs @@ -5,15 +5,17 @@ -- Stability : experimental -- Portability : POSIX -- --- This module exposes termonad's basic configuration options, as well as 'defaultMain'. +-- This module exposes Termonad's basic configuration options, as well as 'defaultMain', 'startWithCliArgs', and 'start'. -- -- If you want to configure Termonad, please take a look at "Termonad.Config". module Termonad ( defaultMain + , startWithCliArgs , start , module Config ) where -import Termonad.App (defaultMain, start) +import Termonad.App (start) import Termonad.Config as Config +import Termonad.Startup (defaultMain, startWithCliArgs) diff --git a/src/Termonad/App.hs b/src/Termonad/App.hs --- a/src/Termonad/App.hs +++ b/src/Termonad/App.hs @@ -1,13 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-} + module Termonad.App where import Termonad.Prelude -import Config.Dyre (defaultParams, projectName, realMain, showError, wrapMain) -import Control.Lens ((.~), (^.), (^..), over, set, view) -import Control.Monad.Fail (fail) -import Data.FocusList (focusList, moveFromToFL, updateFocusFL) -import Data.Sequence (findIndexR) -import GI.Gdk (castTo, managedForeignPtr, screenGetDefault) +import Control.Lens ((^.)) +import Data.FileEmbed (embedFile) +import qualified Data.Text as Text +import Data.Text.Encoding (encodeUtf8) +import GI.Gdk (screenGetDefault) import GI.Gio ( ApplicationFlags(ApplicationFlagsFlagsNone) , MenuModel(MenuModel) @@ -23,20 +24,9 @@ ( Application , ApplicationWindow(ApplicationWindow) , Box(Box) - , CheckButton(CheckButton) - , ComboBoxText(ComboBoxText) - , Dialog(Dialog) - , Entry(Entry) - , FontButton(FontButton) - , Label(Label) - , PolicyType(PolicyTypeAutomatic) - , PositionType(PositionTypeRight) - , ResponseType(ResponseTypeAccept, ResponseTypeNo, ResponseTypeYes) - , ScrolledWindow(ScrolledWindow) - , SpinButton(SpinButton) + , Notebook + , ResponseType(ResponseTypeNo, ResponseTypeYes) , pattern STYLE_PROVIDER_PRIORITY_APPLICATION - , aboutDialogNew - , adjustmentNew , applicationAddWindow , applicationGetActiveWindow , applicationSetAccelsForAction @@ -45,142 +35,55 @@ , boxPackStart , builderNewFromString , builderSetApplication - , comboBoxGetActiveId - , comboBoxSetActiveId - , comboBoxTextAppend , containerAdd , cssProviderLoadFromData , cssProviderNew , dialogAddButton , dialogGetContentArea , dialogNew - , dialogResponse , dialogRun - , entryBufferGetText - , entryBufferSetText - , entryGetText - , entryNew - , fontChooserSetFontDesc - , fontChooserGetFontDesc - , getEntryBuffer - , gridAttachNextTo - , gridNew , labelNew , notebookGetNPages , notebookNew , notebookSetShowBorder - , onEntryActivate , onNotebookPageRemoved - , onNotebookPageReordered - , onNotebookSwitchPage , onWidgetDeleteEvent - , scrolledWindowSetPolicy , setWidgetMargin - , spinButtonGetValueAsInt - , spinButtonSetAdjustment - , spinButtonSetValue , styleContextAddProviderForScreen - , toggleButtonGetActive - , toggleButtonSetActive , widgetDestroy , widgetGrabFocus , widgetSetCanFocus - , widgetSetVisible , widgetShow , widgetShowAll , windowPresent - , windowSetDefaultIconFromFile + , windowSetDefaultIcon , windowSetTitle , windowSetTransientFor ) import qualified GI.Gtk as Gtk -import GI.Pango - ( FontDescription - , pattern SCALE - , fontDescriptionGetFamily - , fontDescriptionGetSize - , fontDescriptionGetSizeIsAbsolute - , fontDescriptionNew - , fontDescriptionSetFamily - , fontDescriptionSetSize - , fontDescriptionSetAbsoluteSize - ) -import GI.Vte - ( CursorBlinkMode(..) - , catchRegexError - , regexNewForSearch - , terminalCopyClipboard - , terminalPasteClipboard - , terminalSearchFindNext - , terminalSearchFindPrevious - , terminalSearchSetRegex - , terminalSearchSetWrapAround - , terminalSetBoldIsBright - , terminalSetCursorBlinkMode - , terminalSetFont - , terminalSetScrollbackLines - , terminalSetWordCharExceptions - , terminalSetAllowBold - ) -import System.Environment (getExecutablePath) -import System.FilePath (takeFileName) - -import Paths_termonad (getDataFileName) -import Termonad.Gtk (appNew, objFromBuildUnsafe, terminalSetEnableSixelIfExists) +import Termonad.Gtk (appNew, imgToPixbuf, objFromBuildUnsafe) import Termonad.Keys (handleKeyPress) import Termonad.Lenses - ( lensBoldIsBright - , lensEnableSixel - , lensAllowBold - , lensConfirmExit - , lensCursorBlinkMode - , lensFontConfig + ( lensConfirmExit , lensOptions , lensShowMenu - , lensShowScrollbar - , lensShowTabBar - , lensScrollbackLen - , lensTMNotebook - , lensTMNotebookTabTermContainer - , lensTMNotebookTabs - , lensTMNotebookTabTerm , lensTMStateApp - , lensTMStateAppWin , lensTMStateConfig - , lensTMStateFontDesc - , lensTMStateNotebook , lensTerm - , lensWordCharExceptions ) -import Termonad.PreferencesFile (saveToPreferencesFile) -import Termonad.Term - ( createTerm - , relabelTabs - , termNextPage - , termPrevPage - , termExitFocused - , setShowTabs - , showScrollbarToPolicy - ) +import Termonad.Preferences (showPreferencesDialog) +import Termonad.Term (createTerm, setShowTabs) import Termonad.Types - ( ConfigOptions(..) - , FontConfig(..) - , FontSize(FontSizePoints, FontSizeUnits) - , ShowScrollbar(..) - , ShowTabBar(..) - , TMConfig - , TMNotebookTab + ( TMConfig , TMState - , TMState'(TMState) - , getFocusedTermFromState + , TMState' + , TMWindowId + , createFontDescFromConfig , modFontSize , newEmptyTMState - , tmNotebookTabTermContainer - , tmNotebookTabs - , tmStateApp - , tmStateNotebook ) -import Termonad.XML (interfaceText, menuText, preferencesText) +import Termonad.XML (interfaceText, menuText) +import Termonad.Window (showAboutDialog, modifyFontSizeForAllTerms, setupWindowCallbacks) setupScreenStyle :: IO () setupScreenStyle = do @@ -219,95 +122,13 @@ , " background-color: transparent;" , "}" ] - let styleData = encodeUtf8 (unlines textLines :: Text) + let styleData = encodeUtf8 (Text.unlines textLines) cssProviderLoadFromData cssProvider styleData styleContextAddProviderForScreen screen cssProvider (fromIntegral STYLE_PROVIDER_PRIORITY_APPLICATION) -createFontDescFromConfig :: TMConfig -> IO FontDescription -createFontDescFromConfig tmConfig = do - let fontConf = tmConfig ^. lensOptions . lensFontConfig - createFontDesc (fontSize fontConf) (fontFamily fontConf) - -createFontDesc :: FontSize -> Text -> IO FontDescription -createFontDesc fontSz fontFam = do - fontDesc <- fontDescriptionNew - fontDescriptionSetFamily fontDesc fontFam - setFontDescSize fontDesc fontSz - pure fontDesc - -setFontDescSize :: FontDescription -> FontSize -> IO () -setFontDescSize fontDesc (FontSizePoints points) = - fontDescriptionSetSize fontDesc $ fromIntegral (points * fromIntegral SCALE) -setFontDescSize fontDesc (FontSizeUnits units) = - fontDescriptionSetAbsoluteSize fontDesc $ units * fromIntegral SCALE - -adjustFontDescSize :: (FontSize -> FontSize) -> FontDescription -> IO () -adjustFontDescSize f fontDesc = do - currFontSz <- fontSizeFromFontDescription fontDesc - let newFontSz = f currFontSz - setFontDescSize fontDesc newFontSz - -modifyFontSizeForAllTerms :: (FontSize -> FontSize) -> TMState -> IO () -modifyFontSizeForAllTerms modFontSizeFunc mvarTMState = do - tmState <- readMVar mvarTMState - let fontDesc = tmState ^. lensTMStateFontDesc - adjustFontDescSize modFontSizeFunc fontDesc - let terms = - tmState ^.. - lensTMStateNotebook . - lensTMNotebookTabs . - traverse . - lensTMNotebookTabTerm . - lensTerm - foldMap (\vteTerm -> terminalSetFont vteTerm (Just fontDesc)) terms - -fontSizeFromFontDescription :: FontDescription -> IO FontSize -fontSizeFromFontDescription fontDesc = do - currSize <- fontDescriptionGetSize fontDesc - currAbsolute <- fontDescriptionGetSizeIsAbsolute fontDesc - return $ if currAbsolute - then FontSizeUnits $ fromIntegral currSize / fromIntegral SCALE - else - let fontRatio :: Double = fromIntegral currSize / fromIntegral SCALE - in FontSizePoints $ round fontRatio - -fontConfigFromFontDescription :: FontDescription -> IO (Maybe FontConfig) -fontConfigFromFontDescription fontDescription = do - fontSize <- fontSizeFromFontDescription fontDescription - maybeFontFamily <- fontDescriptionGetFamily fontDescription - return $ (`FontConfig` fontSize) <$> maybeFontFamily - -compareScrolledWinAndTab :: ScrolledWindow -> TMNotebookTab -> Bool -compareScrolledWinAndTab scrollWin flTab = - let ScrolledWindow managedPtrFLTab = tmNotebookTabTermContainer flTab - foreignPtrFLTab = managedForeignPtr managedPtrFLTab - ScrolledWindow managedPtrScrollWin = scrollWin - foreignPtrScrollWin = managedForeignPtr managedPtrScrollWin - in foreignPtrFLTab == foreignPtrScrollWin - -updateFLTabPos :: TMState -> Int -> Int -> IO () -updateFLTabPos mvarTMState oldPos newPos = - modifyMVar_ mvarTMState $ \tmState -> do - let tabs = tmState ^. lensTMStateNotebook . lensTMNotebookTabs - maybeNewTabs = moveFromToFL oldPos newPos tabs - case maybeNewTabs of - Nothing -> do - putStrLn $ - "in updateFLTabPos, Strange error: couldn't move tabs.\n" <> - "old pos: " <> tshow oldPos <> "\n" <> - "new pos: " <> tshow newPos <> "\n" <> - "tabs: " <> tshow tabs <> "\n" <> - "maybeNewTabs: " <> tshow maybeNewTabs <> "\n" <> - "tmState: " <> tshow tmState - pure tmState - Just newTabs -> - pure $ - tmState & - lensTMStateNotebook . lensTMNotebookTabs .~ newTabs - -- | Try to figure out whether Termonad should exit. This also used to figure -- out if Termonad should close a given terminal. -- @@ -369,23 +190,16 @@ let app = tmState ^. lensTMStateApp applicationQuit app -setupTermonad :: TMConfig -> Application -> ApplicationWindow -> Gtk.Builder -> IO () -setupTermonad tmConfig app win builder = do - termonadIconPath <- getDataFileName "img/termonad-lambda.png" - windowSetDefaultIconFromFile termonadIconPath - - setupScreenStyle - box <- objFromBuildUnsafe builder "content_box" Box - fontDesc <- createFontDescFromConfig tmConfig - note <- notebookNew - widgetSetCanFocus note False - -- If this is not set to False, then there will be a one pixel white border - -- shown around the notebook. - notebookSetShowBorder note False - boxPackStart box note True True 0 - - mvarTMState <- newEmptyTMState tmConfig app win note fontDesc - terminal <- createTerm handleKeyPress mvarTMState +setupAppCallbacks :: TMState -> TMConfig -> Application -> ApplicationWindow -> Notebook -> TMWindowId -> IO () +setupAppCallbacks mvarTMState tmConfig app win note tmWinId = do + newWindowAction <- simpleActionNew "newwin" Nothing + void $ onSimpleActionActivate newWindowAction $ \_ -> + pure () + -- void $ createTerm handleKeyPress mvarTMState tmWinId + actionMapAddAction app newWindowAction + -- TODO: Uncomment this when adding the actual functionality + -- for creating new windows. + -- applicationSetAccelsForAction app "app.newwin" ["N"] void $ onNotebookPageRemoved note $ \_ _ -> do pages <- notebookGetNPages note @@ -393,65 +207,6 @@ then forceQuit mvarTMState else setShowTabs tmConfig note - void $ onNotebookSwitchPage note $ \_ pageNum -> do - modifyMVar_ mvarTMState $ \tmState -> do - let notebook = tmStateNotebook tmState - tabs = tmNotebookTabs notebook - maybeNewTabs = updateFocusFL (fromIntegral pageNum) tabs - case maybeNewTabs of - Nothing -> pure tmState - Just (tab, newTabs) -> do - widgetGrabFocus $ tab ^. lensTMNotebookTabTerm . lensTerm - pure $ - tmState & - lensTMStateNotebook . lensTMNotebookTabs .~ newTabs - - void $ onNotebookPageReordered note $ \childWidg pageNum -> do - maybeScrollWin <- castTo ScrolledWindow childWidg - case maybeScrollWin of - Nothing -> - fail $ - "In setupTermonad, in callback for onNotebookPageReordered, " <> - "child widget is not a ScrolledWindow.\n" <> - "Don't know how to continue.\n" - Just scrollWin -> do - TMState{tmStateNotebook} <- readMVar mvarTMState - let fl = tmStateNotebook ^. lensTMNotebookTabs - let maybeOldPosition = - findIndexR (compareScrolledWinAndTab scrollWin) (focusList fl) - case maybeOldPosition of - Nothing -> - fail $ - "In setupTermonad, in callback for onNotebookPageReordered, " <> - "the ScrolledWindow is not already in the FocusList.\n" <> - "Don't know how to continue.\n" - Just oldPos -> do - updateFLTabPos mvarTMState oldPos (fromIntegral pageNum) - relabelTabs mvarTMState - - newTabAction <- simpleActionNew "newtab" Nothing - void $ onSimpleActionActivate newTabAction $ \_ -> void $ createTerm handleKeyPress mvarTMState - actionMapAddAction app newTabAction - applicationSetAccelsForAction app "app.newtab" ["T"] - - nextPageAction <- simpleActionNew "nextpage" Nothing - void $ onSimpleActionActivate nextPageAction $ \_ -> - termNextPage mvarTMState - actionMapAddAction app nextPageAction - applicationSetAccelsForAction app "app.nextpage" ["Page_Down"] - - prevPageAction <- simpleActionNew "prevpage" Nothing - void $ onSimpleActionActivate prevPageAction $ \_ -> - termPrevPage mvarTMState - actionMapAddAction app prevPageAction - applicationSetAccelsForAction app "app.prevpage" ["Page_Up"] - - closeTabAction <- simpleActionNew "closetab" Nothing - void $ onSimpleActionActivate closeTabAction $ \_ -> - termExitFocused mvarTMState - actionMapAddAction app closeTabAction - applicationSetAccelsForAction app "app.closetab" ["W"] - quitAction <- simpleActionNew "quit" Nothing void $ onSimpleActionActivate quitAction $ \_ -> do shouldExit <- askShouldExit mvarTMState @@ -459,63 +214,26 @@ actionMapAddAction app quitAction applicationSetAccelsForAction app "app.quit" ["Q"] - copyAction <- simpleActionNew "copy" Nothing - void $ onSimpleActionActivate copyAction $ \_ -> do - maybeTerm <- getFocusedTermFromState mvarTMState - maybe (pure ()) terminalCopyClipboard maybeTerm - actionMapAddAction app copyAction - applicationSetAccelsForAction app "app.copy" ["C"] - - pasteAction <- simpleActionNew "paste" Nothing - void $ onSimpleActionActivate pasteAction $ \_ -> do - maybeTerm <- getFocusedTermFromState mvarTMState - maybe (pure ()) terminalPasteClipboard maybeTerm - actionMapAddAction app pasteAction - applicationSetAccelsForAction app "app.paste" ["V"] - preferencesAction <- simpleActionNew "preferences" Nothing void $ onSimpleActionActivate preferencesAction (const $ showPreferencesDialog mvarTMState) actionMapAddAction app preferencesAction enlargeFontAction <- simpleActionNew "enlargefont" Nothing void $ onSimpleActionActivate enlargeFontAction $ \_ -> - modifyFontSizeForAllTerms (modFontSize 1) mvarTMState + modifyFontSizeForAllTerms (modFontSize 1) mvarTMState tmWinId actionMapAddAction app enlargeFontAction applicationSetAccelsForAction app "app.enlargefont" ["plus"] reduceFontAction <- simpleActionNew "reducefont" Nothing void $ onSimpleActionActivate reduceFontAction $ \_ -> - modifyFontSizeForAllTerms (modFontSize (-1)) mvarTMState + modifyFontSizeForAllTerms (modFontSize (-1)) mvarTMState tmWinId actionMapAddAction app reduceFontAction applicationSetAccelsForAction app "app.reducefont" ["minus"] - findAction <- simpleActionNew "find" Nothing - void $ onSimpleActionActivate findAction $ \_ -> doFind mvarTMState - actionMapAddAction app findAction - applicationSetAccelsForAction app "app.find" ["F"] - - findAboveAction <- simpleActionNew "findabove" Nothing - void $ onSimpleActionActivate findAboveAction $ \_ -> findAbove mvarTMState - actionMapAddAction app findAboveAction - applicationSetAccelsForAction app "app.findabove" ["P"] - - findBelowAction <- simpleActionNew "findbelow" Nothing - void $ onSimpleActionActivate findBelowAction $ \_ -> findBelow mvarTMState - actionMapAddAction app findBelowAction - applicationSetAccelsForAction app "app.findbelow" ["I"] - aboutAction <- simpleActionNew "about" Nothing - void $ onSimpleActionActivate aboutAction $ \_ -> showAboutDialog app + void $ onSimpleActionActivate aboutAction $ \_ -> showAboutDialog win actionMapAddAction app aboutAction - menuBuilder <- builderNewFromString menuText $ fromIntegral (length menuText) - menuModel <- objFromBuildUnsafe menuBuilder "menubar" MenuModel - applicationSetMenubar app (Just menuModel) - let showMenu = tmConfig ^. lensOptions . lensShowMenu - applicationWindowSetShowMenubar win showMenu - - windowSetTitle win "Termonad" - -- This event will happen if the user requests that the top-level Termonad -- window be closed through their window manager. It will also happen -- normally when the user tries to close Termonad through normal methods, @@ -531,349 +249,57 @@ ResponseTypeYes -> False _ -> True +setupTermonad :: TMConfig -> Application -> ApplicationWindow -> Gtk.Builder -> IO () +setupTermonad tmConfig app win builder = do + setupScreenStyle + box <- objFromBuildUnsafe builder "content_box" Box + fontDesc <- createFontDescFromConfig tmConfig + note <- notebookNew + widgetSetCanFocus note False + -- If this is not set to False, then there will be a one pixel white border + -- shown around the notebook. + notebookSetShowBorder note False + boxPackStart box note True True 0 + + (mvarTMState, tmWinId) <- newEmptyTMState tmConfig app win note fontDesc + terminal <- createTerm handleKeyPress mvarTMState tmWinId + + setupAppCallbacks mvarTMState tmConfig app win note tmWinId + setupWindowCallbacks mvarTMState app win note tmWinId + + menuBuilder <- builderNewFromString menuText $ fromIntegral (Text.length menuText) + menuModel <- objFromBuildUnsafe menuBuilder "menubar" MenuModel + applicationSetMenubar app (Just menuModel) + let showMenu = tmConfig ^. lensOptions . lensShowMenu + applicationWindowSetShowMenubar win showMenu + + windowSetTitle win "Termonad" + widgetShowAll win widgetGrabFocus $ terminal ^. lensTerm appActivate :: TMConfig -> Application -> IO () appActivate tmConfig app = do + let img = $(embedFile "img/termonad-lambda.png") + iconPixbuf <- imgToPixbuf img + windowSetDefaultIcon iconPixbuf uiBuilder <- - builderNewFromString interfaceText $ fromIntegral (length interfaceText) + builderNewFromString interfaceText $ fromIntegral (Text.length interfaceText) builderSetApplication uiBuilder app appWin <- objFromBuildUnsafe uiBuilder "appWin" ApplicationWindow applicationAddWindow app appWin setupTermonad tmConfig app appWin uiBuilder windowPresent appWin -showAboutDialog :: Application -> IO () -showAboutDialog app = do - win <- applicationGetActiveWindow app - aboutDialog <- aboutDialogNew - windowSetTransientFor aboutDialog win - void $ dialogRun aboutDialog - widgetDestroy aboutDialog - -showFindDialog :: Application -> IO (Maybe Text) -showFindDialog app = do - win <- applicationGetActiveWindow app - dialog <- dialogNew - box <- dialogGetContentArea dialog - grid <- gridNew - - searchForLabel <- labelNew (Just "Search for regex:") - containerAdd grid searchForLabel - widgetShow searchForLabel - setWidgetMargin searchForLabel 10 - - searchEntry <- entryNew - gridAttachNextTo grid searchEntry (Just searchForLabel) PositionTypeRight 1 1 - widgetShow searchEntry - setWidgetMargin searchEntry 10 - -- setWidgetMarginBottom searchEntry 20 - void $ - onEntryActivate searchEntry $ - dialogResponse dialog (fromIntegral (fromEnum ResponseTypeYes)) - - void $ - dialogAddButton - dialog - "Close" - (fromIntegral (fromEnum ResponseTypeNo)) - void $ - dialogAddButton - dialog - "Find" - (fromIntegral (fromEnum ResponseTypeYes)) - - containerAdd box grid - widgetShow grid - windowSetTransientFor dialog win - res <- dialogRun dialog - - searchString <- entryGetText searchEntry - let maybeSearchString = - case toEnum (fromIntegral res) of - ResponseTypeYes -> Just searchString - _ -> Nothing - - widgetDestroy dialog - - pure maybeSearchString - -doFind :: TMState -> IO () -doFind mvarTMState = do - tmState <- readMVar mvarTMState - let app = tmStateApp tmState - maybeSearchString <- showFindDialog app - -- putStrLn $ "trying to find: " <> tshow maybeSearchString - maybeTerminal <- getFocusedTermFromState mvarTMState - case (maybeSearchString, maybeTerminal) of - (Just searchString, Just terminal) -> do - -- TODO: Figure out how to import the correct pcre flags. - -- - -- If you don't pass the pcre2Multiline flag, VTE gives - -- the following warning: - -- - -- (termonad-linux-x86_64:18792): Vte-WARNING **: - -- 21:56:31.193: (vtegtk.cc:2269):void - -- vte_terminal_search_set_regex(VteTerminal*, - -- VteRegex*, guint32): runtime check failed: - -- (regex == nullptr || - -- _vte_regex_get_compile_flags(regex) & PCRE2_MULTILINE) - -- - -- However, if you do add the pcre2Multiline flag, - -- the terminalSearchSetRegex appears to just completely - -- not work. - let pcreFlags = 0 - let newRegex = - regexNewForSearch - searchString - (fromIntegral $ length searchString) - pcreFlags - eitherRegex <- - catchRegexError - (fmap Right newRegex) - (\_ errMsg -> pure (Left errMsg)) - case eitherRegex of - Left errMsg -> do - let msg = "error when creating regex: " <> errMsg - hPutStrLn stderr msg - Right regex -> do - terminalSearchSetRegex terminal (Just regex) pcreFlags - terminalSearchSetWrapAround terminal True - _matchFound <- terminalSearchFindPrevious terminal - -- TODO: Setup an actual logging framework to show these - -- kinds of log messages. Also make a similar change in - -- findAbove and findBelow. - -- putStrLn $ "was match found: " <> tshow matchFound - pure () - _ -> pure () - -findAbove :: TMState -> IO () -findAbove mvarTMState = do - maybeTerminal <- getFocusedTermFromState mvarTMState - case maybeTerminal of - Nothing -> pure () - Just terminal -> do - _matchFound <- terminalSearchFindPrevious terminal - -- putStrLn $ "was match found: " <> tshow matchFound - pure () - -findBelow :: TMState -> IO () -findBelow mvarTMState = do - maybeTerminal <- getFocusedTermFromState mvarTMState - case maybeTerminal of - Nothing -> pure () - Just terminal -> do - _matchFound <- terminalSearchFindNext terminal - -- putStrLn $ "was match found: " <> tshow matchFound - pure () - -setShowMenuBar :: Application -> Bool -> IO () -setShowMenuBar app visible = do - void $ runMaybeT $ do - win <- MaybeT $ applicationGetActiveWindow app - appWin <- MaybeT $ castTo ApplicationWindow win - lift $ applicationWindowSetShowMenubar appWin visible - --- | Fill a combo box with ids and labels --- --- The ids are stored in the combobox as 'Text', so their type should be an --- instance of the 'Show' type class. -comboBoxFill :: forall a. Show a => ComboBoxText -> [(a, Text)] -> IO () -comboBoxFill comboBox = mapM_ go - where - go :: (a, Text) -> IO () - go (value, textId) = - comboBoxTextAppend comboBox (Just $ tshow value) textId - --- | Set the current active item in a combobox given an input id. -comboBoxSetActive :: Show a => ComboBoxText -> a -> IO () -comboBoxSetActive cb item = void $ comboBoxSetActiveId cb (Just $ tshow item) - --- | Get the current active item in a combobox --- --- The list of values to be searched in the combobox must be given as a --- parameter. These values are converted to Text then compared to the current --- id. -comboBoxGetActive - :: forall a. (Show a, Enum a) => ComboBoxText -> [a] -> IO (Maybe a) -comboBoxGetActive cb values = findEnumFromMaybeId <$> comboBoxGetActiveId cb - where - findEnumFromMaybeId :: Maybe Text -> Maybe a - findEnumFromMaybeId maybeId = maybeId >>= findEnumFromId - - findEnumFromId :: Text -> Maybe a - findEnumFromId label = find (\x -> tshow x == label) values - -applyNewPreferences :: TMState -> IO () -applyNewPreferences mvarTMState = do - tmState <- readMVar mvarTMState - let appWin = tmState ^. lensTMStateAppWin - config = tmState ^. lensTMStateConfig - notebook = tmState ^. lensTMStateNotebook . lensTMNotebook - tabFocusList = tmState ^. lensTMStateNotebook . lensTMNotebookTabs - showMenu = config ^. lensOptions . lensShowMenu - applicationWindowSetShowMenubar appWin showMenu - setShowTabs config notebook - -- Sets the remaining preferences to each tab - foldMap (applyNewPreferencesToTab mvarTMState) tabFocusList - -applyNewPreferencesToTab :: TMState -> TMNotebookTab -> IO () -applyNewPreferencesToTab mvarTMState tab = do - tmState <- readMVar mvarTMState - let fontDesc = tmState ^. lensTMStateFontDesc - term = tab ^. lensTMNotebookTabTerm . lensTerm - scrolledWin = tab ^. lensTMNotebookTabTermContainer - options = tmState ^. lensTMStateConfig . lensOptions - terminalSetFont term (Just fontDesc) - terminalSetCursorBlinkMode term (cursorBlinkMode options) - terminalSetWordCharExceptions term (wordCharExceptions options) - terminalSetScrollbackLines term (fromIntegral (scrollbackLen options)) - terminalSetBoldIsBright term (boldIsBright options) - terminalSetEnableSixelIfExists term (enableSixel options) - terminalSetAllowBold term (allowBold options) - - let vScrollbarPolicy = showScrollbarToPolicy (options ^. lensShowScrollbar) - scrolledWindowSetPolicy scrolledWin PolicyTypeAutomatic vScrollbarPolicy - --- | Show the preferences dialog. --- --- When the user clicks on the Ok button, it copies the new settings to TMState. --- Then apply them to the current terminals. -showPreferencesDialog :: TMState -> IO () -showPreferencesDialog mvarTMState = do - -- Get app out of mvar - tmState <- readMVar mvarTMState - let app = tmState ^. lensTMStateApp - - -- Create the preference dialog and get some widgets - preferencesBuilder <- - builderNewFromString preferencesText $ fromIntegral (length preferencesText) - preferencesDialog <- - objFromBuildUnsafe preferencesBuilder "preferences" Dialog - confirmExitCheckButton <- - objFromBuildUnsafe preferencesBuilder "confirmExit" CheckButton - showMenuCheckButton <- - objFromBuildUnsafe preferencesBuilder "showMenu" CheckButton - boldIsBrightCheckButton <- - objFromBuildUnsafe preferencesBuilder "boldIsBright" CheckButton - enableSixelCheckButton <- - objFromBuildUnsafe preferencesBuilder "enableSixel" CheckButton - allowBoldCheckButton <- - objFromBuildUnsafe preferencesBuilder "allowBold" CheckButton - wordCharExceptionsEntryBuffer <- - objFromBuildUnsafe preferencesBuilder "wordCharExceptions" Entry >>= - getEntryBuffer - fontButton <- objFromBuildUnsafe preferencesBuilder "font" FontButton - showScrollbarComboBoxText <- - objFromBuildUnsafe preferencesBuilder "showScrollbar" ComboBoxText - comboBoxFill - showScrollbarComboBoxText - [ (ShowScrollbarNever, "Never") - , (ShowScrollbarAlways, "Always") - , (ShowScrollbarIfNeeded, "If needed") - ] - showTabBarComboBoxText <- - objFromBuildUnsafe preferencesBuilder "showTabBar" ComboBoxText - comboBoxFill - showTabBarComboBoxText - [ (ShowTabBarNever, "Never") - , (ShowTabBarAlways, "Always") - , (ShowTabBarIfNeeded, "If needed") - ] - cursorBlinkModeComboBoxText <- - objFromBuildUnsafe preferencesBuilder "cursorBlinkMode" ComboBoxText - comboBoxFill - cursorBlinkModeComboBoxText - [ (CursorBlinkModeSystem, "System") - , (CursorBlinkModeOn, "On") - , (CursorBlinkModeOff, "Off") - ] - scrollbackLenSpinButton <- - objFromBuildUnsafe preferencesBuilder "scrollbackLen" SpinButton - adjustmentNew 0 0 (fromIntegral (maxBound :: Int)) 1 10 0 >>= - spinButtonSetAdjustment scrollbackLenSpinButton - warningLabel <- objFromBuildUnsafe preferencesBuilder "warning" Label - - -- We show the warning label only if the user has launched termonad with a - -- termonad.hs file - executablePath <- getExecutablePath - let hasTermonadHs = takeFileName executablePath == "termonad-linux-x86_64" - widgetSetVisible warningLabel hasTermonadHs - - -- Make the dialog modal - maybeWin <- applicationGetActiveWindow app - windowSetTransientFor preferencesDialog maybeWin - - -- Init with current state - fontChooserSetFontDesc fontButton (tmState ^. lensTMStateFontDesc) - let options = tmState ^. lensTMStateConfig . lensOptions - comboBoxSetActive showScrollbarComboBoxText $ showScrollbar options - comboBoxSetActive showTabBarComboBoxText $ showTabBar options - comboBoxSetActive cursorBlinkModeComboBoxText $ cursorBlinkMode options - spinButtonSetValue scrollbackLenSpinButton (fromIntegral $ scrollbackLen options) - toggleButtonSetActive confirmExitCheckButton $ confirmExit options - toggleButtonSetActive showMenuCheckButton $ showMenu options - toggleButtonSetActive boldIsBrightCheckButton $ boldIsBright options - toggleButtonSetActive enableSixelCheckButton $ enableSixel options - toggleButtonSetActive allowBoldCheckButton $ allowBold options - entryBufferSetText wordCharExceptionsEntryBuffer (wordCharExceptions options) (-1) - - -- Run dialog then close - res <- dialogRun preferencesDialog - - -- When closing the dialog get the new settings - when (toEnum (fromIntegral res) == ResponseTypeAccept) $ do - maybeFontDesc <- fontChooserGetFontDesc fontButton - maybeFontConfig <- - join <$> mapM fontConfigFromFontDescription maybeFontDesc - maybeShowScrollbar <- - comboBoxGetActive showScrollbarComboBoxText [ShowScrollbarNever ..] - maybeShowTabBar <- - comboBoxGetActive showTabBarComboBoxText [ShowTabBarNever ..] - maybeCursorBlinkMode <- - comboBoxGetActive cursorBlinkModeComboBoxText [CursorBlinkModeSystem ..] - scrollbackLenVal <- - fromIntegral <$> spinButtonGetValueAsInt scrollbackLenSpinButton - confirmExitVal <- toggleButtonGetActive confirmExitCheckButton - showMenuVal <- toggleButtonGetActive showMenuCheckButton - boldIsBrightVal <- toggleButtonGetActive boldIsBrightCheckButton - enableSixelVal <- toggleButtonGetActive enableSixelCheckButton - allowBoldVal <- toggleButtonGetActive allowBoldCheckButton - wordCharExceptionsVal <- entryBufferGetText wordCharExceptionsEntryBuffer - - -- Apply the changes to mvarTMState - modifyMVar_ mvarTMState $ pure - . over lensTMStateFontDesc (`fromMaybe` maybeFontDesc) - . over (lensTMStateConfig . lensOptions) - ( set lensConfirmExit confirmExitVal - . set lensShowMenu showMenuVal - . set lensBoldIsBright boldIsBrightVal - . set lensEnableSixel enableSixelVal - . set lensAllowBold allowBoldVal - . set lensWordCharExceptions wordCharExceptionsVal - . over lensFontConfig (`fromMaybe` maybeFontConfig) - . set lensScrollbackLen scrollbackLenVal - . over lensShowScrollbar (`fromMaybe` maybeShowScrollbar) - . over lensShowTabBar (`fromMaybe` maybeShowTabBar) - . over lensCursorBlinkMode (`fromMaybe` maybeCursorBlinkMode) - ) - - -- Save the changes to the preferences files - withMVar mvarTMState $ saveToPreferencesFile . view lensTMStateConfig - - -- Update the app with new settings - applyNewPreferences mvarTMState - - widgetDestroy preferencesDialog - appStartup :: Application -> IO () appStartup _app = pure () -- | Run Termonad with the given 'TMConfig'. -- --- Do not perform any of the recompilation operations that the 'defaultMain' +-- Do not perform any of the recompilation operations that the 'Termonad.Startup.defaultMain' -- function does. +-- +-- This function __does not__ parse command line arguments. start :: TMConfig -> IO () start tmConfig = do -- app <- appNew (Just "haskell.termonad") [ApplicationFlagsFlagsNone] @@ -882,81 +308,3 @@ void $ onApplicationStartup app (appStartup app) void $ onApplicationActivate app (appActivate tmConfig app) void $ applicationRun app Nothing - --- | Run Termonad with the given 'TMConfig'. --- --- This function will check if there is a @~\/.config\/termonad\/termonad.hs@ file --- and a @~\/.cache\/termonad\/termonad-linux-x86_64@ binary. Termonad will --- perform different actions based on whether or not these two files exist. --- --- Here are the four different possible actions based on the existence of these --- two files. --- --- - @~\/.config\/termonad\/termonad.hs@ exists, @~\/.cache\/termonad\/termonad-linux-x86_64@ exists --- --- The timestamps of these two files are checked. If the --- @~\/.config\/termonad\/termonad.hs@ file has been modified after the --- @~\/.cache\/termonad\/termonad-linux-x86_64@ binary, then Termonad will use --- GHC to recompile the @~\/.config\/termonad\/termonad.hs@ file, producing a --- new binary at @~\/.cache\/termonad\/termonad-linux-x86_64@. This new binary --- will be re-executed. The 'TMConfig' passed to this 'defaultMain' will be --- effectively thrown away. --- --- If GHC fails to recompile the @~\/.config\/termonad\/termonad.hs@ file, then --- Termonad will just execute 'start' with the 'TMConfig' passed in. --- --- If the @~\/.cache\/termonad\/termonad-linux-x86_64@ binary has been modified --- after the @~\/.config\/termonad\/termonad.hs@ file, then Termonad will --- re-exec the @~\/.cache\/termonad\/termonad-linux-x86_64@ binary. The --- 'TMConfig' passed to this 'defaultMain' will be effectively thrown away. --- --- - @~\/.config\/termonad\/termonad.hs@ exists, @~\/.cache\/termonad\/termonad-linux-x86_64@ does not exist --- --- Termonad will use GHC to recompile the @~\/.config\/termonad\/termonad.hs@ --- file, producing a new binary at @~\/.cache\/termonad\/termonad-linux-x86_64@. --- This new binary will be re-executed. The 'TMConfig' passed to this --- 'defaultMain' will be effectively thrown away. --- --- If GHC fails to recompile the @~\/.config\/termonad\/termonad.hs@ file, then --- Termonad will just execute 'start' with the 'TMConfig' passed in. --- --- - @~\/.config\/termonad\/termonad.hs@ does not exist, @~\/.cache\/termonad\/termonad-linux-x86_64@ exists --- --- Termonad will ignore the @~\/.cache\/termonad\/termonad-linux-x86_64@ binary --- and just run 'start' with the 'TMConfig' passed to this function. --- --- - @~\/.config\/termonad\/termonad.hs@ does not exist, @~\/.cache\/termonad\/termonad-linux-x86_64@ does not exist --- --- Termonad will run 'start' with the 'TMConfig' passed to this function. --- --- Other notes: --- --- 1. That the locations of @~\/.config\/termonad\/termonad.hs@ and --- @~\/.cache\/termonad\/termonad-linux-x86_64@ may differ depending on your --- system. --- --- 2. In your own @~\/.config\/termonad\/termonad.hs@ file, you can use either --- 'defaultMain' or 'start'. As long as you always execute the system-wide --- @termonad@ binary (instead of the binary produced as --- @~\/.cache\/termonad\/termonad-linux-x86_64@), the effect should be the same. -defaultMain :: TMConfig -> IO () -defaultMain tmConfig = do - let params = - defaultParams - { projectName = "termonad" - , showError = \(cfg, oldErrs) newErr -> (cfg, oldErrs <> "\n" <> newErr) - , realMain = \(cfg, errs) -> putStrLn (pack errs) *> start cfg - } - eitherRes <- tryIOError $ wrapMain params (tmConfig, "") - case eitherRes of - Left ioErr - | ioeGetErrorType ioErr == doesNotExistErrorType && ioeGetFileName ioErr == Just "ghc" -> do - putStrLn $ - "Could not find ghc on your PATH. Ignoring your termonad.hs " <> - "configuration file and running termonad with default settings." - start tmConfig - | otherwise -> do - putStrLn "IO error occurred when trying to run termonad:" - print ioErr - putStrLn "Don't know how to recover. Exiting." - Right _ -> pure () diff --git a/src/Termonad/Cli.hs b/src/Termonad/Cli.hs new file mode 100644 --- /dev/null +++ b/src/Termonad/Cli.hs @@ -0,0 +1,434 @@ +-- | Module : Termonad.Cli +-- Description : Termonad CLI argument parsing module. +-- Copyright : (c) Dennis Gosnell, 2023 +-- License : BSD3 +-- Stability : experimental +-- Portability : POSIX +-- +-- This module exposes Termonad's CLI argument parsing functionality. +-- +-- The main function for parsing CLI arguments is 'parseCliArgs'. The function +-- that knows how to combine CLI arguments with normal 'ConfigOptions' is +-- 'applyCliArgs'. + +module Termonad.Cli where + +import Termonad.Prelude + +import Control.Applicative ((<|>), (<**>)) +import Data.Text (pack) +import GI.Vte (CursorBlinkMode) +import Options.Applicative (fullDesc, info, helper, progDesc, ParserInfo, execParser, Parser, Mod, OptionFields, option, str, value, short, long, metavar, help, ReadM, maybeReader, auto, flag') +import Termonad.Types (ConfigOptions (..), Option (Set, Unset), ShowScrollbar, FontSize (..), ShowTabBar, showScrollbarFromString, showTabBarFromString, cursorBlinkModeFromString, FontConfig (..)) + + +-- | A data type that contains arguments from the command line. +data CliArgs = CliArgs + { cliConfigOptions :: CliConfigOptions + , extraCliArgs :: ExtraCliArgs + } deriving (Eq, Show) + +-- | The default 'CliArgs'. This corresponds to the value 'CliArgs' will +-- become when no CLI arguments have been passed. +-- +-- >>> :{ +-- let defCliArgs = +-- CliArgs +-- { cliConfigOptions = defaultCliConfigOptions +-- , extraCliArgs = defaultExtraCliArgs +-- } +-- in defaultCliArgs == defCliArgs +-- :} +-- True +defaultCliArgs :: CliArgs +defaultCliArgs = + CliArgs + { cliConfigOptions = defaultCliConfigOptions + , extraCliArgs = defaultExtraCliArgs + } + +-- | CLI arguments that correspond to fields in 'ConfigOptions'. +-- +-- See 'ConfigOptions' for what each of these options mean. +data CliConfigOptions = CliConfigOptions + { cliConfFontFamily :: !(Option Text) + , cliConfFontSize :: !(Option FontSize) + , cliConfShowScrollbar :: !(Option ShowScrollbar) + , cliConfScrollbackLen :: !(Option Integer) + , cliConfConfirmExit :: !(Option Bool) + , cliConfWordCharExceptions :: !(Option Text) + , cliConfShowMenu :: !(Option Bool) + , cliConfShowTabBar :: !(Option ShowTabBar) + , cliConfCursorBlinkMode :: !(Option CursorBlinkMode) + , cliConfBoldIsBright :: !(Option Bool) + , cliConfEnableSixel :: !(Option Bool) + , cliConfAllowBold :: !(Option Bool) + } deriving (Eq, Show) + +-- | The default 'CliConfigOptions'. All 'Option's are 'Unset', which means +-- they won't override options from 'ConfigOptions' in 'applyCliArgs'. +-- +-- >>> :{ +-- let defCliConfOpt = +-- CliConfigOptions +-- { cliConfFontFamily = Unset +-- , cliConfFontSize = Unset +-- , cliConfShowScrollbar = Unset +-- , cliConfScrollbackLen = Unset +-- , cliConfConfirmExit = Unset +-- , cliConfWordCharExceptions = Unset +-- , cliConfShowMenu = Unset +-- , cliConfShowTabBar = Unset +-- , cliConfCursorBlinkMode = Unset +-- , cliConfBoldIsBright = Unset +-- , cliConfEnableSixel = Unset +-- , cliConfAllowBold = Unset +-- } +-- in defaultCliConfigOptions == defCliConfOpt +-- :} +-- True +defaultCliConfigOptions :: CliConfigOptions +defaultCliConfigOptions = + CliConfigOptions + { cliConfFontFamily = Unset + , cliConfFontSize = Unset + , cliConfShowScrollbar = Unset + , cliConfScrollbackLen = Unset + , cliConfConfirmExit = Unset + , cliConfWordCharExceptions = Unset + , cliConfShowMenu = Unset + , cliConfShowTabBar = Unset + , cliConfCursorBlinkMode = Unset + , cliConfBoldIsBright = Unset + , cliConfEnableSixel = Unset + , cliConfAllowBold = Unset + } + +-- | Extra CLI arguments for values that don't make sense in 'ConfigOptions'. +data ExtraCliArgs = ExtraCliArgs + deriving (Eq, Show) + +-- | The default 'ExtraCliArgs'. +-- +-- >>> :{ +-- let defExtraCliArgs = +-- ExtraCliArgs +-- in defaultExtraCliArgs == defExtraCliArgs +-- :} +-- True +defaultExtraCliArgs :: ExtraCliArgs +defaultExtraCliArgs = ExtraCliArgs + +-- | Similar to 'Options.Applicative.strOption', but specifically work on a +-- value that is an 'Option'. +strOption' :: IsString s => Mod OptionFields (Option s) -> Parser (Option s) +strOption' mods = option (fmap Set str) (value Unset <> mods) + +-- | Similar to 'Options.Applicative.option', but specifically work on a +-- value that is an 'Option'. +option' :: ReadM a -> Mod OptionFields (Option a) -> Parser (Option a) +option' readM mods = option (fmap Set readM) (value Unset <> mods) + +-- | Similar to 'Options.Applicative.maybeReader', but work on 'Text' instead +-- of 'String'. +maybeTextReader :: (Text -> Maybe a) -> ReadM a +maybeTextReader f = maybeReader (f . pack) + +-- | Helper for making a 'flag' CLI argument that optionally takes a @no-@ prefix. +-- +-- Example: +-- +-- > 'optionFlag' 'True' 'False' 'f' 'n' "foo" "Does foo" "Does not do foo" :: Parser (Option Bool) +-- +-- This creates a 'Parser' that accepts both a @--foo@ and a @--no-foo@ flag. +-- Passing @--foo@ returns @'Set' 'True'@, while passing @--no-foo@ returns +-- @'Set' 'False'@. Passing neither @--foo@ nor @--no-foo@ returns 'Unset'. +-- +-- TODO: This doesn't quite work. If the user passes both @--foo@ and +-- @--no-foo@ flags, this should ideally take the value of the last flag +-- passed. However, it appears that if you pass both flags, the second +-- flag is just not recognized and optparse-applicative raises an error. +optionFlag + :: a -- ^ Value when specified /without/ @no-@ prefix. + -> a -- ^ Value when specified /with/ @no-@ prefix. + -> Char -- ^ Short flag for /without/ @no-@ prefix. + -> Char -- ^ Short flag for /with/ @no-@ prefix. + -> String -- ^ Long flag. + -> String -- ^ Help text for /without/ @no-@ prefix option. + -> String -- ^ Help text for /with/ @no-@ prefix option. + -> Parser (Option a) +optionFlag valNormal valNo shortNormal shortNo longFlag helpNormal helpNo = + flagNormal <|> flagNo <|> pure Unset + where + flagNormal = + flag' (Set valNormal) (short shortNormal <> long longFlag <> help helpNormal) + flagNo = + flag' (Set valNo) (short shortNo <> long ("no-" <> longFlag) <> help helpNo) + +cliConfigOptionsParser :: Parser CliConfigOptions +cliConfigOptionsParser = + CliConfigOptions + <$> fontFamilyParser + <*> fontSizeParser + <*> showScrollbarParser + <*> scrollbackLenParser + <*> confirmExitParser + <*> wordCharExceptionsParser + <*> showMenuParser + <*> showTabBarParser + <*> cursorBlinkModeParser + <*> boldIsBrightParser + <*> enableSixelParser + <*> allowBoldParser + +fontFamilyParser :: Parser (Option Text) +fontFamilyParser = + strOption' + ( short 'f' <> + long "font-family" <> + metavar "FONT_FAMILY" <> + help + "Font family to use. Defaults to \"Monospace\". Examples: \ + \\"DejaVu Sans Mono\", \"Source Code Pro\"" + ) + +fontSizeParser :: Parser (Option FontSize) +fontSizeParser = f <$> pointsParser <*> unitsParser + where + f :: Option Int -> Option Double -> Option FontSize + f optionPoints optionUnits = + case (fmap FontSizePoints optionPoints, fmap FontSizeUnits optionUnits) of + (Unset, units) -> units + (points, _) -> points + + pointsParser :: Parser (Option Int) + pointsParser = + option' + auto + ( short 'p' <> + long "font-size-points" <> + metavar "POINTS" <> + help + "Font size in POINTS. Defaults to \"12\" if not specified. \ + \If you specify both --font-size-points and --font-size-units, \ + \--font-size-points will take priority. --font-size-points \ + \should be similar to font sizes you may be \ + \familiar with from other applications." + ) + + unitsParser :: Parser (Option Double) + unitsParser = + option' + auto + ( short 'u' <> + long "font-size-units" <> + metavar "UNITS" <> + help + "Font size in device units/pixels. Example: \"20.5\", \ + \\"30\". If not specified, the default from \ + \--font-size-points is used." + ) + +showScrollbarParser :: Parser (Option ShowScrollbar) +showScrollbarParser = + option' + (maybeTextReader showScrollbarFromString) + ( short 'l' <> + long "show-scrollbar" <> + metavar "SHOW_SCROLLBAR" <> + help + "Whether or not to show a scrollbar in the terminal. \ + \Defaults to \"if-needed\". Possible values = \"never\": \ + \never show the scrollbar, \"always\": always show the \ + \scrollbar, \"if-needed\": only show the scrollbar if \ + \enough text on the screen" + ) + +scrollbackLenParser :: Parser (Option Integer) +scrollbackLenParser = + option' + auto + ( short 'b' <> + long "scrollback-length" <> + metavar "SCROLLBACK_LENGTH" <> + help + "Number of lines to keep in the scrollback buffer in the \ + \terminal. Defaults to 10000 lines. Examples: \"200\", \ + \\"3000\"" + ) + +confirmExitParser :: Parser (Option Bool) +confirmExitParser = + optionFlag + True + False + 'x' + 'C' + "confirm-exit" + "Ask for confirmation when closing terminals or Termonad itself. \ + \Defaults to asking for confirmation if not specified." + "Do not ask for confirmation when closing terminals or Termonad \ + \itself. Defaults to asking for confirmation if not specified." + +wordCharExceptionsParser :: Parser (Option Text) +wordCharExceptionsParser = + strOption' + ( short 'w' <> + long "word-char-exceptions" <> + metavar "EXCEPTIONS" <> + help + "The characters in this list will be counted as part of a word \ + \when double-clicking to select text in the terminal. Defaults \ + \to \"-#%&+,./=?@\\_~:\"" + ) + +showMenuParser :: Parser (Option Bool) +showMenuParser = + optionFlag + True + False + 'm' + 'u' + "show-menu" + "Show the menu bar. Defaults to showing the menu bar when not \ + \specified." + "Do not show the menu bar. Defaults to showing the menu bar when \ + \not specified." + +showTabBarParser :: Parser (Option ShowTabBar) +showTabBarParser = + option' + (maybeTextReader showTabBarFromString) + ( short 'l' <> + long "show-tab-bar" <> + metavar "SHOW_TAB_BAR" <> + help + "Whether or not to show the tab bar in the terminal. \ + \Defaults to \"if-needed\". Possible values = \"never\": \ + \never show the tab bar, \"always\": always show the \ + \tab bar, \"if-needed\": only show the tab bar if \ + \multiple tabs are open." + ) + +cursorBlinkModeParser :: Parser (Option CursorBlinkMode) +cursorBlinkModeParser = + option' + (maybeTextReader cursorBlinkModeFromString) + ( short 'n' <> + long "cursor-blink" <> + metavar "BLINK_MODE" <> + help + "How to handle cursor blink. Defaults to \"on\". Possible \ + \values = \"system\": follow system settings, \"on\": cursor \ + \blinks, \"off\": no cursor blink." + ) + +boldIsBrightParser :: Parser (Option Bool) +boldIsBrightParser = + optionFlag + True + False + 'd' + 'r' + "bold-is-bright" + "Force bold text to use bright colors. Defaults to not forcing \ + \bold text to use bright colors." + "Do not force bold text to use bright colors. Defaults to not forcing \ + \bold text to use bright colors." + +enableSixelParser :: Parser (Option Bool) +enableSixelParser = + optionFlag + True + False + 's' + 'i' + "sixel" + "Enable SIXEL support. Note that you need to build Termonad with \ + \a VTE with SIXEL support for this to work. Defaults to not \ + \enabling SIXEL." + "Disable SIXEL support. Defaults to disabling SIXEL support." + +allowBoldParser :: Parser (Option Bool) +allowBoldParser = + optionFlag + True + False + 'a' + 'o' + "allow-bold" + "Allow Termonad to show bold text. Defaults to enabled." + "Disable Termonad from showing text as bold. Defaults to \ + \allow showing text as bold." + +extraCliArgsParser :: Parser ExtraCliArgs +extraCliArgsParser = pure ExtraCliArgs + +cliArgsParser :: Parser CliArgs +cliArgsParser = + CliArgs <$> cliConfigOptionsParser <*> extraCliArgsParser + +cliArgsParserInfo :: ParserInfo CliArgs +cliArgsParserInfo = + info + (cliArgsParser <**> helper) + ( fullDesc <> + progDesc "A VTE-based terminal emulator configurable in Haskell" + ) + +-- | Parse and return CliArguments. +parseCliArgs :: IO CliArgs +parseCliArgs = execParser cliArgsParserInfo + +-- | Overwrite the arguments in 'ConfigOptions' that have been 'Set' in +-- 'CliArgs'. +-- +-- >>> import Termonad.Types (defaultConfigOptions) +-- >>> let cliConfOpts = defaultCliConfigOptions { cliConfScrollbackLen = Set 50 } +-- >>> let cliArgs = defaultCliArgs { cliConfigOptions = cliConfOpts } +-- >>> let overwrittenConfOpts = defaultConfigOptions { scrollbackLen = 50 } +-- >>> applyCliArgs cliArgs defaultConfigOptions == overwrittenConfOpts +-- True +applyCliArgs :: CliArgs -> ConfigOptions -> ConfigOptions +applyCliArgs cliArgs confOpts = + let oldFontConf = fontConfig confOpts + newFontConfig = + oldFontConf + { fontFamily = + fromOption + (fontFamily oldFontConf) + (cliConfFontFamily cliConfOpts) + , fontSize = + fromOption + (fontSize oldFontConf) + (cliConfFontSize cliConfOpts) + } + in + confOpts + { fontConfig = newFontConfig + , showScrollbar = fromOpt showScrollbar cliConfShowScrollbar + , scrollbackLen = fromOpt scrollbackLen cliConfScrollbackLen + , confirmExit = fromOpt confirmExit cliConfConfirmExit + , wordCharExceptions = fromOpt wordCharExceptions cliConfWordCharExceptions + , showMenu = fromOpt showMenu cliConfShowMenu + , showTabBar = fromOpt showTabBar cliConfShowTabBar + , cursorBlinkMode = fromOpt cursorBlinkMode cliConfCursorBlinkMode + , boldIsBright = fromOpt boldIsBright cliConfBoldIsBright + , enableSixel = fromOpt enableSixel cliConfEnableSixel + , allowBold = fromOpt allowBold cliConfAllowBold + } + where + fromOpt + :: forall a. (ConfigOptions -> a) -> (CliConfigOptions -> Option a) -> a + fromOpt getConfVal getCliVal = + fromOption + (getConfVal confOpts) + (getCliVal cliConfOpts) + + fromOption :: forall b. b -> Option b -> b + fromOption defVal = \case + Set a -> a + Unset -> defVal + + cliConfOpts :: CliConfigOptions + cliConfOpts = cliConfigOptions cliArgs diff --git a/src/Termonad/Config.hs b/src/Termonad/Config.hs --- a/src/Termonad/Config.hs +++ b/src/Termonad/Config.hs @@ -21,10 +21,12 @@ -- -- main :: IO () -- main = 'start' $ 'defaultTMConfig' --- { 'showScrollbar' = 'ShowScrollbarNever' --- , 'confirmExit' = False --- , 'showMenu' = False --- , 'cursorBlinkMode' = 'CursorBlinkModeOff' +-- { 'options' = 'defaultConfigOptions' +-- { 'showScrollbar' = 'ShowScrollbarNever' +-- , 'confirmExit' = False +-- , 'showMenu' = False +-- , 'cursorBlinkMode' = 'CursorBlinkModeOff' +-- } -- } -- @ -- @@ -59,5 +61,5 @@ import GI.Vte (CursorBlinkMode(..)) -import Termonad.PreferencesFile (tmConfigFromPreferencesFile) +import Termonad.Preferences (tmConfigFromPreferencesFile) import Termonad.Types diff --git a/src/Termonad/Config/Colour.hs b/src/Termonad/Config/Colour.hs --- a/src/Termonad/Config/Colour.hs +++ b/src/Termonad/Config/Colour.hs @@ -87,7 +87,7 @@ -- $setup ) where -import Termonad.Prelude hiding ((\\), index) +import Termonad.Prelude import Control.Lens ((%~), makeLensesFor) import Data.Colour @@ -124,9 +124,6 @@ , terminalSetColorHighlight , terminalSetColorHighlightForeground ) -import Text.Printf (printf) -import Text.Show (showString) - import Termonad.Lenses (lensCreateTermHook, lensHooks) import Termonad.Types ( Option(Unset) @@ -134,6 +131,7 @@ , TMState , whenSet ) +import Text.Printf (printf) -- $setup -- >>> import Data.Colour.Names (green, red) @@ -552,7 +550,7 @@ coef x = fromIntegral x / 5 -- | A matrix of a 6 x 6 x 6 color cube. Default value for 'ColourCubePalette'. -- --- >>> putStrLn $ pack $ showColourCube defaultColourCube +-- >>> putStrLn $ showColourCube defaultColourCube -- [ [ #000000ff, #00005fff, #000087ff, #0000afff, #0000d7ff, #0000ffff -- , #005f00ff, #005f5fff, #005f87ff, #005fafff, #005fd7ff, #005fffff -- , #008700ff, #00875fff, #008787ff, #0087afff, #0087d7ff, #0087ffff @@ -660,6 +658,12 @@ showCol :: AlphaColour Double -> String -> String showCol col str = sRGB32show col <> str + + -- A version of head that gives a better error message. + headEx :: forall b. [b] -> b + headEx = \case + [] -> error "showColourCube: error in headEx, passed empty list, this is likely a logic error" + (h : _) -> h -- | A List of a grey scale. Default value for 'FullPalette'. -- diff --git a/src/Termonad/Gtk.hs b/src/Termonad/Gtk.hs --- a/src/Termonad/Gtk.hs +++ b/src/Termonad/Gtk.hs @@ -17,14 +17,16 @@ import Termonad.Prelude -import Control.Monad.Fail (MonadFail, fail) import Data.GI.Base (ManagedPtr, withManagedPtr) +import Data.Text (unpack) import GHC.Stack (HasCallStack) import GI.Gdk ( GObject , castTo ) -import GI.Gio (ApplicationFlags) +import GI.GdkPixbuf (Pixbuf, pixbufNewFromStream) +import GI.Gio (ApplicationFlags, Cancellable) +import GI.Gio.Objects.MemoryInputStream (memoryInputStreamNewFromData) import GI.Gtk (Application, IsWidget, Widget(Widget), applicationNew, builderGetObject, toWidget) import qualified GI.Gtk as Gtk import GI.Vte @@ -33,22 +35,18 @@ , terminalSetEnableSixel #endif ) - +import System.Exit (die) objFromBuildUnsafe :: GObject o => Gtk.Builder -> Text -> (ManagedPtr o -> o) -> IO o objFromBuildUnsafe builder name constructor = do maybePlainObj <- builderGetObject builder name case maybePlainObj of - Nothing -> error $ "Couldn't get " <> unpack name <> " from builder!" + Nothing -> error $ unpack $ "Couldn't get " <> name <> " from builder!" Just plainObj -> do maybeNewObj <- castTo constructor plainObj case maybeNewObj of - Nothing -> - error $ - "Got " <> - unpack name <> - " from builder, but couldn't convert to object!" + Nothing -> error $ unpack $ "Got " <> name <> " from builder, but couldn't convert to object!" Just obj -> pure obj -- | Unsafely creates a new 'Application'. This calls 'fail' if it cannot @@ -93,3 +91,15 @@ terminalSetEnableSixel t b #endif pure () + +-- | Load an image in a 'ByteString' into a 'Pixbuf'. +-- +-- Supports all image types that 'pixbufNewFromStream' supports. +imgToPixbuf :: ByteString -> IO Pixbuf +imgToPixbuf imgByteString = do + inputStream <- memoryInputStreamNewFromData imgByteString Nothing + maybePixbuf <- pixbufNewFromStream inputStream (Nothing :: Maybe Cancellable) + case maybePixbuf of + Nothing -> + die "imgToPixbuf: Unexpected error when trying to convert an image to a Pixbuf" + Just pixbuf -> pure pixbuf diff --git a/src/Termonad/IdMap.hs b/src/Termonad/IdMap.hs new file mode 100644 --- /dev/null +++ b/src/Termonad/IdMap.hs @@ -0,0 +1,25 @@ +-- | Module : Termonad.IdMap +-- Description : A Map that keeps track of the ID of values +-- Copyright : (c) Dennis Gosnell, 2023 +-- License : BSD3 +-- Stability : experimental +-- Portability : POSIX +-- +-- An 'IdMap' is a combination between an 'IntMap' and a 'Set'. +-- +-- An 'IdMap' allows adding an arbitrary number of things to be tracked. It +-- returns an 'IdMapKey' whenever a new item is added to the set. This +-- 'IdMapKey' can then be used to lookup items already in the set. + +module Termonad.IdMap + ( IdMapKey + , IdMap + , emptyIdMap + , singletonIdMap + , insertIdMap + , lookupIdMap + , keysIdMap + , deleteIdMap + ) where + +import Termonad.IdMap.Internal diff --git a/src/Termonad/IdMap/Internal.hs b/src/Termonad/IdMap/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Termonad/IdMap/Internal.hs @@ -0,0 +1,165 @@ +-- | Module : Termonad.IdMap +-- Description : A Map that keeps track of the ID of values +-- Copyright : (c) Dennis Gosnell, 2023 +-- License : BSD3 +-- Stability : experimental +-- Portability : POSIX + +module Termonad.IdMap.Internal where + +import Termonad.Prelude + +import Control.Lens (FoldableWithIndex, ifoldMap, Index, IxValue, Traversal', Ixed (ix)) +import qualified Data.Foldable as Foldable +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap + +newtype IdMapKey = IdMapKey { unIdMapKey :: Int } + deriving stock (Eq, Show) + +data IdMap a = IdMap + { idMap :: !(IntMap a) + , nextId :: !Int + } + deriving stock Show + +-- | 'IdMap's are equal if they contain the same elements at the same keys. +-- +-- >>> let (helloKey, idmapA) = insertIdMap "hello" emptyIdMap +-- >>> let (_, idmapB) = singletonIdMap "hello" +-- >>> idmapA == idmapB +-- True +-- +-- Note that if you delete and reinsert a value, it will get a different key, +-- so will no longer be equal. +-- +-- >>> let (_, idmapA') = insertIdMap "hello" $ deleteIdMap helloKey idmapA +-- >>> idmapA' == idmapB +-- False +-- +-- However, 'IdMap's don't check the 'nextId' field when determining equality. +-- +-- >>> let (byeKey, idmapA'') = insertIdMap "bye" idmapA +-- >>> let idmapA''' = deleteIdMap byeKey idmapA'' +-- >>> idmapA''' == idmapB +-- True +instance Eq a => Eq (IdMap a) where + (IdMap idMapA _) == (IdMap idMapB _) = idMapA == idMapB + +instance Functor IdMap where + fmap f IdMap{idMap, nextId} = IdMap { idMap = fmap f idMap, nextId } + +instance Foldable IdMap where + foldMap f m = Foldable.foldMap f $ idMap m + +instance FoldableWithIndex Int IdMap where + ifoldMap f m = ifoldMap f $ idMap m + +instance Traversable IdMap where + traverse f IdMap{idMap, nextId} = + fmap (\m -> IdMap { idMap = m, nextId }) (traverse f idMap) + +type instance Index (IdMap a) = IdMapKey +type instance IxValue (IdMap a) = a + +instance Ixed (IdMap a) where + ix :: IdMapKey -> Traversal' (IdMap a) a + ix (IdMapKey i) f IdMap{idMap, nextId} = + case IntMap.lookup i idMap of + Just v -> fmap update (f v) -- f v <&> \v' -> IntMap.insert k v' m + Nothing -> pure IdMap{idMap, nextId} + where + update :: a -> IdMap a + update v' = + IdMap + { idMap = IntMap.adjust (const v') i idMap + , nextId + } + +initialId :: Int +initialId = 0 + +-- | Get the next available ID. +-- +-- >>> succId 3 +-- 4 +succId :: Int -> Int +succId i = i + 1 + +-- | An initial 'IdMap' with no values. +-- +-- >>> emptyIdMap +-- IdMap {idMap = fromList [], nextId = 0} +emptyIdMap :: IdMap a +emptyIdMap = IdMap { idMap = mempty, nextId = 0 } + +-- | Insert a value into an 'IdMap'. Returns the key for the newly inserted +-- item. +-- +-- >>> let (key, idmap) = insertIdMap "hello" emptyIdMap +-- >>> (key, idmap) +-- (IdMapKey {unIdMapKey = 0},IdMap {idMap = fromList [(0,"hello")], nextId = 1}) +-- +-- >>> insertIdMap "zoom" idmap +-- (IdMapKey {unIdMapKey = 1},IdMap {idMap = fromList [(0,"hello"),(1,"zoom")], nextId = 2}) +insertIdMap :: a -> IdMap a -> (IdMapKey, IdMap a) +insertIdMap a IdMap {idMap, nextId} = + let newMap = IntMap.insert nextId a idMap + newNextId = nextId + 1 + in (IdMapKey nextId, IdMap { idMap = newMap, nextId = newNextId }) + +-- | Create an 'IdMap' with a single value. +-- +-- >>> singletonIdMap "hello" +-- (IdMapKey {unIdMapKey = 0},IdMap {idMap = fromList [(0,"hello")], nextId = 1}) +-- +-- prop> \a -> insertIdMap a emptyIdMap == singletonIdMap a +singletonIdMap :: a -> (IdMapKey, IdMap a) +singletonIdMap a = insertIdMap a emptyIdMap + +-- | Lookup the given key in an 'IdMap'. +-- +-- >>> let (key, idmap) = insertIdMap "hello" emptyIdMap +-- >>> lookupIdMap key idmap +-- Just "hello" +-- +-- Trying to lookup keys that don't exist returns 'Nothing': +-- +-- >>> let idmap' = deleteIdMap key idmap +-- >>> lookupIdMap key idmap' +-- Nothing +lookupIdMap :: IdMapKey -> IdMap a -> Maybe a +lookupIdMap (IdMapKey k) IdMap {idMap} = IntMap.lookup k idMap + +-- | List all keys in an 'IdMap'. +-- +-- >>> let (_, idmap) = singletonIdMap "hello" +-- >>> let (_, idmap') = insertIdMap "bye" idmap +-- >>> keysIdMap idmap' +-- [IdMapKey {unIdMapKey = 0},IdMapKey {unIdMapKey = 1}] +-- +-- Returns the empty list when passed an empty 'IdMap': +-- +-- >>> keysIdMap emptyIdMap +-- [] +keysIdMap :: IdMap a -> [IdMapKey] +keysIdMap IdMap {idMap} = fmap IdMapKey $ IntMap.keys idMap + +-- | Delete a key and its value from the map. When the key is not a member of +-- the map, the original map is returned. +-- +-- >>> let (key, idmap) = singletonIdMap "hello" +-- >>> let (_, idmap') = insertIdMap "bye" idmap +-- >>> deleteIdMap key idmap' +-- IdMap {idMap = fromList [(1,"bye")], nextId = 2} +-- +-- Deleting a key that does not exist just returns the old map: +-- +-- >>> deleteIdMap key idmap' +-- IdMap {idMap = fromList [(1,"bye")], nextId = 2} +deleteIdMap :: IdMapKey -> IdMap a -> IdMap a +deleteIdMap (IdMapKey k) IdMap {idMap, nextId} = + IdMap + { idMap = IntMap.delete k idMap + , nextId + } diff --git a/src/Termonad/Keys.hs b/src/Termonad/Keys.hs --- a/src/Termonad/Keys.hs +++ b/src/Termonad/Keys.hs @@ -4,6 +4,10 @@ import Termonad.Prelude import Control.Lens (imap) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set import GI.Gdk ( EventKey , pattern KEY_0 @@ -27,7 +31,7 @@ ) import Termonad.Term (altNumSwitchTerm) -import Termonad.Types (TMState) +import Termonad.Types (TMState, TMWindowId) showKeys :: EventKey -> IO Bool @@ -41,28 +45,29 @@ keycode <- getEventKeyHardwareKeycode eventKey putStrLn "key press event:" - putStrLn $ " type = " <> tshow eventType - putStrLn $ " str = " <> tshow maybeString - putStrLn $ " mods = " <> tshow modifiers - putStrLn $ " isMod = " <> tshow isMod - putStrLn $ " len = " <> tshow len - putStrLn $ " keyval = " <> tshow keyval - putStrLn $ " keycode = " <> tshow keycode + putStrLn $ " type = " <> show eventType + putStrLn $ " str = " <> show maybeString + putStrLn $ " mods = " <> show modifiers + putStrLn $ " isMod = " <> show isMod + putStrLn $ " len = " <> show len + putStrLn $ " keyval = " <> show keyval + putStrLn $ " keycode = " <> show keycode putStrLn "" pure True data Key = Key - { keyVal :: Word32 - , keyMods :: Set ModifierType + { keyVal :: !Word32 + , keyMods :: !(Set ModifierType) } deriving (Eq, Ord, Show) toKey :: Word32 -> Set ModifierType -> Key toKey = Key -keyMap :: Map Key (TMState -> IO Bool) +keyMap :: Map Key (TMState -> TMWindowId -> IO Bool) keyMap = - let numKeys = + let numKeys :: [Word32] + numKeys = [ KEY_1 , KEY_2 , KEY_3 @@ -74,6 +79,7 @@ , KEY_9 , KEY_0 ] + altNumKeys :: [(Key, TMState -> TMWindowId -> IO Bool)] altNumKeys = imap (\i k -> @@ -81,14 +87,15 @@ ) numKeys in - mapFromList altNumKeys + Map.fromList altNumKeys -stopProp :: (TMState -> IO a) -> TMState -> IO Bool -stopProp callback terState = callback terState $> True +stopProp :: (TMState -> TMWindowId -> IO a) -> TMState -> TMWindowId -> IO Bool +stopProp callback terState tmWinId = callback terState tmWinId $> True removeStrangeModifiers :: Key -> Key removeStrangeModifiers Key{keyVal, keyMods} = - let reservedModifiers = + let reservedModifiers :: Set ModifierType + reservedModifiers = [ ModifierTypeModifierReserved13Mask , ModifierTypeModifierReserved14Mask , ModifierTypeModifierReserved15Mask @@ -104,17 +111,17 @@ , ModifierTypeModifierReserved25Mask , ModifierTypeModifierReserved29Mask ] - in Key keyVal (difference keyMods reservedModifiers) + in Key keyVal (Set.difference keyMods reservedModifiers) -handleKeyPress :: TMState -> EventKey -> IO Bool -handleKeyPress terState eventKey = do +handleKeyPress :: TMState -> TMWindowId -> EventKey -> IO Bool +handleKeyPress terState tmWindowId eventKey = do -- void $ showKeys eventKey keyval <- getEventKeyKeyval eventKey modifiers <- getEventKeyState eventKey - let oldKey = toKey keyval (setFromList modifiers) + let oldKey = toKey keyval (Set.fromList modifiers) newKey = removeStrangeModifiers oldKey - maybeAction = lookup newKey keyMap + maybeAction = Map.lookup newKey keyMap case maybeAction of - Just action -> action terState + Just action -> action terState tmWindowId Nothing -> pure False diff --git a/src/Termonad/Lenses.hs b/src/Termonad/Lenses.hs --- a/src/Termonad/Lenses.hs +++ b/src/Termonad/Lenses.hs @@ -29,12 +29,17 @@ ) $(makeLensesFor + [ ("tmWindowAppWin", "lensTMWindowAppWin") + , ("tmWindowNotebook", "lensTMWindowNotebook") + ] + ''TMWindow + ) + +$(makeLensesFor [ ("tmStateApp", "lensTMStateApp") - , ("tmStateAppWin", "lensTMStateAppWin") - , ("tmStateNotebook", "lensTMStateNotebook") , ("tmStateFontDesc", "lensTMStateFontDesc") , ("tmStateConfig", "lensTMStateConfig") - , ("tmStateUserReqExit", "lensTMStateUserReqExit") + , ("tmStateWindows", "lensTMStateWindows") ] ''TMState' ) diff --git a/src/Termonad/Preferences.hs b/src/Termonad/Preferences.hs new file mode 100644 --- /dev/null +++ b/src/Termonad/Preferences.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE CPP #-} + +-- | Description : Controls the Preferences dialog and setting app preferences +-- Copyright : (c) Dennis Gosnell, 2023 +-- License : BSD3 +-- Stability : experimental +-- Portability : POSIX +-- +-- This module controls the Preferences dialog, which lets you set Termonad +-- preferences at run-time. +-- +-- It also exports helpful functions from "Termonad.Preferences.File". + +module Termonad.Preferences + ( module Termonad.Preferences.File + , showPreferencesDialog + ) where + +import Termonad.Prelude + +import Control.Lens ((^.), over, set, view) +import qualified Data.List as List +import qualified Data.Text as Text +import GI.Gtk + ( CheckButton(CheckButton) + , ComboBoxText(ComboBoxText) + , Dialog(Dialog) + , Entry(Entry) + , FontButton(FontButton) + , Label(Label) + , PolicyType(PolicyTypeAutomatic) + , ResponseType(ResponseTypeAccept) + , SpinButton(SpinButton) + , adjustmentNew + , applicationGetActiveWindow + , applicationWindowSetShowMenubar + , builderNewFromString + , comboBoxGetActiveId + , comboBoxSetActiveId + , comboBoxTextAppend + , dialogRun + , entryBufferGetText + , entryBufferSetText + , fontChooserSetFontDesc + , fontChooserGetFontDesc + , getEntryBuffer + , scrolledWindowSetPolicy + , spinButtonGetValueAsInt + , spinButtonSetAdjustment + , spinButtonSetValue + , toggleButtonGetActive + , toggleButtonSetActive + , widgetDestroy + , widgetSetVisible + , windowSetTransientFor + ) +import GI.Vte + ( CursorBlinkMode(..) + , terminalSetBoldIsBright + , terminalSetCursorBlinkMode + , terminalSetFont + , terminalSetScrollbackLines + , terminalSetWordCharExceptions + , terminalSetAllowBold + ) +import System.Environment (getExecutablePath) +import System.FilePath (takeFileName) +import Termonad.Gtk (objFromBuildUnsafe, terminalSetEnableSixelIfExists) +import Termonad.Lenses + ( lensBoldIsBright + , lensEnableSixel + , lensAllowBold + , lensConfirmExit + , lensCursorBlinkMode + , lensFontConfig + , lensOptions + , lensShowMenu + , lensShowScrollbar + , lensShowTabBar + , lensScrollbackLen + , lensTMNotebookTabTermContainer + , lensTMNotebookTabTerm + , lensTMStateApp + , lensTMStateConfig + , lensTMStateFontDesc + , lensTerm + , lensWordCharExceptions + ) +import Termonad.Preferences.File (saveToPreferencesFile, tmConfigFromPreferencesFile) +import Termonad.Term + ( setShowTabs + , showScrollbarToPolicy + ) +import Termonad.Types + ( ConfigOptions(..) + , ShowScrollbar(..) + , ShowTabBar(..) + , TMNotebookTab + , TMState + , TMWindowId + , fontConfigFromFontDescription + , getTMWindowFromTMState' + , tmNotebook + , tmNotebookTabs + , tmStateWindows + , tmWindowAppWin + , tmWindowNotebook + ) +import Termonad.XML (preferencesText) +import Termonad.IdMap (keysIdMap) + +-- | Fill a combo box with ids and labels +-- +-- The ids are stored in the combobox as 'Text', so their type should be an +-- instance of the 'Show' type class. +comboBoxFill :: forall a. Show a => ComboBoxText -> [(a, Text)] -> IO () +comboBoxFill comboBox = mapM_ go + where + go :: (a, Text) -> IO () + go (value, textId) = + comboBoxTextAppend comboBox (Just $ tshow value) textId + +-- | Set the current active item in a combobox given an input id. +comboBoxSetActive :: Show a => ComboBoxText -> a -> IO () +comboBoxSetActive cb item = void $ comboBoxSetActiveId cb (Just $ tshow item) + +-- | Get the current active item in a combobox +-- +-- The list of values to be searched in the combobox must be given as a +-- parameter. These values are converted to Text then compared to the current +-- id. +comboBoxGetActive + :: forall a. (Show a, Enum a) => ComboBoxText -> [a] -> IO (Maybe a) +comboBoxGetActive cb values = findEnumFromMaybeId <$> comboBoxGetActiveId cb + where + findEnumFromMaybeId :: Maybe Text -> Maybe a + findEnumFromMaybeId maybeId = maybeId >>= findEnumFromId + + findEnumFromId :: Text -> Maybe a + findEnumFromId label = List.find (\x -> tshow x == label) values + +applyNewPreferencesToTab :: TMState -> TMNotebookTab -> IO () +applyNewPreferencesToTab mvarTMState tab = do + tmState <- readMVar mvarTMState + let fontDesc = tmState ^. lensTMStateFontDesc + term = tab ^. lensTMNotebookTabTerm . lensTerm + scrolledWin = tab ^. lensTMNotebookTabTermContainer + options = tmState ^. lensTMStateConfig . lensOptions + terminalSetFont term (Just fontDesc) + terminalSetCursorBlinkMode term (cursorBlinkMode options) + terminalSetWordCharExceptions term (wordCharExceptions options) + terminalSetScrollbackLines term (fromIntegral (scrollbackLen options)) + terminalSetBoldIsBright term (boldIsBright options) + terminalSetEnableSixelIfExists term (enableSixel options) + terminalSetAllowBold term (allowBold options) + + let vScrollbarPolicy = showScrollbarToPolicy (options ^. lensShowScrollbar) + scrolledWindowSetPolicy scrolledWin PolicyTypeAutomatic vScrollbarPolicy + +applyNewPreferencesToWindow :: TMState -> TMWindowId -> IO () +applyNewPreferencesToWindow mvarTMState tmWinId = do + tmState <- readMVar mvarTMState + tmWin <- getTMWindowFromTMState' tmState tmWinId + let appWin = tmWindowAppWin tmWin + config = tmState ^. lensTMStateConfig + notebook = tmWindowNotebook tmWin + tabFocusList = tmNotebookTabs notebook + showMenu = config ^. lensOptions . lensShowMenu + applicationWindowSetShowMenubar appWin showMenu + setShowTabs config (tmNotebook notebook) + -- Sets the remaining preferences to each tab + foldMap (applyNewPreferencesToTab mvarTMState) tabFocusList + +-- | Takes a 'TMState', and looks at the 'TMConfig' within. +-- Take all the configuration options from the 'TMConfig' and apply them to the +-- current 'Application', 'Window's, and 'Term's. +-- +-- This function is meant to be used after a big update to the 'TMConfig' within a +-- 'TMState'. +applyNewPreferences :: TMState -> IO () +applyNewPreferences mvarTMState = do + tmState <- readMVar mvarTMState + let windows = tmStateWindows tmState + foldMap (applyNewPreferencesToWindow mvarTMState) (keysIdMap windows) + +-- | Show the preferences dialog. +-- +-- When the user clicks on the Ok button, it copies the new settings to TMState. +-- Then apply them to the current terminals. +showPreferencesDialog :: TMState -> IO () +showPreferencesDialog mvarTMState = do + -- Get app out of mvar + tmState <- readMVar mvarTMState + let app = tmState ^. lensTMStateApp + + -- Create the preference dialog and get some widgets + preferencesBuilder <- + builderNewFromString preferencesText $ fromIntegral (Text.length preferencesText) + preferencesDialog <- + objFromBuildUnsafe preferencesBuilder "preferences" Dialog + confirmExitCheckButton <- + objFromBuildUnsafe preferencesBuilder "confirmExit" CheckButton + showMenuCheckButton <- + objFromBuildUnsafe preferencesBuilder "showMenu" CheckButton + boldIsBrightCheckButton <- + objFromBuildUnsafe preferencesBuilder "boldIsBright" CheckButton + enableSixelCheckButton <- + objFromBuildUnsafe preferencesBuilder "enableSixel" CheckButton + allowBoldCheckButton <- + objFromBuildUnsafe preferencesBuilder "allowBold" CheckButton + wordCharExceptionsEntryBuffer <- + objFromBuildUnsafe preferencesBuilder "wordCharExceptions" Entry >>= + getEntryBuffer + fontButton <- objFromBuildUnsafe preferencesBuilder "font" FontButton + showScrollbarComboBoxText <- + objFromBuildUnsafe preferencesBuilder "showScrollbar" ComboBoxText + comboBoxFill + showScrollbarComboBoxText + [ (ShowScrollbarNever, "Never") + , (ShowScrollbarAlways, "Always") + , (ShowScrollbarIfNeeded, "If needed") + ] + showTabBarComboBoxText <- + objFromBuildUnsafe preferencesBuilder "showTabBar" ComboBoxText + comboBoxFill + showTabBarComboBoxText + [ (ShowTabBarNever, "Never") + , (ShowTabBarAlways, "Always") + , (ShowTabBarIfNeeded, "If needed") + ] + cursorBlinkModeComboBoxText <- + objFromBuildUnsafe preferencesBuilder "cursorBlinkMode" ComboBoxText + comboBoxFill + cursorBlinkModeComboBoxText + [ (CursorBlinkModeSystem, "System") + , (CursorBlinkModeOn, "On") + , (CursorBlinkModeOff, "Off") + ] + scrollbackLenSpinButton <- + objFromBuildUnsafe preferencesBuilder "scrollbackLen" SpinButton + adjustmentNew 0 0 (fromIntegral (maxBound :: Int)) 1 10 0 >>= + spinButtonSetAdjustment scrollbackLenSpinButton + warningLabel <- objFromBuildUnsafe preferencesBuilder "warning" Label + + -- We show the warning label only if the user has launched termonad with a + -- termonad.hs file + executablePath <- getExecutablePath + let hasTermonadHs = takeFileName executablePath == "termonad-linux-x86_64" + widgetSetVisible warningLabel hasTermonadHs + + -- Make the dialog modal + maybeWin <- applicationGetActiveWindow app + windowSetTransientFor preferencesDialog maybeWin + + -- Init with current state + fontChooserSetFontDesc fontButton (tmState ^. lensTMStateFontDesc) + let options = tmState ^. lensTMStateConfig . lensOptions + comboBoxSetActive showScrollbarComboBoxText $ showScrollbar options + comboBoxSetActive showTabBarComboBoxText $ showTabBar options + comboBoxSetActive cursorBlinkModeComboBoxText $ cursorBlinkMode options + spinButtonSetValue scrollbackLenSpinButton (fromIntegral $ scrollbackLen options) + toggleButtonSetActive confirmExitCheckButton $ confirmExit options + toggleButtonSetActive showMenuCheckButton $ showMenu options + toggleButtonSetActive boldIsBrightCheckButton $ boldIsBright options + toggleButtonSetActive enableSixelCheckButton $ enableSixel options + toggleButtonSetActive allowBoldCheckButton $ allowBold options + entryBufferSetText wordCharExceptionsEntryBuffer (wordCharExceptions options) (-1) + + -- Run dialog then close + res <- dialogRun preferencesDialog + + -- When closing the dialog get the new settings + when (toEnum (fromIntegral res) == ResponseTypeAccept) $ do + maybeFontDesc <- fontChooserGetFontDesc fontButton + maybeFontConfig <- + join <$> mapM fontConfigFromFontDescription maybeFontDesc + maybeShowScrollbar <- + comboBoxGetActive showScrollbarComboBoxText [ShowScrollbarNever ..] + maybeShowTabBar <- + comboBoxGetActive showTabBarComboBoxText [ShowTabBarNever ..] + maybeCursorBlinkMode <- + comboBoxGetActive cursorBlinkModeComboBoxText [CursorBlinkModeSystem ..] + scrollbackLenVal <- + fromIntegral <$> spinButtonGetValueAsInt scrollbackLenSpinButton + confirmExitVal <- toggleButtonGetActive confirmExitCheckButton + showMenuVal <- toggleButtonGetActive showMenuCheckButton + boldIsBrightVal <- toggleButtonGetActive boldIsBrightCheckButton + enableSixelVal <- toggleButtonGetActive enableSixelCheckButton + allowBoldVal <- toggleButtonGetActive allowBoldCheckButton + wordCharExceptionsVal <- entryBufferGetText wordCharExceptionsEntryBuffer + + -- Apply the changes to mvarTMState + modifyMVar_ mvarTMState $ pure + . over lensTMStateFontDesc (`fromMaybe` maybeFontDesc) + . over (lensTMStateConfig . lensOptions) + ( set lensConfirmExit confirmExitVal + . set lensShowMenu showMenuVal + . set lensBoldIsBright boldIsBrightVal + . set lensEnableSixel enableSixelVal + . set lensAllowBold allowBoldVal + . set lensWordCharExceptions wordCharExceptionsVal + . over lensFontConfig (`fromMaybe` maybeFontConfig) + . set lensScrollbackLen scrollbackLenVal + . over lensShowScrollbar (`fromMaybe` maybeShowScrollbar) + . over lensShowTabBar (`fromMaybe` maybeShowTabBar) + . over lensCursorBlinkMode (`fromMaybe` maybeCursorBlinkMode) + ) + + -- Save the changes to the preferences files + withMVar mvarTMState $ saveToPreferencesFile . view lensTMStateConfig + + -- Update the app with new settings + applyNewPreferences mvarTMState + + widgetDestroy preferencesDialog diff --git a/src/Termonad/Preferences/File.hs b/src/Termonad/Preferences/File.hs new file mode 100644 --- /dev/null +++ b/src/Termonad/Preferences/File.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE CPP #-} + +-- | Description : Read and write to the Preferences file +-- Copyright : (c) Dennis Gosnell, 2023 +-- License : BSD3 +-- Stability : experimental +-- Portability : POSIX +-- +-- This module contains functions for reading and writing to the preferences file. +-- +-- The preferences file is generally stored in +-- @~/.config/termonad/termonad.yaml@. It stores run-time preferences that +-- have been set through the Preferences dialog. Preferences are loaded on +-- app startup, but only if the @termonad.hs@ configuration file doesn't exist. + +module Termonad.Preferences.File where + +import Termonad.Prelude + +import Control.Monad.Trans.Except (ExceptT(..), runExceptT, throwE, withExceptT) +import Data.Aeson (Result(..), fromJSON) +#if MIN_VERSION_aeson(2, 0, 0) +import qualified Data.Aeson.KeyMap as KeyMap +#endif +import qualified Data.ByteString as ByteString +import qualified Data.HashMap.Strict as HashMap +import Data.Text (pack) +import Data.Yaml (ParseException, ToJSON (toJSON), decodeFileEither, encode, prettyPrintParseException) +import Data.Yaml.Aeson (Value(..)) +import System.Directory + ( XdgDirectory(XdgConfig) + , createDirectoryIfMissing + , doesFileExist + , getXdgDirectory + ) +import System.FilePath (()) +import Termonad.Types + ( ConfigOptions + , TMConfig(TMConfig, hooks, options) + , defaultConfigHooks + , defaultConfigOptions + ) + +-- $setup +-- +-- >>> import Data.Aeson(object, (.=)) + +-- | Get the path to the preferences file @~\/.config\/termonad\/termonad.yaml@. +getPreferencesFile :: IO FilePath +getPreferencesFile = do + -- Get the termonad config directory + confDir <- getXdgDirectory XdgConfig "termonad" + createDirectoryIfMissing True confDir + pure $ confDir "termonad.yaml" + +-- | Read the configuration for the preferences file +-- @~\/.config\/termonad\/termonad.yaml@. This file stores only the 'options' of +-- 'TMConfig' so 'hooks' are initialized with 'defaultConfigHooks'. If the +-- file doesn't exist, create it with the default values. +-- +-- Any options that do not exist will get initialized with values from +-- 'defaultConfigOptions'. +tmConfigFromPreferencesFile :: IO TMConfig +tmConfigFromPreferencesFile = do + confFile <- getPreferencesFile + -- If there is no preferences file we create it with the default values + exists <- doesFileExist confFile + unless exists $ writePreferencesFile confFile defaultConfigOptions + -- Read the configuration file + eitherOptions <- readFileWithDefaults confFile + options <- + case eitherOptions of + Left err -> do + hPutStrLn stderr $ "Error parsing file " <> pack confFile <> ": " <> err + pure defaultConfigOptions + Right options -> pure options + pure TMConfig { options = options, hooks = defaultConfigHooks } + +-- | Read the 'ConfigOptions' out of a configuration file. +-- +-- Merge the raw 'ConfigOptions' with 'defaultConfigOptions'. This makes sure +-- that old versions of the configuration file will still be able to be read +-- even if new options are added to 'ConfigOptions' in new versions of +-- Termonad. +readFileWithDefaults :: FilePath -> IO (Either Text ConfigOptions) +readFileWithDefaults file = runExceptT $ do + -- Read the configuration file as a JSON object + optsFromFile :: Value <- + withExceptT parseExceptionToText . ExceptT $ decodeFileEither file + let optsDefault :: Value = toJSON defaultConfigOptions + -- Then merge it with the default options in JSON before converting it to + -- a 'ConfigOptions' + resultToExcept . fromJSON $ mergeObjVals optsFromFile optsDefault + where + parseExceptionToText :: ParseException -> Text + parseExceptionToText = pack . prettyPrintParseException + + resultToExcept :: Result a -> ExceptT Text IO a + resultToExcept (Success v) = pure v + resultToExcept (Error str) = throwE (pack str) + +-- | Merge 'Value's recursively. +-- +-- This merges 'Value's recursively in 'Object' values, taking values that +-- have been explicitly over the defaults. The defaults are only used if +-- there is no value that has been explicitly set. +-- +-- For 'Array', 'String', 'Number', 'Bool', and 'Null', take the first 'Value' +-- (the one that has been explicitly set in the user's config file): +-- +-- >>> mergeObjVals (Array [Number 1, Number 2]) (Array [String "hello"]) +-- Array [Number 1.0,Number 2.0] +-- >>> mergeObjVals (String "hello") (String "bye") +-- String "hello" +-- >>> mergeObjVals (Number 1) (Number 2) +-- Number 1.0 +-- >>> mergeObjVals (Bool True) (Bool False) +-- Bool True +-- >>> mergeObjVals Null Null +-- Null +-- +-- Note that 'Value's in 'Array's are not recursed into: +-- +-- >>> let obj1 = object ["hello" .= Number 2] +-- >>> let obj2 = object ["hello" .= String "bye"] +-- >>> mergeObjVals (Array [obj1]) (Array [obj2]) +-- Array [Object (fromList [("hello",Number 2.0)])] +-- +-- 'Object's are recursed into. Unique keys from both Maps will be used. +-- Keys that are in both Maps will be merged according to the rules above: +-- +-- >>> let object1 = object ["hello" .= Number 1, "bye" .= Number 100] +-- >>> let object2 = object ["hello" .= Number 2, "goat" .= String "chicken"] +-- >>> mergeObjVals object1 object2 +-- Object (fromList [("bye",Number 100.0),("goat",String "chicken"),("hello",Number 1.0)]) +-- +-- 'Value's of different types will use the second 'Value': +-- +-- >>> mergeObjVals Null (String "bye") +-- String "bye" +-- >>> mergeObjVals (Bool True) (Number 2) +-- Number 2.0 +-- >>> mergeObjVals (Object mempty) (Bool False) +-- Bool False +mergeObjVals + :: Value + -- ^ Value that has been set explicitly in the User's configuration + -- file. + -> Value + -- ^ Default value that will be used if no explicitly set value. + -> Value + -- ^ Merged values. +mergeObjVals optsFromFile optsDefault = + case (optsFromFile, optsDefault) of + -- Both the options from the file and the default options are an Object + -- here. Recursively merge the keys and values. + (Object optsFromFileKeyMap, Object optsDefaultKeyMap) -> + let +#if MIN_VERSION_aeson(2, 0, 0) + hashMapFromKeyMap = KeyMap.toHashMap + keyMapFromHashMap = KeyMap.fromHashMap +#else + hashMapFromKeyMap = id + keyMapFromHashMap = id +#endif + optsFromFileHashMap = hashMapFromKeyMap optsFromFileKeyMap + optsDefaultHashMap = hashMapFromKeyMap optsDefaultKeyMap + optsResultHashMap = HashMap.unionWith mergeObjVals + optsFromFileHashMap + optsDefaultHashMap + optsResultKeyMap = keyMapFromHashMap optsResultHashMap + in Object optsResultKeyMap + -- Both the value from the file and the default value are the same type. + -- Use the value from the file. + -- + -- XXX: This will end up causing readFileWithDefaults to fail if the value + -- from the file is old and can no longer properly be decoded into a value + -- expected by ConfigOptions. + (Array fromFile, Array _) -> Array fromFile + (String fromFile, String _) -> String fromFile + (Number fromFile, Number _) -> Number fromFile + (Bool fromFile, Bool _) -> Bool fromFile + (Null, Null) -> Null + -- The value from the file and the default value are different types. Just + -- use the default value. + (_, defVal) -> defVal + +writePreferencesFile :: FilePath -> ConfigOptions -> IO () +writePreferencesFile confFile options = do + let yaml = encode options + yamlWithComment = + "# DO NOT EDIT THIS FILE BY HAND!\n" <> + "#\n" <> + "# This file is generated automatically by the Preferences dialog\n" <> + "# in Termonad. Please open the Preferences dialog if you wish to\n" <> + "# modify this file.\n" <> + "#\n" <> + "# The settings in this file will be ignored if you have a\n" <> + "# termonad.hs file in this same directory.\n\n" <> + yaml + ByteString.writeFile confFile yamlWithComment + +-- | Save the configuration to the preferences file +-- @~\/.config\/termonad\/termonad.yaml@ +saveToPreferencesFile :: TMConfig -> IO () +saveToPreferencesFile TMConfig { options = options } = do + confFile <- getPreferencesFile + writePreferencesFile confFile options + diff --git a/src/Termonad/PreferencesFile.hs b/src/Termonad/PreferencesFile.hs deleted file mode 100644 --- a/src/Termonad/PreferencesFile.hs +++ /dev/null @@ -1,195 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Termonad.PreferencesFile where - -import Termonad.Prelude - -import Control.Monad.Trans.Except (ExceptT(..), runExceptT, throwE, withExceptT) -import Data.Aeson (Result(..), fromJSON) -#if MIN_VERSION_aeson(2, 0, 0) -import qualified Data.Aeson.KeyMap as KeyMap -#endif -import qualified Data.HashMap.Strict as HashMap -import Data.Yaml (ParseException, ToJSON (toJSON), decodeFileEither, encode, prettyPrintParseException) -import Data.Yaml.Aeson (Value(..)) - -import System.Directory - ( XdgDirectory(XdgConfig) - , createDirectoryIfMissing - , doesFileExist - , getXdgDirectory - ) - -import Termonad.Types - ( ConfigOptions - , TMConfig(TMConfig, hooks, options) - , defaultConfigHooks - , defaultConfigOptions - ) - --- $setup --- --- >>> import Data.Aeson(object, (.=)) - --- | Get the path to the preferences file @~\/.config\/termonad\/termonad.yaml@. -getPreferencesFile :: IO FilePath -getPreferencesFile = do - -- Get the termonad config directory - confDir <- getXdgDirectory XdgConfig "termonad" - createDirectoryIfMissing True confDir - pure $ confDir "termonad.yaml" - --- | Read the configuration for the preferences file --- @~\/.config\/termonad\/termonad.yaml@. This file stores only the 'options' of --- 'TMConfig' so 'hooks' are initialized with 'defaultConfigHooks'. If the --- file doesn't exist, create it with the default values. --- --- Any options that do not exist will get initialized with values from --- 'defaultConfigOptions'. -tmConfigFromPreferencesFile :: IO TMConfig -tmConfigFromPreferencesFile = do - confFile <- getPreferencesFile - -- If there is no preferences file we create it with the default values - exists <- doesFileExist confFile - unless exists $ writePreferencesFile confFile defaultConfigOptions - -- Read the configuration file - eitherOptions <- readFileWithDefaults confFile - options <- - case eitherOptions of - Left err -> do - hPutStrLn stderr $ "Error parsing file " <> pack confFile <> ": " <> err - pure defaultConfigOptions - Right options -> pure options - pure TMConfig { options = options, hooks = defaultConfigHooks } - --- | Read the 'ConfigOptions' out of a configuration file. --- --- Merge the raw 'ConfigOptions' with 'defaultConfigOptions'. This makes sure --- that old versions of the configuration file will still be able to be read --- even if new options are added to 'ConfigOptions' in new versions of --- Termonad. -readFileWithDefaults :: FilePath -> IO (Either Text ConfigOptions) -readFileWithDefaults file = runExceptT $ do - -- Read the configuration file as a JSON object - optsFromFile :: Value <- - withExceptT parseExceptionToText . ExceptT $ decodeFileEither file - let optsDefault :: Value = toJSON $ defaultConfigOptions - -- Then merge it with the default options in JSON before converting it to - -- a 'ConfigOptions' - resultToExcept . fromJSON $ mergeObjVals optsFromFile optsDefault - where - parseExceptionToText :: ParseException -> Text - parseExceptionToText = pack . prettyPrintParseException - - resultToExcept :: Result a -> ExceptT Text IO a - resultToExcept (Success v) = pure v - resultToExcept (Error str) = throwE (pack str) - --- | Merge 'Value's recursively. --- --- This merges 'Value's recursively in 'Object' values, taking values that --- have been explicitly over the defaults. The defaults are only used if --- there is no value that has been explicitly set. --- --- For 'Array', 'String', 'Number', 'Bool', and 'Null', take the first 'Value' --- (the one that has been explicitly set in the user's config file): --- --- >>> mergeObjVals (Array [Number 1, Number 2]) (Array [String "hello"]) --- Array [Number 1.0,Number 2.0] --- >>> mergeObjVals (String "hello") (String "bye") --- String "hello" --- >>> mergeObjVals (Number 1) (Number 2) --- Number 1.0 --- >>> mergeObjVals (Bool True) (Bool False) --- Bool True --- >>> mergeObjVals Null Null --- Null --- --- Note that 'Value's in 'Array's are not recursed into: --- --- >>> let obj1 = object ["hello" .= Number 2] --- >>> let obj2 = object ["hello" .= String "bye"] --- >>> mergeObjVals (Array [obj1]) (Array [obj2]) --- Array [Object (fromList [("hello",Number 2.0)])] --- --- 'Object's are recursed into. Unique keys from both Maps will be used. --- Keys that are in both Maps will be merged according to the rules above: --- --- >>> let object1 = object ["hello" .= Number 1, "bye" .= Number 100] --- >>> let object2 = object ["hello" .= Number 2, "goat" .= String "chicken"] --- >>> mergeObjVals object1 object2 --- Object (fromList [("bye",Number 100.0),("goat",String "chicken"),("hello",Number 1.0)]) --- --- 'Value's of different types will use the second 'Value': --- --- >>> mergeObjVals Null (String "bye") --- String "bye" --- >>> mergeObjVals (Bool True) (Number 2) --- Number 2.0 --- >>> mergeObjVals (Object mempty) (Bool False) --- Bool False --- -mergeObjVals - :: Value - -- ^ Value that has been set explicitly in the User's configuration - -- file. - -> Value - -- ^ Default value that will be used if no explicitly set value. - -> Value - -- ^ Merged values. -mergeObjVals optsFromFile optsDefault = - case (optsFromFile, optsDefault) of - -- Both the options from the file and the default options are an Object - -- here. Recursively merge the keys and values. - (Object optsFromFileKeyMap, Object optsDefaultKeyMap) -> - let -#if MIN_VERSION_aeson(2, 0, 0) - hashMapFromKeyMap = KeyMap.toHashMap - keyMapFromHashMap = KeyMap.fromHashMap -#else - hashMapFromKeyMap = id - keyMapFromHashMap = id -#endif - optsFromFileHashMap = hashMapFromKeyMap optsFromFileKeyMap - optsDefaultHashMap = hashMapFromKeyMap optsDefaultKeyMap - optsResultHashMap = HashMap.unionWith mergeObjVals - optsFromFileHashMap - optsDefaultHashMap - optsResultKeyMap = keyMapFromHashMap optsResultHashMap - in Object optsResultKeyMap - -- Both the value from the file and the default value are the same type. - -- Use the value from the file. - -- - -- XXX: This will end up causing readFileWithDefaults to fail if the value - -- from the file is old and can no longer properly be decoded into a value - -- expected by ConfigOptions. - (Array fromFile, Array _) -> Array fromFile - (String fromFile, String _) -> String fromFile - (Number fromFile, Number _) -> Number fromFile - (Bool fromFile, Bool _) -> Bool fromFile - (Null, Null) -> Null - -- The value from the file and the default value are different types. Just - -- use the default value. - (_, defVal) -> defVal - -writePreferencesFile :: FilePath -> ConfigOptions -> IO () -writePreferencesFile confFile options = do - let yaml = encode options - yamlWithComment = - "# DO NOT EDIT THIS FILE BY HAND!\n" <> - "#\n" <> - "# This file is generated automatically by the Preferences dialog\n" <> - "# in Termonad. Please open the Preferences dialog if you wish to\n" <> - "# modify this file.\n" <> - "#\n" <> - "# The settings in this file will be ignored if you have a\n" <> - "# termonad.hs file in this same directory.\n\n" <> - yaml - writeFile confFile yamlWithComment - --- | Save the configuration to the preferences file --- @~\/.config\/termonad\/termonad.yaml@ -saveToPreferencesFile :: TMConfig -> IO () -saveToPreferencesFile TMConfig { options = options } = do - confFile <- getPreferencesFile - writePreferencesFile confFile options diff --git a/src/Termonad/Prelude.hs b/src/Termonad/Prelude.hs --- a/src/Termonad/Prelude.hs +++ b/src/Termonad/Prelude.hs @@ -1,17 +1,42 @@ + +-- | This is a basic prelude-like module that adds a bunch of common datatypes +-- and functions to the 'Prelude'. + module Termonad.Prelude ( module X , hPutStrLn , whenJust + , stderr + , tshow ) where +import Control.Concurrent.MVar as X (MVar, modifyMVar, modifyMVar_, newMVar, readMVar, withMVar) +import Control.Exception as X (IOException, try) import Control.Lens as X ((&)) +import Control.Monad as X (join, unless, void, when, (<=<)) +import Control.Monad.IO.Class as X +import Control.Monad.Trans.Class as X (lift) import Control.Monad.Trans.Maybe as X (MaybeT(MaybeT), runMaybeT) -import ClassyPrelude as X +import Data.ByteString as X (ByteString) +import Data.Function as X (on) +import Data.Functor as X (($>)) +import Data.Int as X (Int32) +import Data.Maybe as X (catMaybes, fromMaybe) import Data.Proxy as X +import Data.String as X (IsString) +import Data.Text as X (Text) +import Data.Text (pack) import qualified Data.Text.IO as TextIO +import Data.Word as X (Word8, Word32) +import GHC.Generics as X (Generic) +import Prelude as X +import System.IO (Handle, stderr) whenJust :: Monoid m => Maybe a -> (a -> m) -> m whenJust = flip foldMap hPutStrLn :: MonadIO m => Handle -> Text -> m () hPutStrLn hndl = liftIO . TextIO.hPutStrLn hndl + +tshow :: Show a => a -> Text +tshow = pack . show diff --git a/src/Termonad/Startup.hs b/src/Termonad/Startup.hs new file mode 100644 --- /dev/null +++ b/src/Termonad/Startup.hs @@ -0,0 +1,149 @@ + +-- | Description : Functions for starting up Termonad. +-- Copyright : (c) Dennis Gosnell, 2023 +-- License : BSD3 +-- Stability : experimental +-- Portability : POSIX +-- +-- This module contains functions for starting up Termonad. + +module Termonad.Startup where + +import Termonad.Prelude + +import Config.Dyre (wrapMain, newParams) +import Control.Lens (over) +import System.IO.Error (doesNotExistErrorType, ioeGetErrorType, ioeGetFileName, tryIOError) +import Termonad.App (start) +import Termonad.Cli (parseCliArgs, applyCliArgs) +import Termonad.Lenses (lensOptions) +import Termonad.Types (TMConfig) + + +-- | Run Termonad with the given 'TMConfig'. +-- +-- Do not perform any of the recompilation operations that the 'defaultMain' +-- function does. +-- +-- This function __does__ parse command line arguments, and then calls 'Termonad.App.start'. +startWithCliArgs :: TMConfig -> IO () +startWithCliArgs tmConfig = do + cliArgs <- parseCliArgs + start (over lensOptions (applyCliArgs cliArgs) tmConfig) + +-- | Run Termonad with the given 'TMConfig'. +-- +-- This function will check if there is a @~\/.config\/termonad\/termonad.hs@ file +-- and a @~\/.cache\/termonad\/termonad-linux-x86_64@ binary. Termonad will +-- perform different actions based on whether or not these two files exist. +-- +-- Here are the four different possible actions based on the existence of these +-- two files. +-- +-- - @~\/.config\/termonad\/termonad.hs@ exists, @~\/.cache\/termonad\/termonad-linux-x86_64@ exists +-- +-- The timestamps of these two files are checked. If the +-- @~\/.config\/termonad\/termonad.hs@ file has been modified after the +-- @~\/.cache\/termonad\/termonad-linux-x86_64@ binary, then Termonad will use +-- GHC to recompile the @~\/.config\/termonad\/termonad.hs@ file, producing a +-- new binary at @~\/.cache\/termonad\/termonad-linux-x86_64@. This new binary +-- will be re-executed. The 'TMConfig' passed to this 'defaultMain' will be +-- effectively thrown away, however all command line options will be passed +-- on to this new Termonad process. +-- +-- If GHC fails to recompile the @~\/.config\/termonad\/termonad.hs@ file, then +-- Termonad will just execute 'startWithCliArgs' with the 'TMConfig' passed in. +-- +-- If the @~\/.cache\/termonad\/termonad-linux-x86_64@ binary has been modified +-- after the @~\/.config\/termonad\/termonad.hs@ file, then Termonad will +-- re-exec the @~\/.cache\/termonad\/termonad-linux-x86_64@ binary. The +-- 'TMConfig' passed to this 'defaultMain' will be effectively thrown away, +-- however all command line options will be passed on to this new Termonad +-- process. +-- +-- - @~\/.config\/termonad\/termonad.hs@ exists, @~\/.cache\/termonad\/termonad-linux-x86_64@ does not exist +-- +-- Termonad will use GHC to recompile the @~\/.config\/termonad\/termonad.hs@ +-- file, producing a new binary at @~\/.cache\/termonad\/termonad-linux-x86_64@. +-- This new binary will be re-executed. The 'TMConfig' passed to this +-- 'defaultMain' will be effectively thrown away, however all command line +-- options will be passed on to this new Termonad process. +-- +-- If GHC fails to recompile the @~\/.config\/termonad\/termonad.hs@ file, then +-- Termonad will just execute 'startWithCliArgs' with the 'TMConfig' passed in. +-- +-- - @~\/.config\/termonad\/termonad.hs@ does not exist, @~\/.cache\/termonad\/termonad-linux-x86_64@ exists +-- +-- Termonad will ignore the @~\/.cache\/termonad\/termonad-linux-x86_64@ binary +-- and just run 'startWithCliArgs' with the 'TMConfig' passed to this function. +-- +-- - @~\/.config\/termonad\/termonad.hs@ does not exist, @~\/.cache\/termonad\/termonad-linux-x86_64@ does not exist +-- +-- Termonad will run 'startWithCliArgs' with the 'TMConfig' passed to this function. +-- +-- Other notes: +-- +-- 1. That the locations of @~\/.config\/termonad\/termonad.hs@ and +-- @~\/.cache\/termonad\/termonad-linux-x86_64@ may differ depending on your +-- system. +-- +-- 2. In your own @~\/.config\/termonad\/termonad.hs@ file, you can use either +-- 'defaultMain' or 'startWithCliArgs'. As long as you always +-- execute the system-wide @termonad@ binary (instead of the binary produced +-- as @~\/.cache\/termonad\/termonad-linux-x86_64@), the effect should be +-- similar. +-- +-- 3. If you directly run the cached termonad binary (e.g. +-- @~\/.cache\/termonad\/termonad-linux-x86_64@) instead of the +-- system-installed Termonad binary (e.g. @\/usr\/bin\/termonad@), the Termonad +-- /will/ recompile the the configuration file +-- @~\/.config\/termonad\/termonad.hs@ according to the above logic (while +-- possibly overwriting the executable file for the binary you're currently +-- running), but it /will not/ re-exec into the newly built @termonad@ binary. +-- +-- 4. When running the system-wide @termonad@ binary, the initial 'TMConfig' +-- that gets passed into this function comes from +-- 'Termonad.PreferencesFile.tmConfigFromPreferencesFile'. As stated above, +-- this initial 'TMConfig' gets ignored if users have a +-- @~\/.config\/termonad\/termonad.hs@ file that gets recompiled and re-execed. +-- +-- End users generally call 'defaultMain' in their +-- @~\/.config\/termonad\/termonad.hs@ file. +-- +-- 'defaultMain' interally calls 'startWithCliArgs', which parses CLI arguments +-- and combines them with the passed-in 'TMConfig'. 'startWithCliArgs' then +-- internally calls 'Termonad.App.start'. +-- +-- If you don't want the re-compiling and re-exec functionality, you can directly +-- use 'startWithCliArgs'. If you also don't want the CLI argument parsing +-- functionality, you can directly use 'Termonad.App.start'. +defaultMain :: TMConfig -> IO () +defaultMain tmConfig = do + let params = newParams "termonad" realMainFunc collectErrs + eitherRes <- tryIOError $ wrapMain params (tmConfig, "") + case eitherRes of + Left ioErr + | ioeGetErrorType ioErr == doesNotExistErrorType && ioeGetFileName ioErr == Just "ghc" -> do + putStrLn $ + "Could not find ghc on your PATH. Ignoring your termonad.hs " <> + "configuration file and running termonad with default settings." + startWithCliArgs tmConfig + | otherwise -> do + putStrLn "IO error occurred when trying to run termonad:" + print ioErr + putStrLn "Don't know how to recover. Exiting." + Right _ -> pure () + where + -- The real main function + realMainFunc :: (TMConfig, String) -> IO () + realMainFunc (cfg, errs) = + case errs of + "" -> startWithCliArgs cfg + _ -> do + putStrLn $ "Errors from dyre when recompiling Termonad:" <> errs + putStrLn "Continuing with Termonad without re-execing into recompiled binary..." + startWithCliArgs cfg + + -- A function that can easily collect errors from dyre + collectErrs :: (TMConfig, String) -> String -> (TMConfig, String) + collectErrs (cfg, oldErrs) newErr = (cfg, oldErrs <> "\n" <> newErr) diff --git a/src/Termonad/Term.hs b/src/Termonad/Term.hs --- a/src/Termonad/Term.hs +++ b/src/Termonad/Term.hs @@ -4,9 +4,13 @@ import Termonad.Prelude -import Control.Lens ((^.), (.~), set, to) +import Control.Lens ((^.), ix, set) +import Data.Coerce (coerce) import Data.Colour.SRGB (Colour, RGB(RGB), toSRGB) import Data.FocusList (appendFL, deleteFL, getFocusItemFL) +import Data.GI.Base (toManagedPtr) +import Data.Text (pack) +import qualified Data.Text as Text import GI.Gdk ( Event (Event) , EventButton @@ -109,7 +113,7 @@ ) import System.Directory (getSymbolicLinkTarget) import System.Environment (lookupEnv) - +import System.FilePath (()) import Termonad.Gtk (terminalSetEnableSixelIfExists) import Termonad.Lenses ( lensConfirmExit @@ -122,9 +126,9 @@ , lensTMNotebookTabs , lensTMStateApp , lensTMStateConfig - , lensTMStateNotebook - , lensTerm + , lensTerm, lensTMStateWindows, lensTMWindowNotebook ) +import Termonad.Pcre (pcre2Multiline) import Termonad.Types ( ConfigHooks(createTermHook) , ConfigOptions(scrollbackLen, wordCharExceptions, cursorBlinkMode, boldIsBright, enableSixel, allowBold) @@ -134,57 +138,64 @@ , TMNotebook , TMNotebookTab , TMState - , TMState'(TMState, tmStateAppWin, tmStateConfig, tmStateFontDesc, tmStateNotebook) + , TMState'(TMState, tmStateConfig, tmStateFontDesc) , TMTerm + , TMWindowId , assertInvariantTMState , createTMNotebookTab + , getNotebookFromTMState + , getTMNotebookFromTMState + , getTMNotebookFromTMState' + , getTMWindowFromTMState + , getTMWindowFromWins , newTMTerm , pid , tmNotebook , tmNotebookTabTerm , tmNotebookTabTermContainer , tmNotebookTabs + , tmStateWindows + , tmWindowAppWin + , tmWindowNotebook ) -import Data.Coerce (coerce) -import Data.GI.Base (toManagedPtr) -import Termonad.Pcre (pcre2Multiline) -focusTerm :: Int -> TMState -> IO () -focusTerm i mvarTMState = do - note <- tmNotebook . tmStateNotebook <$> readMVar mvarTMState +focusTerm :: Int -> TMState -> TMWindowId -> IO () +focusTerm i mvarTMState tmWinId = do + note <- getNotebookFromTMState mvarTMState tmWinId notebookSetCurrentPage note (fromIntegral i) -altNumSwitchTerm :: Int -> TMState -> IO () +altNumSwitchTerm :: Int -> TMState -> TMWindowId -> IO () altNumSwitchTerm = focusTerm -termNextPage :: TMState -> IO () -termNextPage mvarTMState = do - note <- tmNotebook . tmStateNotebook <$> readMVar mvarTMState +-- | Change focus to the next tab. +termNextPage :: TMState -> TMWindowId -> IO () +termNextPage mvarTMState tmWinId = do + note <- getNotebookFromTMState mvarTMState tmWinId notebookNextPage note -termPrevPage :: TMState -> IO () -termPrevPage mvarTMState = do - note <- tmNotebook . tmStateNotebook <$> readMVar mvarTMState +-- | Change focus to the previous tab. +termPrevPage :: TMState -> TMWindowId -> IO () +termPrevPage mvarTMState tmWinId = do + note <- getNotebookFromTMState mvarTMState tmWinId notebookPrevPage note -termExitFocused :: TMState -> IO () -termExitFocused mvarTMState = do - tmState <- readMVar mvarTMState - let maybeTab = - tmState ^. lensTMStateNotebook . lensTMNotebookTabs . to getFocusItemFL +termExitFocused :: TMState -> TMWindowId -> IO () +termExitFocused mvarTMState tmWinId = do + note <- getTMNotebookFromTMState mvarTMState tmWinId + let maybeTab = getFocusItemFL $ tmNotebookTabs note case maybeTab of Nothing -> pure () - Just tab -> termClose tab mvarTMState + Just tab -> termClose tab mvarTMState tmWinId -termClose :: TMNotebookTab -> TMState -> IO () -termClose tab mvarTMState = do +termClose :: TMNotebookTab -> TMState -> TMWindowId -> IO () +termClose tab mvarTMState tmWindowId = do tmState <- readMVar mvarTMState let confirm = tmState ^. lensTMStateConfig . lensOptions . lensConfirmExit close = if confirm then termExitWithConfirmation else termExit - close tab mvarTMState + close tab mvarTMState tmWindowId -termExitWithConfirmation :: TMNotebookTab -> TMState -> IO () -termExitWithConfirmation tab mvarTMState = do +termExitWithConfirmation :: TMNotebookTab -> TMState -> TMWindowId -> IO () +termExitWithConfirmation tab mvarTMState tmWinId = do tmState <- readMVar mvarTMState let app = tmState ^. lensTMStateApp win <- applicationGetActiveWindow app @@ -208,30 +219,34 @@ res <- dialogRun dialog widgetDestroy dialog case toEnum (fromIntegral res) of - ResponseTypeYes -> termExit tab mvarTMState + ResponseTypeYes -> termExit tab mvarTMState tmWinId _ -> pure () -termExit :: TMNotebookTab -> TMState -> IO () -termExit tab mvarTMState = do +termExit :: TMNotebookTab -> TMState -> TMWindowId -> IO () +termExit tab mvarTMState tmWinId = do detachTabAction <- modifyMVar mvarTMState $ \tmState -> do - let notebook = tmStateNotebook tmState + tmNote <- getTMNotebookFromTMState' tmState tmWinId + let detachTabAction :: IO () detachTabAction = notebookDetachTab - (tmNotebook notebook) + (tmNotebook tmNote) (tmNotebookTabTermContainer tab) - let newTabs = deleteFL tab (tmNotebookTabs notebook) - let newTMState = - set (lensTMStateNotebook . lensTMNotebookTabs) newTabs tmState + newTabs = deleteFL tab (tmNotebookTabs tmNote) + newTMState = + set + (lensTMStateWindows . ix tmWinId . lensTMWindowNotebook . lensTMNotebookTabs) + newTabs + tmState pure (newTMState, detachTabAction) detachTabAction - relabelTabs mvarTMState + tmWin <- getTMWindowFromTMState mvarTMState tmWinId + relabelTabs (tmWindowNotebook tmWin) -relabelTabs :: TMState -> IO () -relabelTabs mvarTMState = do - TMState{tmStateNotebook} <- readMVar mvarTMState - let notebook = tmNotebook tmStateNotebook - tabFocusList = tmNotebookTabs tmStateNotebook +relabelTabs :: TMNotebook -> IO () +relabelTabs tmNote = do + let notebook = tmNotebook tmNote + tabFocusList = tmNotebookTabs tmNote foldMap (go notebook) tabFocusList where go :: Notebook -> TMNotebookTab -> IO () @@ -411,12 +426,13 @@ -- | Add a page to the notebook and switch to it. addPage :: TMState + -> TMWindowId -> TMNotebookTab -> Box -- ^ The GTK Object holding the label we want to show for the tab of the -- newly created page of the notebook. -> IO () -addPage mvarTMState notebookTab tabLabelBox = do +addPage mvarTMState tmWinId notebookTab tabLabelBox = do -- Append a new notebook page and update the TMState to reflect this. (note, pageIndex) <- modifyMVar mvarTMState appendNotebookPage @@ -425,8 +441,8 @@ where appendNotebookPage :: TMState' -> IO (TMState', (Notebook, Int32)) appendNotebookPage tmState = do - let notebook = tmStateNotebook tmState - note = tmNotebook notebook + notebook <- getTMNotebookFromTMState' tmState tmWinId + let note = tmNotebook notebook tabs = tmNotebookTabs notebook scrolledWin = tmNotebookTabTermContainer notebookTab pageIndex <- notebookAppendPage note scrolledWin (Just tabLabelBox) @@ -434,7 +450,10 @@ setShowTabs (tmState ^. lensTMStateConfig) note let newTabs = appendFL tabs notebookTab newTMState = - tmState & lensTMStateNotebook . lensTMNotebookTabs .~ newTabs + set + (lensTMStateWindows . ix tmWinId . lensTMWindowNotebook . lensTMNotebookTabs) + newTabs + tmState pure (newTMState, (note, pageIndex)) -- | Set the keyboard focus on a vte terminal @@ -445,17 +464,23 @@ -- | Create a new 'TMTerm', setting it up and adding it to the GTKNotebook. createTerm - :: (TMState -> EventKey -> IO Bool) + :: (TMState -> TMWindowId -> EventKey -> IO Bool) -- ^ Funtion for handling key presses on the terminal. -> TMState + -> TMWindowId -> IO TMTerm -createTerm handleKeyPress mvarTMState = do +createTerm handleKeyPress mvarTMState tmWinId = do -- Check preconditions assertInvariantTMState mvarTMState -- Read needed data in TMVar - TMState{tmStateAppWin, tmStateFontDesc, tmStateConfig, tmStateNotebook=currNote} <- + -- TMState{tmStateAppWin, tmStateFontDesc, tmStateConfig, tmStateNotebook=currNote} <- + -- readMVar mvarTMState + TMState{tmStateFontDesc, tmStateConfig, tmStateWindows} <- readMVar mvarTMState + tmWin <- getTMWindowFromWins tmStateWindows tmWinId + let appWin = tmWindowAppWin tmWin + currNote = tmWindowNotebook tmWin -- Create a new terminal and launch a shell in it vteTerm <- createAndInitVteTerm tmStateFontDesc (options tmStateConfig) @@ -474,7 +499,7 @@ let notebookTab = createTMNotebookTab tabLabel scrolledWin tmTerm -- Add the new notebooktab to the notebook. - addPage mvarTMState notebookTab tabLabelBox + addPage mvarTMState tmWinId notebookTab tabLabelBox -- Setup the initial label for the notebook tab. This needs to happen -- after we add the new page to the notebook, so that the page can get labelled @@ -482,15 +507,13 @@ relabelTab (tmNotebook currNote) tabLabel scrolledWin vteTerm -- Connect callbacks - void $ onButtonClicked tabCloseButton $ termClose notebookTab mvarTMState + void $ onButtonClicked tabCloseButton $ termClose notebookTab mvarTMState tmWinId void $ onTerminalWindowTitleChanged vteTerm $ do - TMState{tmStateNotebook} <- readMVar mvarTMState - let notebook = tmNotebook tmStateNotebook - relabelTab notebook tabLabel scrolledWin vteTerm - void $ onWidgetKeyPressEvent vteTerm $ handleKeyPress mvarTMState - void $ onWidgetKeyPressEvent scrolledWin $ handleKeyPress mvarTMState - void $ onWidgetButtonPressEvent vteTerm $ handleMousePress tmStateAppWin vteTerm - void $ onTerminalChildExited vteTerm $ \_ -> termExit notebookTab mvarTMState + relabelTab (tmNotebook currNote) tabLabel scrolledWin vteTerm + void $ onWidgetKeyPressEvent vteTerm $ handleKeyPress mvarTMState tmWinId + void $ onWidgetKeyPressEvent scrolledWin $ handleKeyPress mvarTMState tmWinId + void $ onWidgetButtonPressEvent vteTerm $ handleMousePress appWin vteTerm + void $ onTerminalChildExited vteTerm $ \_ -> termExit notebookTab mvarTMState tmWinId -- Underline URLs so that the user can see they are right-clickable. -- @@ -506,11 +529,11 @@ "(?:http(s)?:\\/\\/)[\\w.-]+(?:\\.[\\w\\.-]+)+[\\w\\-\\._~:/?#[\\]@!\\$&'\\(\\)\\*\\+,;=.]+" -- We must set the pcre2Multiline option, otherwise VTE prints a warning. let pcreFlags = fromIntegral pcre2Multiline - regex <- regexNewForMatch regexPat (fromIntegral $ length regexPat) pcreFlags + regex <- regexNewForMatch regexPat (fromIntegral $ Text.length regexPat) pcreFlags void $ terminalMatchAddRegex vteTerm regex 0 -- Put the keyboard focus on the term - setFocusOn tmStateAppWin vteTerm + setFocusOn appWin vteTerm -- Make sure the state is still right assertInvariantTMState mvarTMState diff --git a/src/Termonad/Types.hs b/src/Termonad/Types.hs --- a/src/Termonad/Types.hs +++ b/src/Termonad/Types.hs @@ -4,8 +4,9 @@ import Termonad.Prelude -import Control.Monad.Fail (fail) -import Data.FocusList (FocusList, emptyFL, singletonFL, getFocusItemFL, lengthFL) +import Control.Lens (ifoldMap) +import Data.FocusList (FocusList, emptyFL, getFocusItemFL, lengthFL) +import Data.Foldable (toList) import Data.Unique (Unique, hashUnique, newUnique) import Data.Yaml ( FromJSON(parseJSON) @@ -25,12 +26,11 @@ , notebookGetNthPage , notebookGetNPages ) -import GI.Pango (FontDescription) +import GI.Pango (FontDescription, fontDescriptionGetSize, fontDescriptionGetSizeIsAbsolute, pattern SCALE, fontDescriptionGetFamily, fontDescriptionNew, fontDescriptionSetFamily, fontDescriptionSetSize, fontDescriptionSetAbsoluteSize) import GI.Vte (Terminal, CursorBlinkMode(..)) -import Text.Pretty.Simple (pPrint) -import Text.Show (ShowS, showParen, showString) - import Termonad.Gtk (widgetEq) +import Termonad.IdMap (IdMap, IdMapKey, singletonIdMap, lookupIdMap) +import Text.Pretty.Simple (pPrint) -- | A wrapper around a VTE 'Terminal'. This also stores the process ID of the -- process running on this terminal, as well as a 'Unique' that can be used for @@ -107,12 +107,71 @@ showsPrec (d + 1) tmNotebookTabs . showString "}" +getNotebookFromTMState :: TMState -> TMWindowId -> IO Notebook +getNotebookFromTMState mvarTMState tmWinId = do + tmNote <- getTMNotebookFromTMState mvarTMState tmWinId + pure $ tmNotebook tmNote + +getNotebookFromTMState' :: TMState' -> TMWindowId -> IO Notebook +getNotebookFromTMState' tmState tmWinId = do + tmNote <- getTMNotebookFromTMState' tmState tmWinId + pure $ tmNotebook tmNote + +getTMNotebookFromTMState :: TMState -> TMWindowId -> IO TMNotebook +getTMNotebookFromTMState mvarTMState tmWinId = do + tmWin <- getTMWindowFromTMState mvarTMState tmWinId + pure $ tmWindowNotebook tmWin + +getTMNotebookFromTMState' :: TMState' -> TMWindowId -> IO TMNotebook +getTMNotebookFromTMState' tmState tmWinId = do + tmWin <- getTMWindowFromTMState' tmState tmWinId + pure $ tmWindowNotebook tmWin + +data TMWindow = TMWindow + { tmWindowAppWin :: !ApplicationWindow + , tmWindowNotebook :: !TMNotebook + } + +instance Show TMWindow where + showsPrec :: Int -> TMWindow -> ShowS + showsPrec d TMWindow{..} = + showParen (d > 10) $ + showString "TMWindow {" . + showString "tmWindowAppWin = " . + showString "(GI.GTK.ApplicationWindow)" . + showString ", " . + showString "tmWindowNotebook = " . + showsPrec (d + 1) tmWindowNotebook . + showString "}" + +type TMWindowId = IdMapKey + +-- | Get a given 'TMWindow' from a set of 'TMWindow's given a 'TMWindowId'. +-- +-- This throws an error if the 'TMWindowId' can't be found within the 'IdMap'. +getTMWindowFromWins :: IdMap TMWindow -> TMWindowId -> IO TMWindow +getTMWindowFromWins tmWins tmWinId = + case lookupIdMap tmWinId tmWins of + Nothing -> error $ "getTMWindowFromWins: trying to get id " <> show tmWinId <> " from wins, but doesn't exist: " <> show tmWins + Just tmWin -> pure tmWin + +-- | Get a given 'TMWindow' froma a 'TMState' given a 'TMWindowId'. +-- +-- This throws an error if the 'TMWindowId' can't be found within the 'TMState'. +getTMWindowFromTMState :: TMState -> TMWindowId -> IO TMWindow +getTMWindowFromTMState mvarTMState tmWinId = do + TMState{tmStateWindows} <- readMVar mvarTMState + getTMWindowFromWins tmStateWindows tmWinId + +getTMWindowFromTMState' :: TMState' -> TMWindowId -> IO TMWindow +getTMWindowFromTMState' tmState tmWinId = + getTMWindowFromWins (tmStateWindows tmState) tmWinId + data TMState' = TMState { tmStateApp :: !Application - , tmStateAppWin :: !ApplicationWindow - , tmStateNotebook :: !TMNotebook - , tmStateFontDesc :: !FontDescription , tmStateConfig :: !TMConfig + , tmStateFontDesc :: !FontDescription + , tmStateWindows :: !(IdMap TMWindow) } instance Show TMState' where @@ -123,17 +182,14 @@ showString "tmStateApp = " . showString "(GI.GTK.Application)" . showString ", " . - showString "tmStateAppWin = " . - showString "(GI.GTK.ApplicationWindow)" . - showString ", " . - showString "tmStateNotebook = " . - showsPrec (d + 1) tmStateNotebook . + showString "tmStateConfig = " . + showsPrec (d + 1) tmStateConfig . showString ", " . showString "tmStateFontDesc = " . showString "(GI.Pango.FontDescription)" . showString ", " . - showString "tmStateConfig = " . - showsPrec (d + 1) tmStateConfig . + showString "tmStateWindows = " . + showsPrec (d + 1) tmStateWindows . showString "}" type TMState = MVar TMState' @@ -157,14 +213,14 @@ newTMTerm :: Terminal -> Int -> IO TMTerm newTMTerm trm pd = createTMTerm trm pd <$> newUnique -getFocusedTermFromState :: TMState -> IO (Maybe Terminal) -getFocusedTermFromState mvarTMState = +getFocusedTermFromState :: TMState -> TMWindowId -> IO (Maybe Terminal) +getFocusedTermFromState mvarTMState tmWinId = withMVar mvarTMState go where go :: TMState' -> IO (Maybe Terminal) go tmState = do - let maybeNotebookTab = - getFocusItemFL $ tmNotebookTabs $ tmStateNotebook tmState + tmNote <- getTMNotebookFromTMState' tmState tmWinId + let maybeNotebookTab = getFocusItemFL $ tmNotebookTabs tmNote pure $ fmap (term . tmNotebookTabTerm) maybeNotebookTab createTMNotebookTab :: Label -> ScrolledWindow -> TMTerm -> TMNotebookTab @@ -195,50 +251,27 @@ Nothing -> pure acc Just notePage' -> unfoldHelper (index32 + 1) (acc ++ [notePage']) -newTMState :: TMConfig -> Application -> ApplicationWindow -> TMNotebook -> FontDescription -> IO TMState -newTMState tmConfig app appWin note fontDesc = - newMVar $ - TMState - { tmStateApp = app - , tmStateAppWin = appWin - , tmStateNotebook = note - , tmStateFontDesc = fontDesc - , tmStateConfig = tmConfig - } - -newEmptyTMState :: TMConfig -> Application -> ApplicationWindow -> Notebook -> FontDescription -> IO TMState -newEmptyTMState tmConfig app appWin note fontDesc = - newMVar $ - TMState - { tmStateApp = app - , tmStateAppWin = appWin - , tmStateNotebook = createEmptyTMNotebook note - , tmStateFontDesc = fontDesc - , tmStateConfig = tmConfig - } - -newTMStateSingleTerm :: - TMConfig - -> Application - -> ApplicationWindow - -> Notebook - -> Label - -> ScrolledWindow - -> Terminal - -> Int - -> FontDescription - -> IO TMState -newTMStateSingleTerm tmConfig app appWin note label scrollWin trm pd fontDesc = do - tmTerm <- newTMTerm trm pd - let tmNoteTab = createTMNotebookTab label scrollWin tmTerm - tabs = singletonFL tmNoteTab - tmNote = createTMNotebook note tabs - newTMState tmConfig app appWin tmNote fontDesc +createTMWindow :: ApplicationWindow -> TMNotebook -> TMWindow +createTMWindow appwin notebook = + TMWindow + { tmWindowAppWin = appwin + , tmWindowNotebook = notebook + } -traceShowMTMState :: TMState -> IO () -traceShowMTMState mvarTMState = do - tmState <- readMVar mvarTMState - print tmState +newEmptyTMState :: TMConfig -> Application -> ApplicationWindow -> Notebook -> FontDescription -> IO (TMState, TMWindowId) +newEmptyTMState tmConfig app appWin note fontDesc = do + let tmnote = createEmptyTMNotebook note + tmwin = createTMWindow appWin tmnote + (tmwinId, tmwins) = singletonIdMap tmwin + tmState <- + newMVar $ + TMState + { tmStateApp = app + , tmStateConfig = tmConfig + , tmStateFontDesc = fontDesc + , tmStateWindows = tmwins + } + pure (tmState, tmwinId) ------------ -- Config -- @@ -299,6 +332,42 @@ let newUnits = oldUnits + fromIntegral i in FontSizeUnits $ if newUnits < 1 then oldUnits else newUnits +fontSizeFromFontDescription :: FontDescription -> IO FontSize +fontSizeFromFontDescription fontDesc = do + currSize <- fontDescriptionGetSize fontDesc + currAbsolute <- fontDescriptionGetSizeIsAbsolute fontDesc + pure $ + if currAbsolute + then FontSizeUnits $ fromIntegral currSize / fromIntegral SCALE + else + let fontRatio :: Double = fromIntegral currSize / fromIntegral SCALE + in FontSizePoints $ round fontRatio + +-- | Create a 'FontDescription' from a 'FontSize' and font family. +createFontDesc + :: FontSize + -> Text + -- ^ font family + -> IO FontDescription +createFontDesc fontSz fontFam = do + fontDesc <- fontDescriptionNew + fontDescriptionSetFamily fontDesc fontFam + setFontDescSize fontDesc fontSz + pure fontDesc + +-- | Set the size of a 'FontDescription' from a 'FontSize'. +setFontDescSize :: FontDescription -> FontSize -> IO () +setFontDescSize fontDesc (FontSizePoints points) = + fontDescriptionSetSize fontDesc $ fromIntegral (points * fromIntegral SCALE) +setFontDescSize fontDesc (FontSizeUnits units) = + fontDescriptionSetAbsoluteSize fontDesc $ units * fromIntegral SCALE + +-- | Create a 'FontDescription' from the 'fontSize' and 'fontFamily' inside a 'TMConfig'. +createFontDescFromConfig :: TMConfig -> IO FontDescription +createFontDescFromConfig tmConfig = do + let fontConf = fontConfig (options tmConfig) + createFontDesc (fontSize fontConf) (fontFamily fontConf) + -- | Settings for the font to be used in Termonad. data FontConfig = FontConfig { fontFamily :: !Text @@ -318,6 +387,12 @@ , fontSize = defaultFontSize } +fontConfigFromFontDescription :: FontDescription -> IO (Maybe FontConfig) +fontConfigFromFontDescription fontDescription = do + fontSize <- fontSizeFromFontDescription fontDescription + maybeFontFamily <- fontDescriptionGetFamily fontDescription + return $ (`FontConfig` fontSize) <$> maybeFontFamily + -- | This data type represents an option that can either be 'Set' or 'Unset'. -- -- This data type is used in situations where leaving an option unset results @@ -327,7 +402,8 @@ -- supplied by the 'ColourConfig' @ConfigExtension@. By default, -- 'cursorFgColour' and 'cursorBgColour' are both 'Unset'. However, when -- 'cursorBgColour' is 'Set', 'cursorFgColour' defaults to the color of the text --- underneath. There is no way to represent this by setting 'cursorFgColour'. +-- underneath. There is no way to represent this by explicitly setting +-- 'cursorFgColour'. data Option a = Unset | Set !a deriving (Show, Read, Eq, Ord, Functor, Foldable) @@ -354,6 +430,19 @@ -- lines on the terminal to show all at once. deriving (Enum, Eq, Generic, FromJSON, Show, ToJSON) +showScrollbarToString :: ShowScrollbar -> Text +showScrollbarToString = \case + ShowScrollbarNever -> "never" + ShowScrollbarAlways -> "always" + ShowScrollbarIfNeeded -> "if-needed" + +showScrollbarFromString :: Text -> Maybe ShowScrollbar +showScrollbarFromString = \case + "never" -> Just ShowScrollbarNever + "always" -> Just ShowScrollbarAlways + "if-needed" -> Just ShowScrollbarIfNeeded + _ -> Nothing + -- | Whether or not to show the tab bar for switching tabs. data ShowTabBar = ShowTabBarNever -- ^ Never show the tab bar, even if there are multiple tabs @@ -362,6 +451,19 @@ | ShowTabBarIfNeeded -- ^ Only show the tab bar if you have multiple tabs open. deriving (Enum, Eq, Generic, FromJSON, Show, ToJSON) +showTabBarToString :: ShowTabBar -> Text +showTabBarToString = \case + ShowTabBarNever -> "never" + ShowTabBarAlways -> "always" + ShowTabBarIfNeeded -> "if-needed" + +showTabBarFromString :: Text -> Maybe ShowTabBar +showTabBarFromString = \case + "never" -> Just ShowTabBarNever + "always" -> Just ShowTabBarAlways + "if-needed" -> Just ShowTabBarIfNeeded + _ -> Nothing + -- | Configuration options for Termonad. -- -- See 'defaultConfigOptions' for the default values. @@ -424,6 +526,20 @@ -- doesn't look good when bold. } deriving (Eq, Generic, FromJSON, Show, ToJSON) +cursorBlinkModeToString :: CursorBlinkMode -> Text +cursorBlinkModeToString = \case + CursorBlinkModeSystem -> "system" + CursorBlinkModeOn -> "on" + CursorBlinkModeOff -> "off" + AnotherCursorBlinkMode _ -> "other" + +cursorBlinkModeFromString :: Text -> Maybe CursorBlinkMode +cursorBlinkModeFromString = \case + "system" -> Just CursorBlinkModeSystem + "on" -> Just CursorBlinkModeOn + "off" -> Just CursorBlinkModeOff + _ -> Nothing + instance FromJSON CursorBlinkMode where parseJSON = withText "CursorBlinkMode" $ \c -> do case (c :: Text) of @@ -543,32 +659,36 @@ -- the actual GTK 'Notebook' and the 'FocusList'. deriving (Show) -data TMStateInvariantErr +-- | An invariant error on a given 'TMWindow'. +data TMWinInvariantErr = FocusNotSame FocusNotSameErr Int | TabsDoNotMatch TabsDoNotMatch deriving Show --- | Gather up the invariants for 'TMState' and return them as a list. --- --- If no invariants have been violated, then this function should return an --- empty list. -invariantTMState' :: TMState' -> IO [TMStateInvariantErr] -invariantTMState' tmState = +-- | An invariant error on a whole 'TMState'. +data TMStateInvariantErr + = TMWinInvariantErr Int TMWinInvariantErr + -- ^ An invariant error with a given 'TMWindow'. The 'Int' indicates + -- which window it is as an index into 'tmStateWindows'. + deriving Show + +invariantTMWindow :: TMWindow -> IO [TMWinInvariantErr] +invariantTMWindow tmWin = runInvariants [ invariantFocusSame , invariantTMTabLength , invariantTabsAllMatch ] where - runInvariants :: [IO (Maybe TMStateInvariantErr)] -> IO [TMStateInvariantErr] + runInvariants :: [IO (Maybe TMWinInvariantErr)] -> IO [TMWinInvariantErr] runInvariants = fmap catMaybes . sequence - invariantFocusSame :: IO (Maybe TMStateInvariantErr) + invariantFocusSame :: IO (Maybe TMWinInvariantErr) invariantFocusSame = do - let tmNote = tmNotebook $ tmStateNotebook tmState + let tmNote = tmNotebook $ tmWindowNotebook tmWin index32 <- notebookGetCurrentPage tmNote maybeWidgetFromNote <- notebookGetNthPage tmNote index32 - let focusList = tmNotebookTabs $ tmStateNotebook tmState + let focusList = tmNotebookTabs $ tmWindowNotebook tmWin maybeScrollWinFromFL = tmNotebookTabTermContainer <$> getFocusItemFL focusList idx = fromIntegral index32 @@ -591,12 +711,12 @@ Just $ FocusNotSame NotebookTabWidgetDiffersFromFocusListFocus idx - invariantTMTabLength :: IO (Maybe TMStateInvariantErr) + invariantTMTabLength :: IO (Maybe TMWinInvariantErr) invariantTMTabLength = do - let tmNote = tmNotebook $ tmStateNotebook tmState + let tmNote = tmNotebook $ tmWindowNotebook tmWin noteLength32 <- notebookGetNPages tmNote let noteLength = fromIntegral noteLength32 - focusListLength = lengthFL $ tmNotebookTabs $ tmStateNotebook tmState + focusListLength = lengthFL $ tmNotebookTabs $ tmWindowNotebook tmWin lengthEqual = focusListLength == noteLength if lengthEqual then pure Nothing @@ -606,10 +726,10 @@ TabLengthsDifferent noteLength focusListLength -- Turns a FocusList and Notebook into two lists of widgets and compares each widget for equality - invariantTabsAllMatch :: IO (Maybe TMStateInvariantErr) + invariantTabsAllMatch :: IO (Maybe TMWinInvariantErr) invariantTabsAllMatch = do - let tmNote = tmNotebook $ tmStateNotebook tmState - focusList = tmNotebookTabs $ tmStateNotebook tmState + let tmNote = tmNotebook $ tmWindowNotebook tmWin + focusList = tmNotebookTabs $ tmWindowNotebook tmWin flList = tmNotebookTabTermContainer <$> toList focusList noteList <- notebookToList tmNote tabsMatch noteList flList @@ -619,16 +739,30 @@ . (IsWidget a, IsWidget b) => [a] -> [b] - -> IO (Maybe TMStateInvariantErr) + -> IO (Maybe TMWinInvariantErr) tabsMatch xs ys = foldr go (pure Nothing) (zip3 xs ys [0..]) where - go :: (a, b, Int) -> IO (Maybe TMStateInvariantErr) -> IO (Maybe TMStateInvariantErr) + go :: (a, b, Int) -> IO (Maybe TMWinInvariantErr) -> IO (Maybe TMWinInvariantErr) go (x, y, i) acc = do isEq <- widgetEq x y if isEq then acc else pure . Just $ TabsDoNotMatch (TabAtIndexDifferent i) +-- | Gather up the invariants for 'TMState' and return them as a list. +-- +-- If no invariants have been violated, then this function should return an +-- empty list. +invariantTMState' :: TMState' -> IO [TMStateInvariantErr] +invariantTMState' tmState = do + let tmWindows = tmStateWindows tmState + ifoldMap go tmWindows + where + go :: Int -> TMWindow -> IO [TMStateInvariantErr] + go idx tmWin = do + tmWinErrs <- invariantTMWindow tmWin + pure $ fmap (TMWinInvariantErr idx) tmWinErrs + -- | Check the invariants for 'TMState', and call 'fail' if we find that they -- have been violated. assertInvariantTMState :: TMState -> IO () @@ -650,3 +784,8 @@ pPrintTMState mvarTMState = do tmState <- readMVar mvarTMState pPrint tmState + +traceShowMTMState :: TMState -> IO () +traceShowMTMState mvarTMState = do + tmState <- readMVar mvarTMState + print tmState diff --git a/src/Termonad/Window.hs b/src/Termonad/Window.hs new file mode 100644 --- /dev/null +++ b/src/Termonad/Window.hs @@ -0,0 +1,386 @@ + +module Termonad.Window where + +import Termonad.Prelude + +import Control.Lens ((^.), (^..), set, view, ix) +import Data.FocusList (focusList, moveFromToFL, updateFocusFL) +import Data.Sequence (findIndexR) +import qualified Data.Text as Text +import GI.Gdk (castTo, managedForeignPtr) +import GI.Gio + ( actionMapAddAction + , onSimpleActionActivate + , simpleActionNew + ) +import GI.Gtk + ( Application + , ApplicationWindow + , Notebook + , PositionType(PositionTypeRight) + , ResponseType(ResponseTypeNo, ResponseTypeYes) + , ScrolledWindow(ScrolledWindow) + , Widget + , aboutDialogNew + , applicationSetAccelsForAction + , containerAdd + , dialogAddButton + , dialogGetContentArea + , dialogNew + , dialogResponse + , dialogRun + , entryGetText + , entryNew + , gridAttachNextTo + , gridNew + , labelNew + , onEntryActivate + , onNotebookPageReordered + , onNotebookSwitchPage + , setWidgetMargin + , widgetDestroy + , widgetGrabFocus + , widgetShow + , windowSetTransientFor + ) +import GI.Pango (FontDescription) +import GI.Vte + ( catchRegexError + , regexNewForSearch + , terminalCopyClipboard + , terminalPasteClipboard + , terminalSearchFindNext + , terminalSearchFindPrevious + , terminalSearchSetRegex + , terminalSearchSetWrapAround + , terminalSetFont + ) +import Termonad.Keys (handleKeyPress) +import Termonad.Lenses + ( lensTMNotebookTabs + , lensTMNotebookTabTerm + , lensTMStateFontDesc + , lensTerm + , lensTMStateWindows + , lensTMWindowNotebook + ) +import Termonad.Term + ( createTerm + , relabelTabs + , termNextPage + , termPrevPage + , termExitFocused + ) +import Termonad.Types + ( FontSize + , TMNotebookTab + , TMState + , TMWindowId + , fontSizeFromFontDescription + , getFocusedTermFromState + , getTMNotebookFromTMState + , getTMNotebookFromTMState' + , getTMWindowFromTMState + , setFontDescSize + , tmNotebookTabTermContainer + , tmNotebookTabs + , tmWindowAppWin + ) + +modifyFontSizeForAllTerms :: (FontSize -> FontSize) -> TMState -> TMWindowId -> IO () +modifyFontSizeForAllTerms modFontSizeFunc mvarTMState tmWinId = do + tmState <- readMVar mvarTMState + let fontDesc = tmState ^. lensTMStateFontDesc + adjustFontDescSize modFontSizeFunc fontDesc + let terms = + tmState ^.. + lensTMStateWindows . + ix tmWinId . + lensTMWindowNotebook . + lensTMNotebookTabs . + traverse . + lensTMNotebookTabTerm . + lensTerm + foldMap (\vteTerm -> terminalSetFont vteTerm (Just fontDesc)) terms + where + adjustFontDescSize :: (FontSize -> FontSize) -> FontDescription -> IO () + adjustFontDescSize f fontDesc = do + currFontSz <- fontSizeFromFontDescription fontDesc + let newFontSz = f currFontSz + setFontDescSize fontDesc newFontSz + +-- | This is the callback for when a page in a 'Notebook' has been reordered +-- (normally caused by a drag-and-drop event). +notebookPageReorderedCallback + :: TMState + -> TMWindowId + -> Widget + -- ^ The child widget that is in the Notebook page. + -> Word32 + -- ^ The new index of the Notebook page. + -> IO () +notebookPageReorderedCallback mvarTMState tmWinId childWidg pageNum = do + maybeScrollWin <- castTo ScrolledWindow childWidg + case maybeScrollWin of + Nothing -> + fail $ + "In setupTermonad, in callback for onNotebookPageReordered, " <> + "child widget is not a ScrolledWindow.\n" <> + "Don't know how to continue.\n" + Just scrollWin -> do + tmNote <- getTMNotebookFromTMState mvarTMState tmWinId + let fl = view lensTMNotebookTabs tmNote + let maybeOldPosition = + findIndexR (compareScrolledWinAndTab scrollWin) (focusList fl) + case maybeOldPosition of + Nothing -> + fail $ + "In setupTermonad, in callback for onNotebookPageReordered, " <> + "the ScrolledWindow is not already in the FocusList.\n" <> + "Don't know how to continue.\n" + Just oldPos -> do + updateFLTabPos mvarTMState tmWinId oldPos (fromIntegral pageNum) + tmNote' <- getTMNotebookFromTMState mvarTMState tmWinId + relabelTabs tmNote' + where + compareScrolledWinAndTab :: ScrolledWindow -> TMNotebookTab -> Bool + compareScrolledWinAndTab scrollWin flTab = + let ScrolledWindow managedPtrFLTab = tmNotebookTabTermContainer flTab + foreignPtrFLTab = managedForeignPtr managedPtrFLTab + ScrolledWindow managedPtrScrollWin = scrollWin + foreignPtrScrollWin = managedForeignPtr managedPtrScrollWin + in foreignPtrFLTab == foreignPtrScrollWin + +-- | Move a 'TMNotebookTab' from one position to another. +-- +-- If the current position index is out of bounds, or the new index is out of +-- bounds, then nothing will be done. +-- +-- Note that this function doesn't change anything about the 'tmNotebook'. +-- This function is meant to be used as a call-back for when a 'Notebook's +-- tab-order has been changed. +updateFLTabPos + :: TMState + -> TMWindowId + -> Int + -- ^ Current position index. + -> Int + -- ^ New position index. + -> IO () +updateFLTabPos mvarTMState tmWinId oldPos newPos = + modifyMVar_ mvarTMState $ \tmState -> do + note <- getTMNotebookFromTMState' tmState tmWinId + let tabs = tmNotebookTabs note + maybeNewTabs = moveFromToFL oldPos newPos tabs + case maybeNewTabs of + Nothing -> do + putStrLn $ + "in updateFLTabPos, Strange error: couldn't move tabs.\n" <> + "old pos: " <> show oldPos <> "\n" <> + "new pos: " <> show newPos <> "\n" <> + "tabs: " <> show tabs <> "\n" <> + "maybeNewTabs: " <> show maybeNewTabs <> "\n" <> + "tmState: " <> show tmState + pure tmState + Just newTabs -> + pure $ + set + (lensTMStateWindows . ix tmWinId . lensTMWindowNotebook . lensTMNotebookTabs) + newTabs + tmState + +showAboutDialog :: ApplicationWindow -> IO () +showAboutDialog win = do + aboutDialog <- aboutDialogNew + windowSetTransientFor aboutDialog (Just win) + void $ dialogRun aboutDialog + widgetDestroy aboutDialog + +showFindDialog :: ApplicationWindow -> IO (Maybe Text) +showFindDialog win = do + dialog <- dialogNew + box <- dialogGetContentArea dialog + grid <- gridNew + + searchForLabel <- labelNew (Just "Search for regex:") + containerAdd grid searchForLabel + widgetShow searchForLabel + setWidgetMargin searchForLabel 10 + + searchEntry <- entryNew + gridAttachNextTo grid searchEntry (Just searchForLabel) PositionTypeRight 1 1 + widgetShow searchEntry + setWidgetMargin searchEntry 10 + -- setWidgetMarginBottom searchEntry 20 + void $ + onEntryActivate searchEntry $ + dialogResponse dialog (fromIntegral (fromEnum ResponseTypeYes)) + + void $ + dialogAddButton + dialog + "Close" + (fromIntegral (fromEnum ResponseTypeNo)) + void $ + dialogAddButton + dialog + "Find" + (fromIntegral (fromEnum ResponseTypeYes)) + + containerAdd box grid + widgetShow grid + windowSetTransientFor dialog (Just win) + res <- dialogRun dialog + + searchString <- entryGetText searchEntry + let maybeSearchString = + case toEnum (fromIntegral res) of + ResponseTypeYes -> Just searchString + _ -> Nothing + + widgetDestroy dialog + + pure maybeSearchString + +doFind :: TMState -> TMWindowId -> IO () +doFind mvarTMState tmWinId = do + tmWin <- getTMWindowFromTMState mvarTMState tmWinId + let win = tmWindowAppWin tmWin + maybeSearchString <- showFindDialog win + -- putStrLn $ "trying to find: " <> tshow maybeSearchString + maybeTerminal <- getFocusedTermFromState mvarTMState tmWinId + case (maybeSearchString, maybeTerminal) of + (Just searchString, Just terminal) -> do + -- TODO: Figure out how to import the correct pcre flags. + -- + -- If you don't pass the pcre2Multiline flag, VTE gives + -- the following warning: + -- + -- (termonad-linux-x86_64:18792): Vte-WARNING **: + -- 21:56:31.193: (vtegtk.cc:2269):void + -- vte_terminal_search_set_regex(VteTerminal*, + -- VteRegex*, guint32): runtime check failed: + -- (regex == nullptr || + -- _vte_regex_get_compile_flags(regex) & PCRE2_MULTILINE) + -- + -- However, if you do add the pcre2Multiline flag, + -- the terminalSearchSetRegex appears to just completely + -- not work. + let pcreFlags = 0 + let newRegex = + regexNewForSearch + searchString + (fromIntegral $ Text.length searchString) + pcreFlags + eitherRegex <- + catchRegexError + (fmap Right newRegex) + (\_ errMsg -> pure (Left errMsg)) + case eitherRegex of + Left errMsg -> do + let msg = "error when creating regex: " <> errMsg + hPutStrLn stderr msg + Right regex -> do + terminalSearchSetRegex terminal (Just regex) pcreFlags + terminalSearchSetWrapAround terminal True + _matchFound <- terminalSearchFindPrevious terminal + -- TODO: Setup an actual logging framework to show these + -- kinds of log messages. Also make a similar change in + -- findAbove and findBelow. + -- putStrLn $ "was match found: " <> tshow matchFound + pure () + _ -> pure () + +findAbove :: TMState -> TMWindowId -> IO () +findAbove mvarTMState tmWinId = do + maybeTerminal <- getFocusedTermFromState mvarTMState tmWinId + case maybeTerminal of + Nothing -> pure () + Just terminal -> do + _matchFound <- terminalSearchFindPrevious terminal + -- putStrLn $ "was match found: " <> tshow matchFound + pure () + +findBelow :: TMState -> TMWindowId -> IO () +findBelow mvarTMState tmWinId = do + maybeTerminal <- getFocusedTermFromState mvarTMState tmWinId + case maybeTerminal of + Nothing -> pure () + Just terminal -> do + _matchFound <- terminalSearchFindNext terminal + -- putStrLn $ "was match found: " <> tshow matchFound + pure () + +setupWindowCallbacks :: TMState -> Application -> ApplicationWindow -> Notebook -> TMWindowId -> IO () +setupWindowCallbacks mvarTMState app win note tmWinId = do + + void $ onNotebookSwitchPage note $ \_ pageNum -> do + modifyMVar_ mvarTMState $ \tmState -> do + tmNote <- getTMNotebookFromTMState' tmState tmWinId + let tabs = tmNotebookTabs tmNote + maybeNewTabs = updateFocusFL (fromIntegral pageNum) tabs + case maybeNewTabs of + Nothing -> pure tmState + Just (tab, newTabs) -> do + widgetGrabFocus $ tab ^. lensTMNotebookTabTerm . lensTerm + pure $ + set + (lensTMStateWindows . ix tmWinId . lensTMWindowNotebook . lensTMNotebookTabs) + newTabs + tmState + + void $ onNotebookPageReordered note $ \childWidg pageNum -> + notebookPageReorderedCallback mvarTMState tmWinId childWidg pageNum + + newTabAction <- simpleActionNew "newtab" Nothing + void $ onSimpleActionActivate newTabAction $ \_ -> + void $ createTerm handleKeyPress mvarTMState tmWinId + actionMapAddAction win newTabAction + applicationSetAccelsForAction app "win.newtab" ["T"] + + nextPageAction <- simpleActionNew "nextpage" Nothing + void $ onSimpleActionActivate nextPageAction $ \_ -> + termNextPage mvarTMState tmWinId + actionMapAddAction win nextPageAction + applicationSetAccelsForAction app "win.nextpage" ["Page_Down"] + + prevPageAction <- simpleActionNew "prevpage" Nothing + void $ onSimpleActionActivate prevPageAction $ \_ -> + termPrevPage mvarTMState tmWinId + actionMapAddAction win prevPageAction + applicationSetAccelsForAction app "win.prevpage" ["Page_Up"] + + closeTabAction <- simpleActionNew "closetab" Nothing + void $ onSimpleActionActivate closeTabAction $ \_ -> + termExitFocused mvarTMState tmWinId + actionMapAddAction win closeTabAction + applicationSetAccelsForAction app "win.closetab" ["W"] + + copyAction <- simpleActionNew "copy" Nothing + void $ onSimpleActionActivate copyAction $ \_ -> do + maybeTerm <- getFocusedTermFromState mvarTMState tmWinId + maybe (pure ()) terminalCopyClipboard maybeTerm + actionMapAddAction win copyAction + applicationSetAccelsForAction app "win.copy" ["C"] + + pasteAction <- simpleActionNew "paste" Nothing + void $ onSimpleActionActivate pasteAction $ \_ -> do + maybeTerm <- getFocusedTermFromState mvarTMState tmWinId + maybe (pure ()) terminalPasteClipboard maybeTerm + actionMapAddAction win pasteAction + applicationSetAccelsForAction app "win.paste" ["V"] + + findAction <- simpleActionNew "find" Nothing + void $ onSimpleActionActivate findAction $ \_ -> doFind mvarTMState tmWinId + actionMapAddAction win findAction + applicationSetAccelsForAction app "win.find" ["F"] + + findAboveAction <- simpleActionNew "findabove" Nothing + void $ onSimpleActionActivate findAboveAction $ \_ -> findAbove mvarTMState tmWinId + actionMapAddAction win findAboveAction + applicationSetAccelsForAction app "win.findabove" ["P"] + + findBelowAction <- simpleActionNew "findbelow" Nothing + void $ onSimpleActionActivate findBelowAction $ \_ -> findBelow mvarTMState tmWinId + actionMapAddAction win findBelowAction + applicationSetAccelsForAction app "win.findbelow" ["I"] diff --git a/src/Termonad/XML.hs b/src/Termonad/XML.hs --- a/src/Termonad/XML.hs +++ b/src/Termonad/XML.hs @@ -7,6 +7,8 @@ import Data.Default (def) import Data.FileEmbed (embedFile) +import Data.Text.Encoding (decodeUtf8) +import qualified Data.Text.Lazy as LText import Text.XML (renderText) import Text.XML.QQ (Document, xmlRaw) @@ -23,7 +25,7 @@ - Example Application + Termonad 600 400 @@ -42,7 +44,7 @@ |] interfaceText :: Text -interfaceText = toStrict $ renderText def interfaceDoc +interfaceText = LText.toStrict $ renderText def interfaceDoc menuDoc :: Document menuDoc = @@ -54,15 +56,24 @@ File
+ + + New _Tab - app.newtab + win.newtab
_Close Tab - app.closetab + win.closetab _Quit @@ -74,11 +85,11 @@ Edit _Copy - app.copy + win.copy _Paste - app.paste + win.paste _Preferences @@ -100,15 +111,15 @@ Search _Find... - app.find + win.find Find Above - app.findabove + win.findabove Find Below - app.findbelow + win.findbelow @@ -123,7 +134,7 @@ |] menuText :: Text -menuText = toStrict $ renderText def menuDoc +menuText = LText.toStrict $ renderText def menuDoc aboutDoc :: Document aboutDoc = @@ -201,7 +212,7 @@ |] aboutText :: Text -aboutText = toStrict $ renderText def aboutDoc +aboutText = LText.toStrict $ renderText def aboutDoc closeTabDoc :: Document closeTabDoc = @@ -258,7 +269,7 @@ |] closeTabText :: Text -closeTabText = toStrict $ renderText def closeTabDoc +closeTabText = LText.toStrict $ renderText def closeTabDoc preferencesText :: Text preferencesText = decodeUtf8 $(embedFile "glade/preferences.glade") diff --git a/termonad.cabal b/termonad.cabal --- a/termonad.cabal +++ b/termonad.cabal @@ -1,5 +1,5 @@ name: termonad -version: 4.5.0.0 +version: 4.6.0.0 synopsis: Terminal emulator configurable in Haskell description: Termonad is a terminal emulator configurable in Haskell. It is extremely @@ -28,13 +28,13 @@ , glade/preferences.glade , glade/README.md , img/termonad.png - , .nix-helpers/nixops.nix + , img/termonad-lambda.png + , .nix-helpers/nixos-vm.nix , .nix-helpers/nixpkgs.nix , .nix-helpers/overlays.nix , .nix-helpers/stack-shell.nix , .nix-helpers/termonad-with-packages.nix , shell.nix -data-files: img/termonad-lambda.png custom-setup -- Hackage apparently gives an error if you don't specify an -- upper bound on your setup-depends. But I don't want to @@ -59,33 +59,37 @@ hs-source-dirs: src exposed-modules: Termonad , Termonad.App + , Termonad.Cli , Termonad.Config , Termonad.Config.Colour , Termonad.Gtk + , Termonad.IdMap + , Termonad.IdMap.Internal , Termonad.Keys , Termonad.Lenses , Termonad.Pcre - , Termonad.PreferencesFile + , Termonad.Preferences + , Termonad.Preferences.File , Termonad.Prelude + , Termonad.Startup , Termonad.Term , Termonad.Types + , Termonad.Window , Termonad.XML other-modules: Paths_termonad build-depends: base >= 4.13 && < 5 - , adjunctions , aeson - , classy-prelude + , bytestring , colour - , constraints , containers , data-default , directory >= 1.3.1.0 - , distributive - , dyre + , dyre >= 0.9 , file-embed , filepath , focuslist , gi-gdk + , gi-gdkpixbuf , gi-gio , gi-glib , gi-gtk >= 3.0.24 @@ -94,9 +98,8 @@ , haskell-gi-base >= 0.21.2 , inline-c , lens - , mono-traversable + , optparse-applicative , pretty-simple - , QuickCheck , text , transformers , unordered-containers @@ -104,7 +107,7 @@ , xml-html-qq , yaml default-language: Haskell2010 - ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wunused-packages default-extensions: DataKinds , DefaultSignatures , DeriveAnyClass @@ -167,15 +170,8 @@ main-is: Test.hs hs-source-dirs: test build-depends: base - , genvalidity-containers - , genvalidity-hspec - , hedgehog - , lens - , QuickCheck , termonad , tasty - , tasty-hedgehog - , tasty-hspec default-language: Haskell2010 ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -threaded -rtsopts -with-rtsopts=-N default-extensions: DataKinds diff --git a/test/readme/README.lhs b/test/readme/README.lhs --- a/test/readme/README.lhs +++ b/test/readme/README.lhs @@ -292,35 +292,34 @@ Termonad is similar to XMonad. The above steps will install a `termonad` binary somewhere on your system. If you have installed Termonad using `stack`, the -`termonad` binary will be in `~/.local/bin/`. This binary is a version of -Termonad configured with default settings. You can try running it to get an idea -of what Termonad is like: +`termonad` binary will be in `~/.local/bin/`. If you have installed Termonad using +your Linux distro, the `termonad` binary will likely be in `/usr/bin/`. This +binary is a version of Termonad configured with default settings. You can try +running it to get an idea of what Termonad is like: ```sh -$ ~/.local/bin/termonad +$ /usr/bin/termonad ``` -The following section describes the default key bindings. - If you would like to configure Termonad with your own settings, first you will need to create a Haskell file called `~/.config/termonad/termonad.hs`. A following section gives an example configuration file. -If this configuration file exists, when the `~/.local/bin/termonad` binary +If this configuration file exists, when the `/usr/bin/termonad` binary launches, it will try to use GHC to compile the configuration file. If GHC is able to successfully compile the configuration file, a separate binary will be created called something like `~/.cache/termonad/termonad-linux-x86_64`. This binary file can be thought of as your own personal Termonad, configured with all your own settings. -When you run `~/.local/bin/termonad`, it will re-exec +When you run `/usr/bin/termonad`, it will re-exec `~/.cache/termonad/termonad-linux-x86_64` if it exists. However, there is one difficulty with this setup. In order for the -`~/.local/bin/termonad` binary to be able to compile your +`/usr/bin/termonad` binary to be able to compile your `~/.config/termonad/termonad.hs` configuration file, Termonad needs to know where GHC is, as well as where all your Haskell packages live. This presents -some difficulties that will be discussed in a following section. +some difficulties that will be discussed in one of the following sections. ### Default Key Bindings @@ -341,31 +340,40 @@ ### Configuring Termonad -Termonad has two different ways to be configured. +Termonad has three different ways to be configured. -The first way is to use the built-in Preferences editor. You can find this in -the `Preferences` menu under `Edit` in the menubar. +1. Pass arguments on the command line. For instance, run + `termonad --no-show-menu` to never show the `File` menubar. -When opening Termonad for the first time, it will create a preferences file at -`~/.config/termonad/termonad.yaml`. When you change a setting in the -Preferences editor, Termonad will update the setting in the preferences file. + Arguments passed on the command line will normally override other + configuration methods. -When running Termonad, it will load settings from the preferences file. -Do not edit the preferences file by hand, because it will be overwritten when -updating settings in the Preferences editor. +2. Use the built-in Preferences editor. You can find this in + the `Preferences` menu under `Edit` in the menubar. -This method is perfect for users who only want to make small changes to the -Termonad settings, like the default font size. + When opening Termonad for the first time, it will create a preferences file + at `~/.config/termonad/termonad.yaml`. When you change a setting in the + Preferences editor, Termonad will update the setting in the preferences + file. -The second way to configure Termonad is to use a Haskell-based settings file, -called `~/.config/termonad/termonad.hs` by default. This method allows you to -make large, sweeping changes to Termonad. This method is recommended for power -users. + When running Termonad, it will load settings from the preferences file. Do + not edit the preferences file by hand, because it will be overwritten when + updating settings in the Preferences editor. + This method is perfect for users who only want to make small changes to the + Termonad settings, like the default font size. + +3. Use a Haskell-based settings file, called `~/.config/termonad/termonad.hs` by default. + This method allows you to make large, sweeping changes to Termonad. This + method is recommended for power users. + + The rest of this section explains the `~/.config/termonad/termonad.hs` file. + **WARNING: If you have a `~/.config/termonad/termonad.hs` file, then all settings from `~/.config/termonad/termonad.yaml` will be ignored. If you want to set *ANY* settings in `~/.config/termonad/termonad.hs`, then you must -set *ALL* settings in `~/.config/termonad/termonad.hs`.** +set *ALL* settings in `~/.config/termonad/termonad.hs`. However, as stated above, +CLI arguments will override settings in `~/.config/termonad/termonad.hs` by default.** The following is an example Termonad configuration file. You should save this to `~/.config/termonad/termonad.hs`. You can find more information on the available @@ -378,11 +386,11 @@ module Main where -import Termonad.App (defaultMain) -import Termonad.Config +import Termonad ( FontConfig, FontSize(FontSizePoints), Option(Set) , ShowScrollbar(ShowScrollbarAlways), defaultConfigOptions, defaultFontConfig - , defaultTMConfig, fontConfig, fontFamily, fontSize, options, showScrollbar + , defaultMain, defaultTMConfig, fontConfig, fontFamily, fontSize, options + , showScrollbar ) import Termonad.Config.Colour ( AlphaColour, ColourConfig, addColourExtension, createColour @@ -439,9 +447,9 @@ ### Compiling Local Settings -If you launch Termonad by calling `~/.local/bin/termonad`, it will try to +If you launch Termonad by calling `/usr/bin/termonad`, it will try to compile the `~/.config/termonad/termonad.hs` file if it exists. The problem is -that `~/.local/bin/termonad` needs to be able to see GHC and the required +that `/usr/bin/termonad` needs to be able to see GHC and the required Haskell libraries to be able to compile `~/.config/termonad/termonad.hs`. There are a couple solutions to this problem, listed in the sections below. @@ -452,9 +460,10 @@ #### Running with `stack` -If you originally compiled Termonad with `stack`, you can use `stack` to -execute Termonad. First, you must change to the directory with the Termonad -source code. From there, you can run `stack exec`: +If you originally compiled Termonad with `stack` and installed it to +`~/.local/bin/termonad`, you can use `stack` to execute Termonad. First, you +must change to the directory with the Termonad source code. From there, you +can run `stack exec`: ```sh $ cd termonad/ # change to the termonad source code directory