diff --git a/.nix-helpers/nixpkgs.nix b/.nix-helpers/nixpkgs.nix --- a/.nix-helpers/nixpkgs.nix +++ b/.nix-helpers/nixpkgs.nix @@ -1,11 +1,96 @@ -# This file pins the version of nixpkgs to a known good version. -# It is imported from various other files. +# This file pins the version of nixpkgs to a known good version. The nixpkgs is +# imported with an overlay overriding haskellPackages to generate haddocks for +# GI dependencies, and to use the GHC, VTE, GTK and open-haddock versions we +# want. It is imported from various other files. +{ compiler ? null, nixpkgs ? null }: + let - nixpkgsTarball = builtins.fetchTarball { - # recent version of nixpkgs as of 2018-07-29 - url = "https://github.com/NixOS/nixpkgs/archive/a2c6dbe370160ffea5537f64dda04489184c5ce1.tar.gz"; - sha256 = "1x993g9343yv5wyp29i6vskdcc3rl42xipv79nwmmrj8ay2yhh3b"; + # recent version of nixpkgs as of 2018-11-09 + nixpkgsSrc = + if isNull nixpkgs + then + builtins.fetchTarball { + url = "https://github.com/NixOS/nixpkgs/archive/237285295764fb063ec1ca509c36b17c4990eeb4.tar.gz"; + sha256 = "1cl40yz7ry6x2nbzpc5pkf0q5p0fxvi0c2n7la0pz5g1n80n4xlq"; + } + else + nixpkgs; + + compilerVersion = if isNull compiler then "ghc844" else compiler; + + # The termonad derivation is generated automatically with `cabal2nix`. + termonadOverride = + stdenvLib: gnome3: callCabal2nix: overrideCabal: + let + src = + builtins.filterSource + (path: type: with stdenvLib; + ! elem (baseNameOf path) [ ".git" "result" ".stack-work" ] && + ! any (flip hasPrefix (baseNameOf path)) [ "dist" ".ghc" ] + ) + ./..; + termonad = callCabal2nix "termonad" src { + inherit (gnome3) gtk3; + }; + in + overrideCabal termonad (oldAttrs: { + # For some reason the doctests fail when running with nix. + # https://github.com/cdepillabout/termonad/issues/15 + doCheck = false; + }); + + myfocuslist = callCabal2nix: + let + src = builtins.fetchTarball { + url = "https://github.com/cdepillabout/focuslist/archive/80bd865e82ab4499ccebcd89989d2dbb221bb381.tar.gz"; + sha256 = "1b7da9ngk34jc2w4hhqq6qv20pkch5vvi34kr81xpmr3mmiwqmai"; + }; + in callCabal2nix "focuslist" src {}; + + gobjIntroOverride = oldAttrs: { + patches = oldAttrs.patches ++ [ ./macos-gobject-introspection-rpath.patch ]; }; -in -import nixpkgsTarball { } + + haskellPackagesOL = self: super: with super.haskell.lib; { + haskellPackages = super.haskell.packages.${compilerVersion}.override { + overrides = hself: hsuper: { + # Only override the version of foculist if it doesn't already exist in + # the haskell package set. + focuslist = hsuper.focuslist or (myfocuslist hself.callCabal2nix); + + # Set the haskell-gi libraries to generate documentation. + gi-gdk = doHaddock hsuper.gi-gdk; + gi-gio = doHaddock hsuper.gi-gio; + gi-glib = doHaddock hsuper.gi-glib; + gi-gtk = doHaddock hsuper.gi-gtk; + gi-pango = doHaddock hsuper.gi-pango; + gi-vte = doHaddock hsuper.gi-vte; + + termonad = termonadOverride self.stdenv.lib self.gnome3 hself.callCabal2nix self.haskell.lib.overrideCabal; + + # This is a tool to use to easily open haddocks in the browser. + open-haddock = hsuper.open-haddock.overrideAttrs (oa: { + src = super.fetchFromGitHub { + owner = "jml"; + repo = "open-haddock"; + rev = "472d10d61d7b9262626171af0484a65365863fa6"; + sha256 = "072d680j1k3n0vkzsbghhnah2p799yxrm7mhvr0nkdvr7iy04gcz"; + }; + }); + }; + }; + + # Darwin needs a patch to gobject-introspection: + # https://github.com/NixOS/nixpkgs/pull/46310 + gobjectIntrospection = super.gobjectIntrospection.overrideAttrs (oldAttrs: { + patches = + oldAttrs.patches ++ + (if self.stdenv.isDarwin + then [ ./macos-gobject-introspection-rpath.patch ] + else [ ]); + }); + }; + +in import nixpkgsSrc { overlays = [ haskellPackagesOL ]; } + diff --git a/.nix-helpers/running-termonad.nix b/.nix-helpers/running-termonad.nix deleted file mode 100644 --- a/.nix-helpers/running-termonad.nix +++ /dev/null @@ -1,26 +0,0 @@ -# Running `nix-shell .nix-helpers/running-termonad.nix` will put us in an environment -# with termonad available, as well as GHC and a few other packages (lens and colour). -# -# If you run `termonad` while in this environment, `termonad` should be able to see -# GHC and all the Haskell libraries listed below. This will let `termonad` be able to -# recompile the `~/.config/termonad/termonad.hs` file. -# -# This file is really only used when you want to run termonad in an environment where it -# has access to specific libraries. - -{ compiler ? "ghc843" }: - -let - nixpkgs = import ./nixpkgs.nix; - - termonad = nixpkgs.callPackage ../. { inherit compiler; }; - - ghcStuff = nixpkgs.pkgs.haskell.packages.${compiler}.ghcWithPackages (pkgs: [ - pkgs.colour - pkgs.lens - termonad - ]); - -in - -nixpkgs.runCommand "dummy" { buildInputs = [ ghcStuff termonad ]; } "" diff --git a/.nix-helpers/stack-nix-shell.nix b/.nix-helpers/stack-nix-shell.nix --- a/.nix-helpers/stack-nix-shell.nix +++ b/.nix-helpers/stack-nix-shell.nix @@ -1,21 +1,22 @@ # This is the shell file specified in the stack.yaml file. -# This forces stack to use ghc-8.0.2 and stack-lts-9.yaml to compile termonad. +# This runs stack commands in an environment created with nix. let + # recent version of nixpkgs as of 2018-10-17 nixpkgsTarball = builtins.fetchTarball { - # 17.09 (this works) - #url = "https://github.com/NixOS/nixpkgs/archive/39cd40f7bea40116ecb756d46a687bfd0d2e550e.tar.gz"; - #sha256 = "0kpx4h9p1lhjbn1gsil111swa62hmjs9g93xmsavfiki910s73sh"; + url = "https://github.com/NixOS/nixpkgs/archive/6a23e11e658b7a7a77f1b61d30d64153b46bc852.tar.gz"; + sha256 = "03n4bacfk1bbx3v0cx8xcgcmz44l0knswzh7hwih9nx0hj3x41yc"; + }; - # 18.03 - url = "https://github.com/NixOS/nixpkgs/archive/120b013e0c082d58a5712cde0a7371ae8b25a601.tar.gz"; - sha256 = "0hk4y2vkgm1qadpsm4b0q1vxq889jhxzjx3ragybrlwwg54mzp4f"; + # Fixes for individual packages. Currently none needed. + pkgFixes = self: pkgs: { + }; - # recent version of nixpkgs as of 2018-07-25 (this only seems to sometimes work...?)) - #url = "https://github.com/NixOS/nixpkgs/archive/4ccaa7de8eb34a0bb140f109a0e88095480118eb.tar.gz"; - #sha256 = "0szbxfrzmlmxrgkqz5wnfgmsjp82vaddgz7mhdz7jj0jhd0hza4i"; + nixpkgs = import nixpkgsTarball { + overlays = [ + pkgFixes + ]; }; - nixpkgs = import nixpkgsTarball { }; in with nixpkgs; @@ -24,13 +25,14 @@ name = "termonad"; buildInputs = [ cairo + git gnome3.vte gobjectIntrospection gtk3 zlib ]; - ghc = haskell.compiler.ghc802; + ghc = haskell.compiler.ghc843; extraArgs = [ - "--stack-yaml stack-lts-9.yaml" + "--stack-yaml stack-lts-12.yaml" ]; } diff --git a/.nix-helpers/termonad-with-packages.nix b/.nix-helpers/termonad-with-packages.nix new file mode 100644 --- /dev/null +++ b/.nix-helpers/termonad-with-packages.nix @@ -0,0 +1,122 @@ +# This file produces a wrapper around Termonad that will know where to find a +# GHC with the libraries needed to recompile its config file. +# +# This is not NixOS only; it should work with nix on any system. +# +# There are 4 different ways this file can be used. +# +# 1. build directly with `nix-build` +# +# This method allows you to build termonad from the command line with +# `nix-build`. This is the easiest method. +# +# You can call `nix-build` like the following: +# +# $ nix-build .nix-helpers/termonad-with-packages.nix +# +# (This is the same as just calling `nix-build` on the `../default.nix` file.) +# +# This produces a `result` directory that contains the `termonad` exectuable as +# `result/bin/termonad`. +# +# By default, you will be able to use the Haskell packages `lens` and `colour` +# in your `~/.config/termonad/termonad.hs` configuration file. +# +# If you want to use alternative Haskell packages, you can specify them on the +# command line: +# +# $ nix-build .nix-helpers/termonad-with-packages.nix \ +# --arg extraHaskellPackages 'haskellPackages: [ haskellPackages.colour haskellPackages.lens haskellPackages.pipes ]' +# +# This will make sure you can also use the Haskell packages `lens`, `colour`, and `pipes` in your +# `~/.config/termonad/termonad.hs` file. (Actually, if Termonad transitively +# depends on a library, you should be able to use it without having to specify +# it. Although you shouldn't depend on this.) +# +# 2. install with `nix-env` +# +# `nix-env` can be used to install Termonad into your environment: +# +# $ nix-env --file .nix-helpers/termonad-with-packages.nix --install +# +# If you want to specify extra Haskell packages that you can use in your +# `~/.config/termonad/termonad.hs` file, you can call `nix-env` like the +# following: +# +# $ nix-env --file .nix-helpers/termonad-with-packages.nix --install \ +# --arg extraHaskellPackages 'haskellPackages: [ haskellPackages.colour haskellPackages.lens haskellPackages.pipes ]' +# +# 3. an overlay for your user +# +# Nix makes it easy to create overlays. First, create the following file at +# `~/.config/nixpkgs/overlays/termonad.nix`: +# +# ```nix +# self: super: +# let extraHaskellPackages = hp: [ hp.colour hp.lens hp.MonadRandom ]; in +# { termonad = import /some/path/to/termonad/.nix-helpers/termonad-with-packages.nix { inherit extraHaskellPackages; }; +# } +# ``` +# +# Now Termonad can be installed through Nix's standard methods, including `nix-env`: +# +# $ nix-env --file '' --install --attr termonad +# +# 4. system-wide in /etc/nixos/configuration.nix +# +# You can set the `nixpkgs.overlays` attribute in your +# `/etc/nixos/configuration.nix` file just like in (3) above. +# +# ```nix +# { config, pkgs, ... }: +# { +# nixpkgs.overlays = [ (import /home/youruser/.config/nixpkgs/overlays/termonad.nix) ]; +# } +# ``` +# +# You can also add Termonad directly to your system packages: +# +# ```nix +# { config, pkgs, ... }: +# { +# environment.systemPackages = with pkgs; [ +# ... +# (import /some/path/to/termonad/.nix-helpers/termonad-with-packages.nix { }) +# ... +# ]; +# } +# ``` + +let + # Default Haskell packages that you can use in your Termonad configuration. + # This is only used if the user doesn't specify the extraHaskellPackages + # option. + defaultPackages = haskellPackages: with haskellPackages; [ + colour + lens + ]; +in + +{ extraHaskellPackages ? defaultPackages +, compiler ? null +, nixpkgs ? null +}: + +with (import ./nixpkgs.nix { inherit compiler nixpkgs; }); + +let + ghcWithPackages = haskellPackages.ghcWithPackages; + env = ghcWithPackages (self: [ self.termonad ] ++ extraHaskellPackages self); +in + +stdenv.mkDerivation { + name = "termonad-with-packages-${env.version}"; + nativeBuildInputs = [ makeWrapper ]; + buildCommand = '' + mkdir -p $out/bin + makeWrapper ${env}/bin/termonad $out/bin/termonad \ + --set NIX_GHC "${env}/bin/ghc" + ''; + preferLocalBuild = true; + allowSubstitutes = false; +} diff --git a/.nix-helpers/termonad.nix b/.nix-helpers/termonad.nix deleted file mode 100644 --- a/.nix-helpers/termonad.nix +++ /dev/null @@ -1,34 +0,0 @@ -{ mkDerivation, base, Cabal, cabal-doctest, classy-prelude, colour -, constraints, data-default, doctest, dyre, gi-gdk, gi-gio, gi-glib -, gi-gtk, gi-pango, gi-vte, gtk3, haskell-gi-base, hedgehog, lens -, pretty-simple, QuickCheck, stdenv, tasty, tasty-hedgehog -, template-haskell, xml-conduit, xml-html-qq -}: -mkDerivation { - pname = "termonad"; - version = "0.2.0.0"; - src = builtins.filterSource (path: type: - baseNameOf path != ".git" && - baseNameOf path != "result" && - baseNameOf path != ".stack-work" && - baseNameOf path != "dist") ./..; - isLibrary = true; - isExecutable = true; - doCheck = false; - enableSeparateDataOutput = true; - setupHaskellDepends = [ base Cabal cabal-doctest ]; - libraryHaskellDepends = [ - base classy-prelude colour constraints data-default dyre gi-gdk - gi-gio gi-glib gi-gtk gi-pango gi-vte haskell-gi-base lens - pretty-simple QuickCheck xml-conduit xml-html-qq - ]; - libraryPkgconfigDepends = [ gtk3 ]; - executableHaskellDepends = [ base ]; - testHaskellDepends = [ - base doctest hedgehog lens QuickCheck tasty tasty-hedgehog - template-haskell - ]; - homepage = "https://github.com/cdepillabout/termonad"; - description = "Terminal emulator configurable in Haskell"; - license = stdenv.lib.licenses.bsd3; -} diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,12 @@ +## 1.0.0.0 + +* The API for configuring Termonad is now completely different. Many, many + changes have gone into this version. You should approach it as a + completely different application. + + The CHANGELOG will be kept up-to-date for future releases. + ## 0.2.1.0 * Make sure the window title is set to "Termonad". diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,7 +6,9 @@ [![Hackage](https://img.shields.io/hackage/v/termonad.svg)](https://hackage.haskell.org/package/termonad) [![Stackage LTS](http://stackage.org/package/termonad/badge/lts)](http://stackage.org/lts/package/termonad) [![Stackage Nightly](http://stackage.org/package/termonad/badge/nightly)](http://stackage.org/nightly/package/termonad) -![BSD3 license](https://img.shields.io/badge/license-BSD3-blue.svg) +[![BSD3 license](https://img.shields.io/badge/license-BSD3-blue.svg)](./LICENSE) +[![Join the chat at https://gitter.im/termonad/Lobby](https://badges.gitter.im/termonad/Lobby.svg)](https://gitter.im/termonad/Lobby?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) +[![Join the chat in #termonad on irc.freenode.net](https://img.shields.io/badge/%23termonad-irc.freenode.net-brightgreen.svg)](https://webchat.freenode.net/) Termonad is a terminal emulator configurable in Haskell. It is extremely customizable and provides hooks to modify the default behavior. It can be @@ -21,15 +23,20 @@ - [Installation](#installation) - [Arch Linux](#arch-linux) - [Ubuntu / Debian](#ubuntu--debian) - - [NixOS](#nixos) + - [Nix](#nix) - [Mac OS X](#mac-os-x) + - [Installing with just `stack`](#installing-with-just-stack) + - [Installing with just `nix`](#installing-with-just-nix) + - [Installing with `stack` using `nix`](#installing-with-stack-using-nix) - [Windows](#windows) - [How to use Termonad](#how-to-use-termonad) + - [Default Keybindings](#default-keybindings) - [Configuring Termonad](#configuring-termonad) - [Compiling Local Settings](#compiling-local-settings) - [Running with `stack`](#running-with-stack) - [Running with `nix`](#running-with-nix) - [Goals](#goals) + - [Where to get help](#where-to-get-help) - [Contributions](#contributions) - [Maintainers](#maintainers) @@ -84,9 +91,11 @@ $ stack install ``` -### NixOS +### Nix -There are two methods to build Termonad on NixOS. +If you have `nix` installed, you should be able to use it to build Termonad. +This means that it will work on NixOS, or with `nix` on another distro. There +are two different ways to use `nix` to build Termonad: The first is using `stack`. The following commands install `stack` for your user, clone this repository, and install the `termonad` binary to `~/.local/bin/`: @@ -109,8 +118,68 @@ ### Mac OS X -(*currently no instructions available. please send a PR adding instructions if you get termonad to build.*) +Building and installing Termonad on Mac OS X should be possible with any of the following three methods: +- Install the required system libraries (like GTK and VTE) by hand, then use + `stack` to build Termonad. + + This is probably the easiest method. You don't have to understand anything + about `nix`. However, it is slightly annoying to have to install GTK and + VTE by hand. + +- Use `nix` to install both the required system libraries and Termonad itself. + + If you are a nix user and want an easy way to install Termonad, this + is the recommended method. + +- Use `nix` to install install the required system libraries, and `stack` to + build Termonad. + + If you are a nix user, but want to use `stack` to actually do development + on Termonad, using `stack` may be easier than using `cabal`. + +The following sections describe each method. + +#### Installing with just `stack` + +(*currently no instructions available. please send a PR adding instructions if you get termonad to build using this method.*) + +#### Installing with just `nix` + +`nix` can be used to install Termonad with the following steps, assuming you +have `nix` [installed](https://nixos.org/nix/download.html). These commands +clone this repository and build the `termonad` binary at `./result/bin/`: + +```sh +$ git clone https://github.com/cdepillabout/termonad +$ cd termonad/ +$ nix-build +``` + +#### Installing with `stack` using `nix` + +`stack` can be used in conjunction with `nix` to install Termonad. `nix` will +handle installing system dependencies (like GTK and VTE), while `stack` will +handle compiling and installing Haskell packages. + +You must have `nix` [installed](https://nixos.org/nix/download.html). + +You will also need `stack` installed. You can do that with the following command: + +```sh +$ nix-env -i stack +``` + +After `stack` is installed, you will need to clone Termonad and build it: + +``` +$ git clone https://github.com/cdepillabout/termonad +$ cd termonad/ +$ stack --nix install +``` + +This will install the `termonad` binary to `~/.local/bin/`. + ### Windows (*currently no instructions available. please send a PR adding instructions if you get termonad to build.*) @@ -127,25 +196,38 @@ $ ~/.local/bin/termonad ``` -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`. The -next section gives an example configuration file. +The following section describes the default keybindings. -If this file exists, when the `~/.local/bin/termonad` binary launches, it will -try to compile it. If it succeeds, it will create a separate binary file 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. +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 +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 `~/.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 -`~/.config/termonad/termonad.hs` file, it 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. +`~/.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. +### Default Keybindings + +Termonad provides the following default key bindings. + +| Keybinding | Action | +|------------|--------| +| Ctrl Shift t | Open new tab. | +| Ctrl Shift w | Close tab. | +| Alt (number key) | Switch to tab `number`. For example, Alt 2 switches to tab 2. | + ### Configuring Termonad The following is an example Termonad configuration file. You should save this to @@ -162,47 +244,64 @@ import Data.Colour.SRGB (Colour, sRGB24) import Termonad.App (defaultMain) import Termonad.Config - ( FontConfig, ShowScrollbar(ShowScrollbarAlways), cursorColor - , defaultFontConfig, defaultTMConfig, fontConfig, fontFamily - , fontSize, showScrollbar + ( FontConfig, FontSize(FontSizePoints), Option(Set) + , ShowScrollbar(ShowScrollbarAlways), defaultConfigOptions, defaultFontConfig + , defaultTMConfig, fontConfig, fontFamily, fontSize, options, showScrollbar ) +import Termonad.Config.Colour + (ColourConfig, addColourExtension, createColourExtension, cursorBgColour + , defaultColourConfig + ) -- | This sets the color of the cursor in the terminal. -- -- This uses the "Data.Colour" module to define a dark-red color. -- There are many default colors defined in "Data.Colour.Names". -cursColor :: Colour Double -cursColor = sRGB24 204 0 0 +cursBgColor :: Colour Double +cursBgColor = sRGB24 204 0 0 +-- | This sets the colors used for the terminal. We only specify the background +-- color of the cursor. +colConf :: ColourConfig (Colour Double) +colConf = + defaultColourConfig + { cursorBgColour = Set cursBgColor + } + -- | This defines the font for the terminal. fontConf :: FontConfig fontConf = defaultFontConfig { fontFamily = "DejaVu Sans Mono" - , fontSize = 13 + , fontSize = FontSizePoints 13 } main :: IO () main = do + colExt <- createColourExtension colConf let termonadConf = defaultTMConfig - { cursorColor = cursColor - , fontConfig = fontConf - , showScrollbar = ShowScrollbarAlways + { options = + defaultConfigOptions + { fontConfig = fontConf + -- Make sure the scrollbar is always visible. + , showScrollbar = ShowScrollbarAlways + } } + `addColourExtension` colExt defaultMain termonadConf ``` ### Compiling Local Settings -If you lauch Termonad by calling `~/.local/bin/termonad`, it will try to +If you launch Termonad by calling `~/.local/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 Haskell libraries to be able to compile `~/.config/termonad/termonad.hs`. There are a couple solutions to this problem, listed in the sections below. -(These steps are definitely confusing, and I would love to figure out a better +(These steps are definitely confusing. I would love to figure out a better way to do this. Please submit an issue or PR if you have a good idea about how to fix this.) @@ -241,33 +340,15 @@ #### Running with `nix` -If you originally compiled Termonad with `nix`, you can use `nix` to create -an environment with GHC and specified Haskell libraries available. - -There is a `.nix` file available you can use to do this: - -[`.nix-helpers/running-termonad.nix`](./.nix-helpers/running-termonad.nix) - -This file will give us an environment with `termonad`, GHC, and a few Haskell -libraries installed. You can enter this environment using `nix-shell`: - -```sh -$ cd termonad/ # change to the termonad source code directory -$ nix-shell ./.nix-helpers/running-termonad.nix -``` - -From within this environment, you can run `termonad`. It will find the -`~/.config/termonad/termonad.hs` file and compile it, outputting the -`.cache/termonad/termonad-linux-x86_64` binary. Termonad will then re-exec -this binary. +Building Termonad with `nix` (by running `nix-build` in the top +directory) sets it up so that Termonad can see GHC. Termonad should be able +to compile the `~/.config/termonad/termonad.hs` file by default. -The problem with this is that `nix-shell` may change your environment variables -in ways you do not want. I recommend running `termonad` to get it to -recompile your `~/.config/termonad/termonad.hs` file, then exit the nix-shell environment and -rerun Termonad by calling it directly. Termonad will notice that -`~/.config/termonad/termonad.hs` hasn't been changed since -`~/.cache/termonad/termonad-linux-x86_64` has been recompiled, so it will -directly execute `~/.cache/termonad/termonad-linux-x86_64`. +If you're interested in how this works, or want to change which Haskell +packages are available from your `~/.config/termonad/termonad.hs` file, please +see the documentation in the +[`.nix-helpers/termonad-with-packages.nix`](./.nix-helpers/termonad-with-packages.nix) +file. ## Goals @@ -285,13 +366,13 @@ * flexible Most people only need a terminal emulator that lets you change the font-size, - cursor color, etc. They don't need tons of configuration options. - Termonad should be for people that like lots of configuration options. - Termonad should provide many hooks to allow the user to change it's behavior. + cursor color, etc. They don't need tons of configuration options. Termonad + should be for people that like lots of configuration options. Termonad + should provide many hooks to allow the user full control over its behavior. * stable - Termonad should be able to be used as everyday as your main terminal + Termonad should be able to be used everyday as your main terminal emulator. It should not crash for any reason. If you experience a crash, please file an issue or a pull request! @@ -302,6 +383,16 @@ certain data types or functions do. If you have a hard time understanding anything in the documentation, please submit an issue or PR. +## Where to get help + +If you find a bug in Termonad, please either +[send a PR](https://github.com/cdepillabout/termonad/pulls) fixing it or create +an [issue](https://github.com/cdepillabout/termonad/issues) explaining it. + +If you just need help with configuring Termonad, you can either join the +[Gitter room](https://gitter.im/termonad/Lobby) or +[#termonad on irc.freenode.net](https://webchat.freenode.net/). + ## Contributions Contributions are highly appreciated. Termonad is currently missing many @@ -310,4 +401,5 @@ ## Maintainers -- [Dennis Gosnell](https://github.com/cdepillabout) +- [cdepillabout](https://github.com/cdepillabout) +- [LSLeary](https://github.com/LSLeary) diff --git a/default.nix b/default.nix --- a/default.nix +++ b/default.nix @@ -1,32 +1,23 @@ -# This is the main nix file for termonad. It will just build the termonad binary. -# It can be built with the command `nix-build` in the main top directory. +# This is the main nix file for Termonad. It will build the `termonad` +# executable. It will place it in a "wrapped" environment so that Termonad can +# find GHC and a few Haskell libraries. This wrapped Termonad will be able to +# rebuild its configuration file (which should be located at +# `~/.config/termonad/termonad.hs`). # -# The termonad binary will be created at `result/bin/termonad`. - -{ compiler ? "ghc843" }: - -let - nixpkgs = import ./.nix-helpers/nixpkgs.nix; - - set-gi-vte-version = _: { - version = "2.91.19"; - sha256 = "1hnhidjr7jh7i826lj6kdn264i592sfl5kwvymnpiycmcb37dd4y"; - }; - - set-gi-gtk-version = _: { - version = "3.0.24"; - sha256 = "14cyj1acxs39avciyzqqb1qa5dr4my8rv3mfwv1kv92wa9a5i97v"; - }; +# Termonad can be built with the command `nix-build` in the main top +# directory. +# +# The `termonad` executable will be created at `result/bin/termonad`. With +# this default setup, you will be able to use the haskell packages `lens` and +# `colour` in your `~/.config/termonad/termonad.hs` file, as well as the +# Termonad package itself. +# +# If you want to install termonad into your environment, you can use `nix-env` +# from the main top directory: +# +# $ nix-env --file default.nix --install - allHaskellPackages = nixpkgs.pkgs.haskell.packages.${compiler}.override { - overrides = self: super: let lib = nixpkgs.pkgs.haskell.lib; in { - gi-gtk = lib.overrideCabal super.gi-gtk set-gi-gtk-version; - gi-vte = lib.overrideCabal (lib.addPkgconfigDepend (super.gi-vte.override { vte = nixpkgs.gnome3.vte; }) nixpkgs.gnome3.gtk) set-gi-vte-version; - }; - }; +{ compiler ? null, nixpkgs ? null }: -in +import .nix-helpers/termonad-with-packages.nix { inherit compiler nixpkgs; } -allHaskellPackages.callPackage .nix-helpers/termonad.nix { - inherit (nixpkgs.gnome3) gtk3; -} diff --git a/example-config/ExampleColourExtension.hs b/example-config/ExampleColourExtension.hs new file mode 100644 --- /dev/null +++ b/example-config/ExampleColourExtension.hs @@ -0,0 +1,72 @@ +-- | This is an example Termonad configuration that shows how to use the +-- 'ColourExtension' to set colours for your terminal. See the project-wide +-- README.md for how to use Termonad Haskell configuration scripts. + +module Main where + +import Termonad + ( CursorBlinkMode(CursorBlinkModeOff), Option(Set) + , ShowScrollbar(ShowScrollbarNever), TMConfig, confirmExit, cursorBlinkMode + , defaultConfigOptions, defaultTMConfig, options, showMenu, showScrollbar + , start + ) +import Termonad.Config.Colour + ( Colour, ColourConfig, Palette(BasicPalette), addColourExtension + , createColourExtension, cursorBgColour, defaultColourConfig, foregroundColour + , palette, sRGB24 + ) +import Termonad.Config.Vec (Vec((:*), EmptyVec), N8) +import Data.Colour.SRGB (Colour, sRGB24) + +-- This is our main 'TMConfig'. It holds all of the non-colour settings +-- for Termonad. +-- +-- This shows how a few settings can be changed. +myTMConfig :: TMConfig +myTMConfig = + defaultTMConfig + { options = + defaultConfigOptions + { showScrollbar = ShowScrollbarNever + , confirmExit = False + , showMenu = False + , cursorBlinkMode = CursorBlinkModeOff + } + } + +-- This is our 'ColourConfig'. It holds all of our colour-related settings. +myColourConfig :: ColourConfig (Colour Double) +myColourConfig = + defaultColourConfig + -- Set the cursor background colour. This is the normal colour of the + -- cursor. + { cursorBgColour = Set (sRGB24 120 80 110) -- purple + -- Set the default foreground colour of text of the terminal. + , foregroundColour = sRGB24 220 180 210 -- light pink + -- Set the basic palette that has 8 colours. + , palette = BasicPalette myStandardColours + } + where + -- This is a length-indexed linked-list of colours. + myStandardColours :: Vec N8 (Colour Double) + myStandardColours = + sRGB24 40 30 20 -- dark brown (used as background colour) + :* sRGB24 180 30 20 -- red + :* sRGB24 40 160 20 -- green + :* sRGB24 180 160 20 -- dark yellow + :* sRGB24 40 30 120 -- dark purple + :* sRGB24 180 30 120 -- bright pink + :* sRGB24 40 160 120 -- teal + :* sRGB24 180 160 120 -- light brown + :* EmptyVec + +main :: IO () +main = do + -- First, create the colour extension based on 'myColourConfig'. + myColourExt <- createColourExtension myColourConfig + + -- Update 'myTMConfig' with our colour extension. + let newTMConfig = addColourExtension myTMConfig myColourExt + + -- Start Termonad with our updated 'TMConfig'. + start newTMConfig diff --git a/img/termonad-lambda.png b/img/termonad-lambda.png Binary files a/img/termonad-lambda.png and b/img/termonad-lambda.png differ diff --git a/shell.nix b/shell.nix --- a/shell.nix +++ b/shell.nix @@ -1,16 +1,50 @@ -# This is a file that allows you to jump into an environment to be able to build termonad. -# You can jump into this environment by running the command `nix-shell`. +# Running `nix-shell` in the same directory as this file will enter an +# environment in which you can easily hack on or build termonad. It provides: +# * Termonad's system dependencies. +# * GHC with all of termonad's haskell dependencies. +# * Local haddocks for those dependencies. +# * Hoogle with an index generated from those haddocks. +# * Cabal. +# * ghcid. +# * open-haddock. # -# This also installs cabal, so you should be able to build termonad by running `cabal new-build`. +# In this environment you should be able to e.g. +# * Build termonad: +# $ cabal new-build +# * Open a repl with access to the termonad libraries: +# $ cabal new-repl +# * Use `ghcid`: +# $ ghcid --command='cabal new-repl' +# * Open local haddocks for e.g. GI.Vte.Objects.Terminal: +# $ open-haddock GI.Vte.Objects.Terminal +# or for the gi-gtk package: +# $ open-haddock gi-gtk # -# In general, if you prefer to use `stack`, you probably won't use this file. +# If you pass nix-shell the arguments `--arg indexTermonad true`, then hoogle +# will also index the Termonad libraries, however this will mean the environment +# will need to be rebuilt every time the termonad source changes. -{ compiler ? "ghc843" }: +{ compiler ? null, indexTermonad ? false, nixpkgs ? null }: +with (import .nix-helpers/nixpkgs.nix { inherit compiler nixpkgs; }); + let - nixpkgs = import .nix-helpers/nixpkgs.nix; + termonadEnv = haskellPackages.termonad.env; + nativeBuildTools = with haskellPackages; [ cabal-install ghcid open-haddock ]; in -(import ./default.nix { inherit compiler; }).env.overrideAttrs (oldAttrs: rec { - nativeBuildInputs = oldAttrs.nativeBuildInputs ++ [ nixpkgs.pkgs.haskell.packages.${compiler}.cabal-install ]; -}) +if indexTermonad + then + termonadEnv.overrideAttrs (oldAttrs: { + nativeBuildInputs = + oldAttrs.nativeBuildInputs ++ + nativeBuildTools ++ + [ (haskellPackages.ghcWithHoogle (haskellPackages: with haskellPackages; [ termonad ])) + ]; + }) + else + haskellPackages.shellFor { + withHoogle = true; + packages = haskellPackages: [ haskellPackages.termonad ]; + nativeBuildInputs = termonadEnv.nativeBuildInputs ++ nativeBuildTools; + } diff --git a/src/Termonad.hs b/src/Termonad.hs --- a/src/Termonad.hs +++ b/src/Termonad.hs @@ -1,7 +1,19 @@ +-- | Module : Termonad +-- Description : Termonad +-- Copyright : (c) Dennis Gosnell, 2018 +-- License : BSD3 +-- Stability : experimental +-- Portability : POSIX +-- +-- This module exposes termonad's basic configuration options, as well as 'defaultMain'. +-- +-- If you want to configure Termonad, please take a look at "Termonad.Config". + module Termonad ( defaultMain + , start , module Config ) where -import Termonad.App (defaultMain) +import Termonad.App (defaultMain, start) import Termonad.Config as Config diff --git a/src/Termonad/App.hs b/src/Termonad/App.hs --- a/src/Termonad/App.hs +++ b/src/Termonad/App.hs @@ -4,7 +4,9 @@ import Termonad.Prelude import Config.Dyre (defaultParams, projectName, realMain, showError, wrapMain) -import Control.Lens ((&), (^.), (.~)) +import Control.Lens ((&), (.~), (^.)) +import Data.FocusList (focusList, moveFromToFL, updateFocusFL) +import Data.Sequence (findIndexR) import GI.Gdk (castTo, managedForeignPtr, screenGetDefault) import GI.Gio ( ApplicationFlags(ApplicationFlagsFlagsNone) @@ -46,7 +48,6 @@ , onNotebookPageReordered , onNotebookSwitchPage , onWidgetDeleteEvent - , onWidgetDestroy , setWidgetMargin , styleContextAddProviderForScreen , widgetDestroy @@ -54,7 +55,6 @@ , widgetSetCanFocus , widgetShow , widgetShowAll - , windowClose , windowPresent , windowSetDefaultIconFromFile , windowSetTitle @@ -67,6 +67,7 @@ , fontDescriptionNew , fontDescriptionSetFamily , fontDescriptionSetSize + , fontDescriptionSetAbsoluteSize ) import GI.Vte ( terminalCopyClipboard @@ -74,29 +75,30 @@ ) import Paths_termonad (getDataFileName) -import Termonad.Config - ( FontConfig(fontFamily, fontSize) - , TMConfig +import Termonad.Lenses + ( lensConfirmExit , lensFontConfig + , lensOptions + , lensShowMenu + , lensTMNotebookTabTerm + , lensTMNotebookTabs + , lensTMStateApp + , lensTMStateConfig + , lensTMStateNotebook + , lensTerm ) -import Termonad.FocusList (findFL, moveFromToFL, updateFocusFL) import Termonad.Gtk (appNew, objFromBuildUnsafe) import Termonad.Keys (handleKeyPress) -import Termonad.Term (createTerm, relabelTabs, termExitFocused) +import Termonad.Term (createTerm, relabelTabs, termExitFocused, setShowTabs) import Termonad.Types - ( TMNotebookTab + ( FontConfig(fontFamily, fontSize) + , FontSize(FontSizePoints, FontSizeUnits) + , TMConfig + , TMNotebookTab , TMState , TMState'(TMState) - , UserRequestedExit(UserRequestedExit, UserDidNotRequestExit) , getFocusedTermFromState - , getUserRequestedExit - , lensTMNotebookTabs - , lensTMNotebookTabTerm - , lensTMStateApp - , lensTMStateNotebook - , lensTerm , newEmptyTMState - , setUserRequestedExit , tmNotebookTabTermContainer , tmNotebookTabs , tmStateNotebook @@ -118,7 +120,7 @@ -- , " border-width: 200px;" , " background-color: #aaaaaa;" -- , " color: #ff0000;" - , " min-width: 4px;" + -- , " min-width: 4px;" , "}" -- , "scrollbar trough {" -- , " -GtkRange-slider-width: 200px;" @@ -150,13 +152,17 @@ createFontDesc :: TMConfig -> IO FontDescription createFontDesc tmConfig = do fontDesc <- fontDescriptionNew - let fontConf = tmConfig ^. lensFontConfig + let fontConf = tmConfig ^. lensOptions . lensFontConfig fontDescriptionSetFamily fontDesc (fontFamily fontConf) - fontDescriptionSetSize fontDesc (fromIntegral (fontSize fontConf) * SCALE) + case fontSize fontConf of + FontSizePoints points -> + fontDescriptionSetSize fontDesc $ fromIntegral (points * fromIntegral SCALE) + FontSizeUnits units -> + fontDescriptionSetAbsoluteSize fontDesc $ units * fromIntegral SCALE pure fontDesc -compareScrolledWinAndTab :: ScrolledWindow -> a -> TMNotebookTab -> Bool -compareScrolledWinAndTab scrollWin _ flTab = +compareScrolledWinAndTab :: ScrolledWindow -> TMNotebookTab -> Bool +compareScrolledWinAndTab scrollWin flTab = let ScrolledWindow managedPtrFLTab = tmNotebookTabTermContainer flTab foreignPtrFLTab = managedForeignPtr managedPtrFLTab ScrolledWindow managedPtrScrollWin = scrollWin @@ -183,49 +189,65 @@ tmState & lensTMStateNotebook . lensTMNotebookTabs .~ newTabs -exitWithConfirmation :: TMState -> IO () -exitWithConfirmation mvarTMState = do - respType <- exitWithConfirmationDialog mvarTMState - case respType of - ResponseTypeYes -> do - setUserRequestedExit mvarTMState - quit mvarTMState - _ -> pure () - -exitWithConfirmationDialog :: TMState -> IO ResponseType -exitWithConfirmationDialog mvarTMState = do +-- | Try to figure out whether Termonad should exit. This also used to figure +-- out if Termonad should close a given terminal. +-- +-- This reads the 'confirmExit' setting from 'ConfigOptions' to check whether +-- the user wants to be notified when either Termonad or a given terminal is +-- about to be closed. +-- +-- If 'confirmExit' is 'True', then a dialog is presented to the user asking +-- them if they really want to exit or close the terminal. Their response is +-- sent back as a 'ResponseType'. +-- +-- If 'confirmExit' is 'False', then this function always returns +-- 'ResponseTypeYes'. +askShouldExit :: TMState -> IO ResponseType +askShouldExit mvarTMState = do tmState <- readMVar mvarTMState - let app = tmState ^. lensTMStateApp - win <- applicationGetActiveWindow app - dialog <- dialogNew - box <- dialogGetContentArea dialog - label <- labelNew (Just "There are still terminals running. Are you sure you want to exit?") - containerAdd box label - widgetShow label - setWidgetMargin label 10 - void $ - dialogAddButton - dialog - "No, do NOT exit" - (fromIntegral (fromEnum ResponseTypeNo)) - void $ - dialogAddButton - dialog - "Yes, exit" - (fromIntegral (fromEnum ResponseTypeYes)) - windowSetTransientFor dialog win - res <- dialogRun dialog - widgetDestroy dialog - pure $ toEnum (fromIntegral res) + let confirm = tmState ^. lensTMStateConfig . lensOptions . lensConfirmExit + if confirm + then confirmationDialogForExit tmState + else pure ResponseTypeYes + where + -- Show the user a dialog telling them there are still terminals running and + -- asking if they really want to exit. + -- + -- Return the user's resposne as a 'ResponseType'. + confirmationDialogForExit :: TMState' -> IO ResponseType + confirmationDialogForExit tmState = do + let app = tmState ^. lensTMStateApp + win <- applicationGetActiveWindow app + dialog <- dialogNew + box <- dialogGetContentArea dialog + label <- + labelNew $ + Just + "There are still terminals running. Are you sure you want to exit?" + containerAdd box label + widgetShow label + setWidgetMargin label 10 + void $ + dialogAddButton + dialog + "No, do NOT exit" + (fromIntegral (fromEnum ResponseTypeNo)) + void $ + dialogAddButton + dialog + "Yes, exit" + (fromIntegral (fromEnum ResponseTypeYes)) + windowSetTransientFor dialog win + res <- dialogRun dialog + widgetDestroy dialog + pure $ toEnum (fromIntegral res) -quit :: TMState -> IO () -quit mvarTMState = do +-- | Force Termonad to exit without asking the user whether or not to do so. +forceQuit :: TMState -> IO () +forceQuit mvarTMState = do tmState <- readMVar mvarTMState let app = tmState ^. lensTMStateApp - maybeWin <- applicationGetActiveWindow app - case maybeWin of - Nothing -> applicationQuit app - Just win -> windowClose win + applicationQuit app setupTermonad :: TMConfig -> Application -> ApplicationWindow -> Gtk.Builder -> IO () setupTermonad tmConfig app win builder = do @@ -244,9 +266,9 @@ void $ onNotebookPageRemoved note $ \_ _ -> do pages <- notebookGetNPages note - when (pages == 0) $ do - setUserRequestedExit mvarTMState - quit mvarTMState + if pages == 0 + then forceQuit mvarTMState + else setShowTabs tmConfig note void $ onNotebookSwitchPage note $ \_ pageNum -> do maybeRes <- tryTakeMVar mvarTMState @@ -277,14 +299,15 @@ Just scrollWin -> do TMState{tmStateNotebook} <- readMVar mvarTMState let fl = tmStateNotebook ^. lensTMNotebookTabs - let maybeOldPosition = findFL (compareScrolledWinAndTab scrollWin) fl + 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 + Just oldPos -> do updateFLTabPos mvarTMState oldPos (fromIntegral pageNum) relabelTabs mvarTMState @@ -300,8 +323,9 @@ applicationSetAccelsForAction app "app.closetab" ["W"] quitAction <- simpleActionNew "quit" Nothing - void $ onSimpleActionActivate quitAction $ \_ -> - exitWithConfirmation mvarTMState + void $ onSimpleActionActivate quitAction $ \_ -> do + shouldExit <- askShouldExit mvarTMState + when (shouldExit == ResponseTypeYes) $ forceQuit mvarTMState actionMapAddAction app quitAction applicationSetAccelsForAction app "app.quit" ["Q"] @@ -323,24 +347,27 @@ void $ onSimpleActionActivate aboutAction (const $ showAboutDialog app) actionMapAddAction app aboutAction - menuBuilder <- builderNewFromString menuText $ fromIntegral (length menuText) - menuModel <- objFromBuildUnsafe menuBuilder "menubar" MenuModel - applicationSetMenubar app (Just menuModel) + when (tmConfig ^. lensOptions . lensShowMenu) $ do + menuBuilder <- builderNewFromString menuText $ fromIntegral (length menuText) + menuModel <- objFromBuildUnsafe menuBuilder "menubar" MenuModel + applicationSetMenubar app (Just menuModel) 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, + -- like clicking "Quit" or closing the last open terminal. + -- + -- If you return 'True' from this callback, then Termonad will not exit. + -- If you return 'False' from this callback, then Termonad will continue to + -- exit. void $ onWidgetDeleteEvent win $ \_ -> do - userRequestedExit <- getUserRequestedExit mvarTMState - case userRequestedExit of - UserRequestedExit -> pure False - UserDidNotRequestExit -> do - respType <- exitWithConfirmationDialog mvarTMState - let stopOtherHandlers = - case respType of - ResponseTypeYes -> False - _ -> True - pure stopOtherHandlers - void $ onWidgetDestroy win $ quit mvarTMState + shouldExit <- askShouldExit mvarTMState + pure $ + case shouldExit of + ResponseTypeYes -> False + _ -> True widgetShowAll win widgetGrabFocus $ terminal ^. lensTerm @@ -366,6 +393,10 @@ appStartup :: Application -> IO () appStartup _app = pure () +-- | Run Termonad with the given 'TMConfig'. +-- +-- Do not perform any of the recompilation operations that the 'defaultMain' +-- function does. start :: TMConfig -> IO () start tmConfig = do -- app <- appNew (Just "haskell.termonad") [ApplicationFlagsFlagsNone] @@ -375,6 +406,62 @@ 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 = diff --git a/src/Termonad/Config.hs b/src/Termonad/Config.hs --- a/src/Termonad/Config.hs +++ b/src/Termonad/Config.hs @@ -1,59 +1,63 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Termonad.Config where - -import Termonad.Prelude - -import Control.Lens (makeLensesFor) -import Data.Colour (Colour) -import Data.Colour.Names -- (grey) - -data FontConfig = FontConfig - { fontFamily :: !Text - , fontSize :: !Int - } deriving (Eq, Show) - -$(makeLensesFor - [ ("fontFamily", "lensFontFamily") - , ("fontSize", "lensFontSize") - ] - ''FontConfig - ) - -defaultFontConfig :: FontConfig -defaultFontConfig = - FontConfig - { fontFamily = "Monospace" -- or "DejaVu Sans Mono" or "Bitstream Vera Sans Mono Roman" or "Source Code Pro" - , fontSize = 12 - } +-- | Module : Termonad.Config +-- Description : Termonad Configuration Options +-- Copyright : (c) Dennis Gosnell, 2018 +-- License : BSD3 +-- Stability : experimental +-- Portability : POSIX +-- +-- This module exposes termonad's basic configuration options. To set these +-- options in your config, first ensure you've imported "Termonad". +-- +-- Then for your main, apply 'Termonad.start' or 'Termonad.defaultMain' to a 'TMConfig' value. +-- We suggest you build such values by performing record updates on the +-- 'defaultTMConfig' rather than using the 'TMConfig' constructor, as the latter +-- is much more likely to break when there are changes to the 'TMConfig' type. +-- +-- E.g. +-- +-- @ +-- -- Re-exports this module. +-- import "Termonad" +-- +-- main :: IO () +-- main = 'start' $ 'defaultTMConfig' +-- { 'showScrollbar' = 'ShowScrollbarNever' +-- , 'confirmExit' = False +-- , 'showMenu' = False +-- , 'cursorBlinkMode' = 'CursorBlinkModeOff' +-- } +-- @ +-- +-- Additional options can be found in the following modules. +-- +-- * "Termonad.Config.Colour" +-- +-- If you want to see an example configuration file, as well as an explanation +-- for how to use Termonad, see the Termonad +-- . -data ShowScrollbar - = ShowScrollbarNever - | ShowScrollbarAlways - | ShowScrollbarIfNeeded - deriving (Eq, Show) +module Termonad.Config + ( -- * Main Config Data Type + TMConfig(..) + , defaultTMConfig + , ConfigOptions(..) + , defaultConfigOptions + , ConfigHooks(..) + , defaultConfigHooks + -- * Fonts + , FontSize(..) + , defaultFontSize + , FontConfig(..) + , defaultFontConfig + -- * Misc + , Option(..) + , ShowScrollbar(..) + , ShowTabBar(..) + , CursorBlinkMode(..) + ) where -data TMConfig = TMConfig - { fontConfig :: !FontConfig - , showScrollbar :: !ShowScrollbar - , cursorColor :: !(Colour Double) - , scrollbackLen :: !Integer - } deriving (Eq, Show) +import Termonad.Prelude hiding ((\\), index) -$(makeLensesFor - [ ("fontConfig", "lensFontConfig") - , ("showScrollbar", "lensShowScrollbar") - , ("cursorColor", "lensCursorColor") - , ("scrollbackLen", "lensScrollbackLen") - ] - ''TMConfig - ) +import GI.Vte (CursorBlinkMode(..)) -defaultTMConfig :: TMConfig -defaultTMConfig = - TMConfig - { fontConfig = defaultFontConfig - , showScrollbar = ShowScrollbarIfNeeded - , cursorColor = lightgrey - , scrollbackLen = 10000 - } +import Termonad.Types diff --git a/src/Termonad/Config/Colour.hs b/src/Termonad/Config/Colour.hs new file mode 100644 --- /dev/null +++ b/src/Termonad/Config/Colour.hs @@ -0,0 +1,518 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Module : Termonad.Config.Colour +-- Description : Termonad Configuration Colour Options +-- Copyright : (c) Dennis Gosnell, 2018 +-- License : BSD3 +-- Stability : experimental +-- Portability : POSIX +-- +-- To use this config extension in your @~\/.config\/termonad\/termonad.hs@, first +-- import this module. Create a new 'ColourExtension' with the 'createColourExtension' function. +-- Then add the 'ColourExtension' to your 'TMConfig' with the 'addColourExtension' function. +-- +-- See for a simple example. + +module Termonad.Config.Colour + ( -- * Colour Config + ColourConfig(..) + , defaultColourConfig + -- ** Colour Config Lenses + , lensCursorFgColour + , lensCursorBgColour + , lensForegroundColour + , lensBackgroundColour + , lensPalette + -- * Colour Extension + , ColourExtension(..) + , createColourExtension + , createDefColourExtension + , addColourExtension + , addColourConfig + , colourHook + , addColourHook + -- * Palette + , Palette(..) + , defaultStandardColours + , defaultLightColours + , defaultColourCube + , defaultGreyscale + -- * Colour + -- | Check out the "Data.Colour" module for more info about 'Colour'. + , Colour + , sRGB24 + , sRGB24show + -- * Debugging and Internal Methods + , showColourVec + , showColourCube + , paletteToList + , coloursFromBits + , cube + ) where + +import Termonad.Prelude hiding ((\\), index) + +import Control.Lens ((%~), makeLensesFor) +import Data.Colour (Colour, black, affineCombo) +import Data.Colour.SRGB (RGB(RGB), toSRGB, sRGB24, sRGB24show) +import qualified Data.Foldable +import GI.Gdk (RGBA, newZeroRGBA, setRGBABlue, setRGBAGreen, setRGBARed) +import GI.Vte + ( Terminal + , terminalSetColors + , terminalSetColorCursor + , terminalSetColorCursorForeground +--, terminalSetColorBackground + , terminalSetColorForeground + ) +import Text.Show (showString) + +import Termonad.Config.Vec +import Termonad.Lenses (lensCreateTermHook, lensHooks) +import Termonad.Types + ( Option(Unset) + , TMConfig + , TMState + , whenSet + ) + +------------------- +-- Colour Config -- +------------------- + +-- | This is the color palette to use for the terminal. Each data constructor +-- lets you set progressively more colors. These colors are used by the +-- terminal to render +-- . +-- +-- There are 256 total terminal colors. 'BasicPalette' lets you set the first 8, +-- 'ExtendedPalette' lets you set the first 16, 'ColourCubePalette' lets you set +-- the first 232, and 'FullPalette' lets you set all 256. +-- +-- The first 8 colors codes are the standard colors. The next 8 are the +-- extended (light) colors. The next 216 are a full color cube. The last 24 are a +-- grey scale. +-- +-- The following image gives an idea of what each individual color looks like: +-- +-- <> +-- +-- This picture does not exactly match up with Termonad's default colors, but it gives an +-- idea of what each block of colors represents. +-- +-- You can use 'defaultStandardColours', 'defaultLightColours', +-- 'defaultColourCube', and 'defaultGreyscale' as a starting point to +-- customize the colors. The only time you'd need to use a constructor other +-- than 'NoPalette' is when you want to customize the default colors. +-- That is to say, using 'FullPalette' with all the defaults should give you the +-- same result as using 'NoPalette'. +data Palette c + = NoPalette + -- ^ Don't set any colors and just use the default from VTE. This is a black + -- background with light grey text. + | BasicPalette !(Vec N8 c) + -- ^ Set the colors from the standard colors. + | ExtendedPalette !(Vec N8 c) !(Vec N8 c) + -- ^ Set the colors from the extended (light) colors (as well as standard colors). + | ColourCubePalette !(Vec N8 c) !(Vec N8 c) !(Matrix '[N6, N6, N6] c) + -- ^ Set the colors from the color cube (as well as the standard colors and + -- extended colors). + | FullPalette !(Vec N8 c) !(Vec N8 c) !(Matrix '[N6, N6, N6] c) !(Vec N24 c) + -- ^ Set the colors from the grey scale (as well as the standard colors, + -- extended colors, and color cube). + deriving (Eq, Show, Functor, Foldable) + +-- | Convert a 'Palette' to a list of colors. This is helpful for debugging. +paletteToList :: Palette c -> [c] +paletteToList = Data.Foldable.toList + +-- | Create a vector of colors based on input bits. +-- +-- This is used to derive 'defaultStandardColours' and 'defaultLightColours'. +-- +-- >>> coloursFromBits 192 0 == defaultStandardColours +-- True +-- +-- >>> coloursFromBits 192 63 == defaultLightColours +-- True +-- +-- In general, as an end-user, you shouldn't need to use this. +coloursFromBits :: forall b. (Ord b, Floating b) => Word8 -> Word8 -> Vec N8 (Colour b) +coloursFromBits scale offset = genVec_ createElem + where + createElem :: Fin N8 -> Colour b + createElem finN = + let red = cmp 0 finN + green = cmp 1 finN + blue = cmp 2 finN + color = sRGB24 red green blue + in color + + cmp :: Int -> Fin N8 -> Word8 + cmp i = (offset +) . (scale *) . fromIntegral . bit i . toIntFin + + bit :: Int -> Int -> Int + bit m i = i `div` (2 ^ m) `mod` 2 + +-- | A 'Vec' of standard colors. Default value for 'BasicPalette'. +-- +-- >>> showColourVec defaultStandardColours +-- ["#000000","#c00000","#00c000","#c0c000","#0000c0","#c000c0","#00c0c0","#c0c0c0"] +defaultStandardColours :: (Ord b, Floating b) => Vec N8 (Colour b) +defaultStandardColours = coloursFromBits 192 0 + +-- | A 'Vec' of extended (light) colors. Default value for 'ExtendedPalette'. +-- +-- >>> showColourVec defaultLightColours +-- ["#3f3f3f","#ff3f3f","#3fff3f","#ffff3f","#3f3fff","#ff3fff","#3fffff","#ffffff"] +defaultLightColours :: (Ord b, Floating b) => Vec N8 (Colour b) +defaultLightColours = coloursFromBits 192 63 + +-- | A helper function for showing all the colors in 'Vec' of colors. +showColourVec :: forall n. Vec n (Colour Double) -> [String] +showColourVec = fmap sRGB24show . Data.Foldable.toList + +-- | Specify a colour cube with one colour vector for its displacement and three +-- colour vectors for its edges. Produces a uniform 6x6x6 grid bounded by +-- and orthognal to the faces. +cube :: + forall b. Fractional b + => Colour b + -> Vec N3 (Colour b) + -> Matrix '[ N6, N6, N6] (Colour b) +cube d (i :* j :* k :* EmptyVec) = + genMatrix_ $ + \(x :< y :< z :< EmptyHList) -> + affineCombo [(1, d), (coef x, i), (coef y, j), (coef z, k)] black + where + coef :: Fin N6 -> b + coef fin = fromIntegral (toIntFin fin) / 5 + +-- | A matrix of a 6 x 6 x 6 color cube. Default value for 'ColourCubePalette'. +-- +-- >>> putStrLn $ pack $ showColourCube defaultColourCube +-- [ [ #000000, #00005f, #000087, #0000af, #0000d7, #0000ff +-- , #005f00, #005f5f, #005f87, #005faf, #005fd7, #005fff +-- , #008700, #00875f, #008787, #0087af, #0087d7, #0087ff +-- , #00af00, #00af5f, #00af87, #00afaf, #00afd7, #00afff +-- , #00d700, #00d75f, #00d787, #00d7af, #00d7d7, #00d7ff +-- , #00ff00, #00ff5f, #00ff87, #00ffaf, #00ffd7, #00ffff +-- ] +-- , [ #5f0000, #5f005f, #5f0087, #5f00af, #5f00d7, #5f00ff +-- , #5f5f00, #5f5f5f, #5f5f87, #5f5faf, #5f5fd7, #5f5fff +-- , #5f8700, #5f875f, #5f8787, #5f87af, #5f87d7, #5f87ff +-- , #5faf00, #5faf5f, #5faf87, #5fafaf, #5fafd7, #5fafff +-- , #5fd700, #5fd75f, #5fd787, #5fd7af, #5fd7d7, #5fd7ff +-- , #5fff00, #5fff5f, #5fff87, #5fffaf, #5fffd7, #5fffff +-- ] +-- , [ #870000, #87005f, #870087, #8700af, #8700d7, #8700ff +-- , #875f00, #875f5f, #875f87, #875faf, #875fd7, #875fff +-- , #878700, #87875f, #878787, #8787af, #8787d7, #8787ff +-- , #87af00, #87af5f, #87af87, #87afaf, #87afd7, #87afff +-- , #87d700, #87d75f, #87d787, #87d7af, #87d7d7, #87d7ff +-- , #87ff00, #87ff5f, #87ff87, #87ffaf, #87ffd7, #87ffff +-- ] +-- , [ #af0000, #af005f, #af0087, #af00af, #af00d7, #af00ff +-- , #af5f00, #af5f5f, #af5f87, #af5faf, #af5fd7, #af5fff +-- , #af8700, #af875f, #af8787, #af87af, #af87d7, #af87ff +-- , #afaf00, #afaf5f, #afaf87, #afafaf, #afafd7, #afafff +-- , #afd700, #afd75f, #afd787, #afd7af, #afd7d7, #afd7ff +-- , #afff00, #afff5f, #afff87, #afffaf, #afffd7, #afffff +-- ] +-- , [ #d70000, #d7005f, #d70087, #d700af, #d700d7, #d700ff +-- , #d75f00, #d75f5f, #d75f87, #d75faf, #d75fd7, #d75fff +-- , #d78700, #d7875f, #d78787, #d787af, #d787d7, #d787ff +-- , #d7af00, #d7af5f, #d7af87, #d7afaf, #d7afd7, #d7afff +-- , #d7d700, #d7d75f, #d7d787, #d7d7af, #d7d7d7, #d7d7ff +-- , #d7ff00, #d7ff5f, #d7ff87, #d7ffaf, #d7ffd7, #d7ffff +-- ] +-- , [ #ff0000, #ff005f, #ff0087, #ff00af, #ff00d7, #ff00ff +-- , #ff5f00, #ff5f5f, #ff5f87, #ff5faf, #ff5fd7, #ff5fff +-- , #ff8700, #ff875f, #ff8787, #ff87af, #ff87d7, #ff87ff +-- , #ffaf00, #ffaf5f, #ffaf87, #ffafaf, #ffafd7, #ffafff +-- , #ffd700, #ffd75f, #ffd787, #ffd7af, #ffd7d7, #ffd7ff +-- , #ffff00, #ffff5f, #ffff87, #ffffaf, #ffffd7, #ffffff +-- ] +-- ] +defaultColourCube :: (Ord b, Floating b) => Matrix '[N6, N6, N6] (Colour b) +defaultColourCube = + genMatrix_ $ \(x :< y :< z :< EmptyHList) -> sRGB24 (cmp x) (cmp y) (cmp z) + where + cmp :: Fin N6 -> Word8 + cmp i = + let i' = fromIntegral (toIntFin i) + in signum i' * 55 + 40 * i' + +-- | Helper function for showing all the colors in a color cube. This is used +-- for debugging. +showColourCube :: Matrix '[N6, N6, N6] (Colour Double) -> String +showColourCube matrix = + -- TODO: This function will only work with a 6x6x6 matrix, but it could be + -- generalized to work with any Rank-3 matrix. + let itemList = Data.Foldable.toList matrix + in showSColourCube itemList "" + where + showSColourCube :: [Colour Double] -> String -> String + showSColourCube itemList = + showString "[ " . + showSquare 0 itemList . + showString ", " . + showSquare 1 itemList . + showString ", " . + showSquare 2 itemList . + showString ", " . + showSquare 3 itemList . + showString ", " . + showSquare 4 itemList . + showString ", " . + showSquare 5 itemList . + showString "]" + + showSquare :: Int -> [Colour Double] -> String -> String + showSquare i colours = + showString "[ " . + showRow i 0 colours . + showString ", " . + showRow i 1 colours . + showString ", " . + showRow i 2 colours . + showString ", " . + showRow i 3 colours . + showString ", " . + showRow i 4 colours . + showString ", " . + showRow i 5 colours . + showString "]\n" + + showRow :: Int -> Int -> [Colour Double] -> String -> String + showRow i j colours = + showCol (headEx $ drop (i * 36 + j * 6 + 0) colours) . + showString ", " . + showCol (headEx $ drop (i * 36 + j * 6 + 1) colours) . + showString ", " . + showCol (headEx $ drop (i * 36 + j * 6 + 2) colours) . + showString ", " . + showCol (headEx $ drop (i * 36 + j * 6 + 3) colours) . + showString ", " . + showCol (headEx $ drop (i * 36 + j * 6 + 4) colours) . + showString ", " . + showCol (headEx $ drop (i * 36 + j * 6 + 5) colours) . + showString "\n " + + showCol :: Colour Double -> String -> String + showCol col str = sRGB24show col <> str + +-- | A 'Vec' of a grey scale. Default value for 'FullPalette'. +-- +-- >>> showColourVec defaultGreyscale +-- ["#080808","#121212","#1c1c1c","#262626","#303030","#3a3a3a","#444444","#4e4e4e","#585858","#626262","#6c6c6c","#767676","#808080","#8a8a8a","#949494","#9e9e9e","#a8a8a8","#b2b2b2","#bcbcbc","#c6c6c6","#d0d0d0","#dadada","#e4e4e4","#eeeeee"] +defaultGreyscale :: (Ord b, Floating b) => Vec N24 (Colour b) +defaultGreyscale = genVec_ $ \n -> + let l = 8 + 10 * fromIntegral (toIntFin n) + in sRGB24 l l l + +-- | The configuration for the colors used by Termonad. +-- +-- 'foregroundColour' and 'backgroundColour' allow you to set the color of the +-- foreground text and background of the terminal (although see the __WARNING__ +-- below). Most people use a black background and a light foreground for their +-- terminal, so this is the default. +-- +-- 'palette' allows you to set the full color palette used by the terminal. +-- See 'Palette' for more information. +-- +-- If you want to use a terminal with a white (or light) background and a black +-- foreground, it may be a good idea to change some of the colors in the +-- 'Palette' as well. +-- +-- (__WARNING__: Currently due to issues either with VTE or the bindings generated for +-- Haskell, background colour cannot be set independently of the palette. +-- The @backgroundColour@ field will be ignored and the 0th colour in the +-- palette (by default black) will be used as the background colour. See +-- . +-- +-- VTE works as follows: if you don't explicitly set a background or foreground color, +-- it takes the 0th colour from the 'palette' to be the background color, and the 7th +-- colour from the 'palette' to be the foreground color. If you notice oddities with +-- colouring in certain applications, it may be helpful to make sure that these +-- 'palette' colours match up with the 'backgroundColour' and 'foregroundColour' you +-- have set.) +-- +-- 'cursorFgColour' and 'cursorBgColour' allow you to set the foreground color +-- of the text under the cursor, as well as the color of the cursor itself. +-- +-- Termonad will behave differently depending on the combination +-- 'cursorFgColour' and 'cursorBgColour' being 'Set' vs. 'Unset'. +-- Here is the summary of the different possibilities: +-- +-- * 'cursorFgColour' is 'Set' and 'cursorBgColour' is 'Set' +-- +-- The foreground and background colors of the cursor are as you have set. +-- +-- * 'cursorFgColour' is 'Set' and 'cursorBgColour' is 'Unset' +-- +-- The cursor background color turns completely black so that it is not +-- visible. The foreground color of the cursor is the color that you have +-- 'Set'. This ends up being mostly unusable, so you are recommended to +-- always 'Set' 'cursorBgColour' when you have 'Set' 'cursorFgColour'. +-- +-- * 'cursorFgColour' is 'Unset' and 'cursorBgColour' is 'Set' +-- +-- The cursor background color becomes the color you 'Set', while the cursor +-- foreground color doesn't change from the letter it is over. For instance, +-- imagine there is a letter on the screen with a black background and a +-- green foreground. If you bring the cursor overtop of it, the cursor +-- background will be the color you have 'Set', while the cursor foreground +-- will be green. +-- +-- This is completely usable, but is slightly annoying if you place the cursor +-- over a letter with the same foreground color as the cursor's background +-- color, because the letter will not be readable. For instance, imagine you +-- have set your cursor background color to red, and somewhere on the screen +-- there is a letter with a black background and a red foreground. If you move +-- your cursor over the letter, the background of the cursor will be red (as +-- you have set), and the cursor foreground will be red (to match the original +-- foreground color of the letter). This will make it so you can't +-- actually read the letter, because the foreground and background are both +-- red. +-- +-- * 'cursorFgColour' is 'Unset' and 'cursorBgColour' is 'Unset' +-- +-- This combination makes the cursor inverse of whatever text it is over. +-- If your cursor is over red text with a black background, the cursor +-- background will be red and the cursor foreground will be black. +-- +-- This is the default. +-- +-- See 'defaultColourConfig' for the defaults for 'ColourConfig' used in Termonad. +data ColourConfig c = ColourConfig + { cursorFgColour :: !(Option c) -- ^ Foreground color of the cursor. This is + -- the color of the text that the cursor is + -- over. + , cursorBgColour :: !(Option c) -- ^ Background color of the cursor. This is + -- the color of the cursor itself. + , foregroundColour :: !c -- ^ Color of the default default foreground text in + -- the terminal. + , backgroundColour :: !c -- ^ Background color for the terminal, however, See + -- the __WARNING__ above. + , palette :: !(Palette c) -- ^ Color palette for the terminal. See 'Palette'. + } deriving (Eq, Show, Functor) + +-- | Default setting for a 'ColourConfig'. The cursor colors are left at their +-- default for VTE. The foreground text for the terminal is grey and the +-- background of the terminal is black. The palette is left as the default for +-- VTE. +-- +-- >>> let fgGrey = sRGB24 192 192 192 +-- >>> let bgBlack = sRGB24 0 0 0 +-- >>> let defCC = ColourConfig { cursorFgColour = Unset, cursorBgColour = Unset, foregroundColour = fgGrey, backgroundColour = bgBlack, palette = NoPalette } +-- >>> defaultColourConfig == defCC +-- True +defaultColourConfig :: ColourConfig (Colour Double) +defaultColourConfig = ColourConfig + { cursorFgColour = Unset + , cursorBgColour = Unset + , foregroundColour = sRGB24 192 192 192 + , backgroundColour = black + , palette = NoPalette + } + +$(makeLensesFor + [ ("cursorFgColour", "lensCursorFgColour") + , ("cursorBgColour", "lensCursorBgColour") + , ("foregroundColour", "lensForegroundColour") + , ("backgroundColour", "lensBackgroundColour") + , ("palette", "lensPalette") + ] + ''ColourConfig + ) + +------------------------------ +-- ConfigExtension Instance -- +------------------------------ + +-- | Extension that allows setting colors for terminals in Termonad. +data ColourExtension = ColourExtension + { colourExtConf :: MVar (ColourConfig (Colour Double)) + -- ^ 'MVar' holding the current 'ColourConfig'. This could potentially be + -- passed to other extensions or user code. This would allow changing the + -- colors for new terminals in realtime. + , colourExtCreateTermHook :: TMState -> Terminal -> IO () + -- ^ The 'createTermHook' used by the 'ColourExtension'. This sets the + -- colors for a new terminal based on the 'ColourConfig' in 'colourExtConf'. + } + +-- | The default 'createTermHook' for 'colourExtCreateTermHook'. Set the colors +-- for a terminal based on the given 'ColourConfig'. +colourHook :: MVar (ColourConfig (Colour Double)) -> TMState -> Terminal -> IO () +colourHook mvarColourConf _ vteTerm = do + colourConf <- readMVar mvarColourConf + terminalSetColors vteTerm Nothing Nothing . Just + =<< traverse toRGBA (paletteToList . palette $ colourConf) + -- PR #28 / issue #29: Setting the background colour is broken in gi-vte or VTE. If + -- this next line is called, then you are no longer able to set the + -- background color using the palette. + -- terminalSetColorBackground vteTerm =<< toRGBA (backgroundColour colourConf) + terminalSetColorForeground vteTerm =<< toRGBA (foregroundColour colourConf) + let optPerform setC cField = whenSet (cField colourConf) $ \c -> + setC vteTerm . Just =<< toRGBA c + optPerform terminalSetColorCursor cursorBgColour + optPerform terminalSetColorCursorForeground cursorFgColour + where + toRGBA :: Colour Double -> IO RGBA + toRGBA colour = do + let RGB red green blue = toSRGB colour + rgba <- newZeroRGBA + setRGBARed rgba red + setRGBAGreen rgba green + setRGBABlue rgba blue + pure rgba + +-- | Create a 'ColourExtension' based on a given 'ColourConfig'. +-- +-- Most users will want to use this. +createColourExtension :: ColourConfig (Colour Double) -> IO ColourExtension +createColourExtension conf = do + mvarConf <- newMVar conf + pure $ + ColourExtension + { colourExtConf = mvarConf + , colourExtCreateTermHook = colourHook mvarConf + } + +-- | Create a 'ColourExtension' based on 'defaultColourConfig'. +-- +-- Note that this is not needed if you just want to use the default colors for +-- Termonad. However, if you want to pass around the 'MVar' 'ColourConfig' for +-- extensions to use, then you may need this function. +createDefColourExtension :: IO ColourExtension +createDefColourExtension = createColourExtension defaultColourConfig + +-- | Add a given 'ColourConfig' to a 'TMConfig'. This adds 'colourHook' to the +-- 'createTermHook' in 'TMConfig'. +addColourConfig :: TMConfig -> ColourConfig (Colour Double) -> IO TMConfig +addColourConfig tmConf colConf = do + ColourExtension _ newHook <- createColourExtension colConf + let newTMConf = tmConf & lensHooks . lensCreateTermHook %~ addColourHook newHook + pure newTMConf + +-- | This is similar to 'addColourConfig', but can be used on a +-- 'ColourExtension' created with 'createColourExtension'. +addColourExtension :: TMConfig -> ColourExtension -> TMConfig +addColourExtension tmConf (ColourExtension _ newHook) = + tmConf & lensHooks . lensCreateTermHook %~ addColourHook newHook + +-- | This function shows how to combine 'createTermHook's. +-- +-- This first runs the old hook, followed by the new hook. +-- +-- This is used internally by 'addColourConfig' and 'addColourExtension'. +addColourHook + :: (TMState -> Terminal -> IO ()) -- ^ New hook + -> (TMState -> Terminal -> IO ()) -- ^ Old hook + -> TMState + -> Terminal + -> IO () +addColourHook newHook oldHook tmState term = do + oldHook tmState term + newHook tmState term diff --git a/src/Termonad/Config/Vec.hs b/src/Termonad/Config/Vec.hs new file mode 100644 --- /dev/null +++ b/src/Termonad/Config/Vec.hs @@ -0,0 +1,564 @@ +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Module : Termonad.Config.Vec +-- Description : A small library of dependent types +-- Copyright : (c) Dennis Gosnell, 2018 +-- License : BSD3 +-- Stability : experimental +-- Portability : POSIX +-- +-- This is a small library of dependent types. It provides indexed types like +-- 'Fin', 'Vec', and 'Matrix'. +-- +-- This is mainly used in Termonad for "Termonad.Config.Colour" to represent +-- length-indexed colour lists. +-- +-- This module implements a subset of the functionality from the abandoned +-- library. +-- Ideally this module would be split out to a separate package. +-- If you're interested in working on something like this, please see +-- on Github. + +module Termonad.Config.Vec + -- ( Fin + -- , I(I) + -- , M(M) + -- , N3 + -- , N24 + -- , N6 + -- , N8 + -- , Prod((:<), Ø) + -- , Range + -- , Vec + -- , VecT((:+), (:*), ØV, EmptyV) + -- , fin + -- , genMatrix_ + -- , setSubmatrix + -- , genVec_ + -- , vSetAt' + -- ) + where + +import Termonad.Prelude hiding ((\\), index) + +import Data.Distributive (Distributive(distribute)) +import qualified Data.Foldable as Data.Foldable +import Data.Functor.Rep (Representable(..), apRep, bindRep, distributeRep, pureRep) +import Data.Kind (Type) +import Data.Singletons.Prelude +import Data.Singletons.TH +import Text.Show (showParen, showString) + +-------------------------- +-- Misc VecT Operations -- +-------------------------- + +-- TODO: These could be implemented? + +-- data Range n l m = Range (IFin ('S n) l) (IFin ('S n) (l + m)) +-- deriving (Show, Eq) + +-- instance (Known (IFin ('S n)) l, Known (IFin ('S n)) (l + m)) +-- => Known (Range n l) m where +-- type KnownC (Range n l) m +-- = (Known (IFin ('S n)) l, Known (IFin ('S n)) (l + m)) +-- known = Range known known + +-- updateRange :: Range n l m -> (Fin m -> f a -> f a) -> VecT n f a -> VecT n f a +-- updateRange = \case +-- Range IFZ IFZ -> \_ -> id +-- Range (IFS l) (IFS m) -> \f -> onTail (updateRange (Range l m) f) \\ m +-- Range IFZ (IFS m) -> \f -> onTail (updateRange (Range IFZ m) $ f . FS) +-- . onHead (f FZ) \\ m + +-- setRange :: Range n l m -> VecT m f a -> VecT n f a -> VecT n f a +-- setRange r nv = updateRange r (\i _ -> index i nv) + +-- updateSubmatrix +-- :: (ns ~ Fsts3 nlms, ms ~ Thds3 nlms) +-- => HList (Uncur3 Range) nlms -> (HList Fin ms -> a -> a) -> M ns a -> M ns a +-- updateSubmatrix = \case +-- Ø -> \f -> (f Ø <$>) +-- Uncur3 r :< rs -> \f -> onMatrix . updateRange r $ \i -> +-- asM . updateSubmatrix rs $ f . (i :<) + +-- setSubmatrix +-- :: (ns ~ Fsts3 nlms, ms ~ Thds3 nlms) +-- => HList (Uncur3 Range) nlms -> M ms a -> M ns a -> M ns a +-- setSubmatrix rs sm = updateSubmatrix rs $ \is _ -> indexMatrix is sm + +----------- +-- Peano -- +----------- + +$(singletons [d| + + data Peano = Z | S Peano deriving (Eq, Ord, Show) + + addPeano :: Peano -> Peano -> Peano + addPeano Z a = a + addPeano (S a) b = S (addPeano a b) + + subtractPeano :: Peano -> Peano -> Peano + subtractPeano Z _ = Z + subtractPeano a Z = a + subtractPeano (S a) (S b) = subtractPeano a b + + multPeano :: Peano -> Peano -> Peano + multPeano Z _ = Z + multPeano (S a) b = addPeano (multPeano a b) b + + n0 :: Peano + n0 = Z + + n1 :: Peano + n1 = S n0 + + n2 :: Peano + n2 = S n1 + + n3 :: Peano + n3 = S n2 + + n4 :: Peano + n4 = S n3 + + n5 :: Peano + n5 = S n4 + + n6 :: Peano + n6 = S n5 + + n7 :: Peano + n7 = S n6 + + n8 :: Peano + n8 = S n7 + + n9 :: Peano + n9 = S n8 + + n10 :: Peano + n10 = S n9 + + n24 :: Peano + n24 = multPeano n4 n6 + + instance Num Peano where + (+) = addPeano + + (-) = subtractPeano + + (*) = multPeano + + abs = id + + signum Z = Z + signum (S _) = S Z + + fromInteger n = + if n < 0 + then error "Num Peano fromInteger: n is negative" + else + if n == 0 then Z else S (fromInteger (n - 1)) + |]) + +--------- +-- Fin -- +--------- + +data Fin :: Peano -> Type where + FZ :: forall (n :: Peano). Fin ('S n) + FS :: forall (n :: Peano). !(Fin n) -> Fin ('S n) + +deriving instance Eq (Fin n) +deriving instance Ord (Fin n) +deriving instance Show (Fin n) + +toIntFin :: Fin n -> Int +toIntFin FZ = 0 +toIntFin (FS x) = succ $ toIntFin x + +data instance Sing (z :: Fin n) where + SFZ :: Sing 'FZ + SFS :: Sing x -> Sing ('FS x) + +instance SingI 'FZ where + sing = SFZ + +instance SingI n => SingI ('FS n) where + sing = SFS sing + +instance SingKind (Fin n) where + type Demote (Fin n) = Fin n + fromSing :: forall (a :: Fin n). Sing a -> Fin n + fromSing SFZ = FZ + fromSing (SFS fin) = FS (fromSing fin) + + toSing :: Fin n -> SomeSing (Fin n) + toSing FZ = SomeSing SFZ + toSing (FS fin) = + case toSing fin of + SomeSing n -> SomeSing (SFS n) + +instance Show (Sing 'FZ) where + show SFZ = "SFZ" + +instance Show (Sing n) => Show (Sing ('FS n)) where + showsPrec d (SFS n) = + showParen (d > 10) $ + showString "SFS " . showsPrec 11 n + +---------- +-- IFin -- +---------- + +data IFin :: Peano -> Peano -> Type where + IFZ :: forall (n :: Peano). IFin ('S n) 'Z + IFS :: forall (n :: Peano) (m :: Peano). !(IFin n m) -> IFin ('S n) ('S m) + +deriving instance Eq (IFin x y) +deriving instance Ord (IFin x y) +deriving instance Show (IFin x y) + +toFinIFin :: IFin n m -> Fin n +toFinIFin IFZ = FZ +toFinIFin (IFS n) = FS (toFinIFin n) + +toIntIFin :: IFin n m -> Int +toIntIFin = toIntFin . toFinIFin + +data instance Sing (z :: IFin n m) where + SIFZ :: Sing 'IFZ + SIFS :: Sing x -> Sing ('IFS x) + +instance SingI 'IFZ where + sing = SIFZ + +instance SingI n => SingI ('IFS n) where + sing = SIFS sing + +instance SingKind (IFin n m) where + type Demote (IFin n m) = IFin n m + fromSing :: forall (a :: IFin n m). Sing a -> IFin n m + fromSing SIFZ = IFZ + fromSing (SIFS fin) = IFS (fromSing fin) + + toSing :: IFin n m -> SomeSing (IFin n m) + toSing IFZ = SomeSing SIFZ + toSing (IFS fin) = + case toSing fin of + SomeSing n -> SomeSing (SIFS n) + +instance Show (Sing 'IFZ) where + show SIFZ = "SIFZ" + +instance Show (Sing n) => Show (Sing ('IFS n)) where + showsPrec d (SIFS n) = + showParen (d > 10) $ + showString "SIFS " . showsPrec 11 n + +----------- +-- HList -- +----------- + +data HList :: (k -> Type) -> [k] -> Type where + EmptyHList :: HList f '[] + (:<) :: forall (f :: k -> Type) (a :: k) (as :: [k]). f a -> HList f as -> HList f (a ': as) + +infixr 6 :< + +-- | Data constructor for ':<'. +pattern ConsHList :: (f a :: Type) -> HList f as -> HList f (a ': as) +pattern ConsHList fa hlist = fa :< hlist + +--------- +-- Vec -- +--------- + +data Vec (n :: Peano) :: Type -> Type where + EmptyVec :: Vec 'Z a + (:*) :: !a -> !(Vec n a) -> Vec ('S n) a + deriving anyclass MonoFoldable + +infixr 6 :* + +-- | Data constructor for ':*'. +pattern ConsVec :: (a :: Type) -> Vec n a -> Vec ('S n) a +pattern ConsVec a vec = a :* vec + +deriving instance Eq a => Eq (Vec n a) +deriving instance Ord a => Ord (Vec n a) +deriving instance Show a => Show (Vec n a) + +deriving instance Functor (Vec n) +deriving instance Foldable (Vec n) + +instance MonoFunctor (Vec n a) + +instance SingI n => MonoPointed (Vec n a) + +instance SingI n => Applicative (Vec n) where + pure a = replaceVec_ a + + (<*>) = apVec ($) + +instance SingI n => Distributive (Vec n) where + distribute :: Functor f => f (Vec n a) -> Vec n (f a) + distribute = distributeRep + +instance SingI n => Representable (Vec n) where + type Rep (Vec n) = Fin n + + tabulate :: (Fin n -> a) -> Vec n a + tabulate = genVec_ + + index :: Vec n a -> Fin n -> a + index = flip indexVec + +instance SingI n => Monad (Vec n) where + (>>=) :: Vec n a -> (a -> Vec n b) -> Vec n b + (>>=) = bindRep + +type instance Element (Vec n a) = a + +genVec_ :: SingI n => (Fin n -> a) -> Vec n a +genVec_ = genVec sing + +genVec :: SPeano n -> (Fin n -> a) -> Vec n a +genVec SZ _ = EmptyVec +genVec (SS n) f = f FZ :* genVec n (f . FS) + +indexVec :: Fin n -> Vec n a -> a +indexVec FZ (a :* _) = a +indexVec (FS n) (_ :* vec) = indexVec n vec + +singletonVec :: a -> Vec N1 a +singletonVec a = ConsVec a EmptyVec + +replaceVec :: Sing n -> a -> Vec n a +replaceVec SZ _ = EmptyVec +replaceVec (SS n) a = a :* replaceVec n a + +imapVec :: forall n a b. (Fin n -> a -> b) -> Vec n a -> Vec n b +imapVec _ EmptyVec = EmptyVec +imapVec f (a :* as) = f FZ a :* imapVec (\fin vec -> f (FS fin) vec) as + +replaceVec_ :: SingI n => a -> Vec n a +replaceVec_ = replaceVec sing + +apVec :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c +apVec _ EmptyVec _ = EmptyVec +apVec f (a :* as) (b :* bs) = f a b :* apVec f as bs + +onHeadVec :: (a -> a) -> Vec ('S n) a -> Vec ('S n) a +onHeadVec f (a :* as) = f a :* as + +dropVec :: Sing m -> Vec (m + n) a -> Vec n a +dropVec SZ vec = vec +dropVec (SS n) (_ :* vec) = dropVec n vec + +takeVec :: IFin n m -> Vec n a -> Vec m a +takeVec IFZ _ = EmptyVec +takeVec (IFS n) (a :* vec) = a :* takeVec n vec + +updateAtVec :: Fin n -> (a -> a) -> Vec n a -> Vec n a +updateAtVec FZ f (a :* vec) = f a :* vec +updateAtVec (FS n) f (a :* vec) = a :* updateAtVec n f vec + +setAtVec :: Fin n -> a -> Vec n a -> Vec n a +setAtVec fin a = updateAtVec fin (const a) + +------------ +-- Matrix -- +------------ + +type family MatrixTF (ns :: [Peano]) (a :: Type) :: Type where + MatrixTF '[] a = a + MatrixTF (n ': ns) a = Vec n (MatrixTF ns a) + +newtype Matrix ns a = Matrix + { unMatrix :: MatrixTF ns a + } + deriving anyclass (MonoFoldable) + +type instance Element (Matrix ns a) = a + +--------------------------------- +-- Defunctionalization Symbols -- +--------------------------------- + +type MatrixTFSym2 (ns :: [Peano]) (t :: Type) = (MatrixTF ns t :: Type) + +data MatrixTFSym1 (ns :: [Peano]) (z :: TyFun Type Type) + = forall (arg :: Type). SameKind (Apply (MatrixTFSym1 ns) arg) (MatrixTFSym2 ns arg) => MatrixTFSym1KindInference + +type instance Apply (MatrixTFSym1 l1) l2 = MatrixTF l1 l2 + +type role MatrixTFSym0 phantom + +data MatrixTFSym0 (l :: TyFun [Peano] (Type ~> Type)) + = forall (arg :: [Peano]). SameKind (Apply MatrixTFSym0 arg) (MatrixTFSym1 arg) => MatrixTFSym0KindInference + +type instance Apply MatrixTFSym0 l = MatrixTFSym1 l + +type role MatrixTFSym1 phantom phantom + +---------------------- +-- Matrix Functions -- +---------------------- + +eqSingMatrix :: forall (peanos :: [Peano]) (a :: Type). Eq a => Sing peanos -> Matrix peanos a -> Matrix peanos a -> Bool +eqSingMatrix = compareSingMatrix (==) True (&&) + +ordSingMatrix :: forall (peanos :: [Peano]) (a :: Type). Ord a => Sing peanos -> Matrix peanos a -> Matrix peanos a -> Ordering +ordSingMatrix = compareSingMatrix compare EQ f + where + f :: Ordering -> Ordering -> Ordering + f EQ o = o + f o _ = o + +compareSingMatrix :: + forall (peanos :: [Peano]) (a :: Type) (c :: Type) + . (a -> a -> c) + -> c + -> (c -> c -> c) + -> Sing peanos + -> Matrix peanos a + -> Matrix peanos a + -> c +compareSingMatrix f _ _ SNil (Matrix a) (Matrix b) = f a b +compareSingMatrix _ empt _ (SCons SZ _) (Matrix EmptyVec) (Matrix EmptyVec) = empt +compareSingMatrix f empt combine (SCons (SS peanoSingle) moreN) (Matrix (a :* moreA)) (Matrix (b :* moreB)) = + combine + (compareSingMatrix f empt combine moreN (Matrix a) (Matrix b)) + (compareSingMatrix f empt combine (SCons peanoSingle moreN) (Matrix moreA) (Matrix moreB)) + +fmapSingMatrix :: forall (peanos :: [Peano]) (a :: Type) (b ::Type). Sing peanos -> (a -> b) -> Matrix peanos a -> Matrix peanos b +fmapSingMatrix SNil f (Matrix a) = Matrix $ f a +fmapSingMatrix (SCons SZ _) _ (Matrix EmptyVec) = Matrix EmptyVec +fmapSingMatrix (SCons (SS peanoSingle) moreN) f (Matrix (a :* moreA)) = + let matA = fmapSingMatrix moreN f (Matrix a) + matB = fmapSingMatrix (SCons peanoSingle moreN) f (Matrix moreA) + in consMatrix matA matB + +consMatrix :: Matrix ns a -> Matrix (n ': ns) a -> Matrix ('S n ': ns) a +consMatrix (Matrix a) (Matrix as) = Matrix $ ConsVec a as + +toListMatrix :: + forall (peanos :: [Peano]) (a :: Type). + Sing peanos + -> Matrix peanos a + -> [a] +toListMatrix SNil (Matrix a) = [a] +toListMatrix (SCons SZ _) (Matrix EmptyVec) = [] +toListMatrix (SCons (SS peanoSingle) moreN) (Matrix (a :* moreA)) = + toListMatrix moreN (Matrix a) <> toListMatrix (SCons peanoSingle moreN) (Matrix moreA) + +genMatrix :: + forall (ns :: [Peano]) (a :: Type). + Sing ns + -> (HList Fin ns -> a) + -> Matrix ns a +genMatrix SNil f = Matrix $ f EmptyHList +genMatrix (SCons (n :: SPeano foo) (ns' :: Sing oaoa)) f = + Matrix $ (genVec n $ (gagaga :: Fin foo -> MatrixTF oaoa a) :: Vec foo (MatrixTF oaoa a)) + where + gagaga :: Fin foo -> MatrixTF oaoa a + gagaga faaa = unMatrix $ (genMatrix ns' $ byebye faaa :: Matrix oaoa a) + + byebye :: Fin foo -> HList Fin oaoa -> a + byebye faaa = f . ConsHList faaa + +genMatrix_ :: SingI ns => (HList Fin ns -> a) -> Matrix ns a +genMatrix_ = genMatrix sing + +indexMatrix :: HList Fin ns -> Matrix ns a -> a +indexMatrix EmptyHList (Matrix a) = a +indexMatrix (i :< is) (Matrix vec) = indexMatrix is $ Matrix (indexVec i vec) + +imapMatrix :: forall (ns :: [Peano]) a b. Sing ns -> (HList Fin ns -> a -> b) -> Matrix ns a -> Matrix ns b +imapMatrix SNil f (Matrix a) = Matrix (f EmptyHList a) +imapMatrix (SCons _ ns) f matrix = + onMatrixTF + (imapVec (\fin -> onMatrix (imapMatrix ns (\hlist -> f (ConsHList fin hlist))))) + matrix + +imapMatrix_ :: SingI ns => (HList Fin ns -> a -> b) -> Matrix ns a -> Matrix ns b +imapMatrix_ = imapMatrix sing + +onMatrixTF :: (MatrixTF ns a -> MatrixTF ms b) -> Matrix ns a -> Matrix ms b +onMatrixTF f (Matrix mat) = Matrix $ f mat + +onMatrix :: (Matrix ns a -> Matrix ms b) -> MatrixTF ns a -> MatrixTF ms b +onMatrix f = unMatrix . f . Matrix + +updateAtMatrix :: HList Fin ns -> (a -> a) -> Matrix ns a -> Matrix ns a +updateAtMatrix EmptyHList _ mat = mat +updateAtMatrix (n :< ns) f mat = + onMatrixTF (updateAtVec n (onMatrix (updateAtMatrix ns f))) mat + +setAtMatrix :: HList Fin ns -> a -> Matrix ns a -> Matrix ns a +setAtMatrix fins a = updateAtMatrix fins (const a) + +---------------------- +-- Matrix Instances -- +---------------------- + +deriving instance (Eq (MatrixTF ns a)) => Eq (Matrix ns a) + +deriving instance (Ord (MatrixTF ns a)) => Ord (Matrix ns a) + +deriving instance (Show (MatrixTF ns a)) => Show (Matrix ns a) + +instance SingI ns => Functor (Matrix ns) where + fmap :: (a -> b) -> Matrix ns a -> Matrix ns b + fmap = fmapSingMatrix (sing @_ @ns) + +instance SingI ns => Data.Foldable.Foldable (Matrix ns) where + foldr :: (a -> b -> b) -> b -> Matrix ns a -> b + foldr comb b = Data.Foldable.foldr comb b . toListMatrix (sing @_ @ns) + + toList :: Matrix ns a -> [a] + toList = toListMatrix (sing @_ @ns) + +instance SingI ns => Distributive (Matrix ns) where + distribute :: Functor f => f (Matrix ns a) -> Matrix ns (f a) + distribute = distributeRep + +instance SingI ns => Representable (Matrix ns) where + type Rep (Matrix ns) = HList Fin ns + + tabulate :: (HList Fin ns -> a) -> Matrix ns a + tabulate = genMatrix_ + + index :: Matrix ns a -> HList Fin ns -> a + index = flip indexMatrix + +instance Num a => Num (Matrix '[] a) where + Matrix a + Matrix b = Matrix (a + b) + + Matrix a * Matrix b = Matrix (a * b) + + Matrix a - Matrix b = Matrix (a - b) + + abs (Matrix a) = Matrix (abs a) + + signum (Matrix a) = Matrix (signum a) + + fromInteger :: Integer -> Matrix '[] a + fromInteger = Matrix . fromInteger + +instance SingI ns => Applicative (Matrix ns) where + pure :: a -> Matrix ns a + pure = pureRep + + (<*>) :: Matrix ns (a -> b) -> Matrix ns a -> Matrix ns b + (<*>) = apRep + +instance SingI ns => Monad (Matrix ns) where + (>>=) :: Matrix ns a -> (a -> Matrix ns b) -> Matrix ns b + (>>=) = bindRep diff --git a/src/Termonad/FocusList.hs b/src/Termonad/FocusList.hs deleted file mode 100644 --- a/src/Termonad/FocusList.hs +++ /dev/null @@ -1,830 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - -module Termonad.FocusList where - -import Termonad.Prelude - -import Control.Lens -import qualified Data.Foldable as Foldable -import Test.QuickCheck -import Text.Show (Show(showsPrec), ShowS, showParen, showString) - --- $setup --- >>> :set -XFlexibleContexts --- >>> :set -XScopedTypeVariables - -data Focus = Focus {-# UNPACK #-} !Int | NoFocus deriving (Eq, Generic, Read, Show) - --- | 'NoFocus' is always less than 'Focus'. --- --- prop> NoFocus < Focus a -instance Ord Focus where - compare :: Focus -> Focus -> Ordering - compare NoFocus NoFocus = EQ - compare NoFocus (Focus _) = LT - compare (Focus _) NoFocus = GT - compare (Focus a) (Focus b) = compare a b - -instance CoArbitrary Focus - -foldFocus :: b -> (Int -> b) -> Focus -> b -foldFocus b _ NoFocus = b -foldFocus _ f (Focus i) = f i - -_Focus :: Prism' Focus Int -_Focus = prism' Focus (foldFocus Nothing Just) - -_NoFocus :: Prism' Focus () -_NoFocus = prism' (const NoFocus) (foldFocus (Just ()) (const Nothing)) - -hasFocus :: Focus -> Bool -hasFocus NoFocus = False -hasFocus (Focus _) = True - -unsafeGetFocus :: Focus -> Int -unsafeGetFocus NoFocus = error "unsafeGetFocus: NoFocus" -unsafeGetFocus (Focus i) = i - --- TODO: Probably be better --- implemented as an Order statistic tree --- (https://en.wikipedia.org/wiki/Order_statistic_tree). -data FocusList a = FocusList - { focusListFocus :: !Focus - , focusListLen :: {-# UNPACK #-} !Int - , focusList :: !(IntMap a) - } deriving (Eq, Generic) - -$(makeLensesFor - [ ("focusListFocus", "lensFocusListFocus") - , ("focusListLen", "lensFocusListLen") - , ("focusList", "lensFocusList") - ] - ''FocusList - ) - -instance Functor FocusList where - fmap :: (a -> b) -> FocusList a -> FocusList b - fmap f (FocusList focus len intmap) = FocusList focus len (fmap f intmap) - -instance Foldable FocusList where - foldr f b (FocusList _ _ intmap) = Foldable.foldr f b intmap - -instance Traversable FocusList where - traverse :: Applicative f => (a -> f b) -> FocusList a -> f (FocusList b) - traverse f (FocusList focus len intmap) = FocusList focus len <$> traverse f intmap - -type instance Element (FocusList a) = a - -instance MonoFunctor (FocusList a) - -instance MonoFoldable (FocusList a) - -instance MonoTraversable (FocusList a) - -instance Arbitrary1 FocusList where - liftArbitrary :: Gen a -> Gen (FocusList a) - liftArbitrary genA = do - arbList <- liftArbitrary genA - case arbList of - [] -> pure emptyFL - (_:_) -> do - let listLen = length arbList - len <- choose (0, listLen - 1) - pure $ unsafeFLFromList (Focus len) arbList - -instance Arbitrary a => Arbitrary (FocusList a) where - arbitrary = arbitrary1 - -instance CoArbitrary a => CoArbitrary (FocusList a) - -debugFL :: Show a => FocusList a -> String -debugFL FocusList{..} = - showString "FocusList {" . - showString "focusListFocus = " . - showsPrec 0 focusListFocus . - showString ", " . - showString "focusListLen = " . - showsPrec 0 focusListLen . - showString ", " . - showString "focusList = " . - showsPrec 0 focusList $ - showString "}" "" - -instance Show a => Show (FocusList a) where - showsPrec :: Int -> FocusList a -> ShowS - showsPrec d FocusList{..} = - let list = fmap snd $ sortOn fst $ mapToList focusList - in - showParen (d > 10) $ - showString "FocusList " . - showsPrec 11 focusListFocus . - showString " " . - showsPrec 11 list - -lensFocusListAt :: Int -> Lens' (FocusList a) (Maybe a) -lensFocusListAt i = lensFocusList . at i - --- | This is an invariant that the 'FocusList' must always protect. -invariantFL :: FocusList a -> Bool -invariantFL fl = - invariantFocusNotNeg && - invariantFocusInMap && - invariantFocusIfLenGT0 && - invariantLenIsCorrect && - invariantNoSkippedNumsInMap - where - -- This makes sure that the 'Focus' in a 'FocusList' can never be negative. - invariantFocusNotNeg :: Bool - invariantFocusNotNeg = - case fl ^. lensFocusListFocus of - NoFocus -> True - Focus i -> i >= 0 - - -- | This makes sure that if there is a 'Focus', then it actually exists in - -- the 'FocusList'. - invariantFocusInMap :: Bool - invariantFocusInMap = - case fl ^. lensFocusListFocus of - NoFocus -> length (fl ^. lensFocusList) == 0 - Focus i -> - case lookup i (fl ^. lensFocusList) of - Nothing -> False - Just _ -> True - - -- | This makes sure that there needs to be a 'Focus' if the length of the - -- 'FocusList' is greater than 0. - invariantFocusIfLenGT0 :: Bool - invariantFocusIfLenGT0 = - let len = fl ^. lensFocusListLen - focus = fl ^. lensFocusListFocus - in - case focus of - Focus _ -> len /= 0 - NoFocus -> len == 0 - - -- | Make sure that the length of the 'FocusList' is actually the number of - -- elements in the inner 'IntMap'. - invariantLenIsCorrect :: Bool - invariantLenIsCorrect = - let len = fl ^. lensFocusListLen - intmap = fl ^. lensFocusList - in len == length intmap - - -- | Make sure that there are no numbers that have been skipped in the - -- inner 'IntMap'. - invariantNoSkippedNumsInMap :: Bool - invariantNoSkippedNumsInMap = - let len = fl ^. lensFocusListLen - intmap = fl ^. lensFocusList - indexes = sort $ fmap fst $ mapToList intmap - in indexes == [0..(len - 1)] - - --- | Unsafely create a 'FocusList'. This does not check that the focus --- actually exists in the list. --- --- >>> let fl = unsafeFLFromList (Focus 1) [0..2] --- >>> debugFL fl --- "FocusList {focusListFocus = Focus 1, focusListLen = 3, focusList = fromList [(0,0),(1,1),(2,2)]}" --- --- >>> let fl = unsafeFLFromList NoFocus [] --- >>> debugFL fl --- "FocusList {focusListFocus = NoFocus, focusListLen = 0, focusList = fromList []}" -unsafeFLFromList :: Focus -> [a] -> FocusList a -unsafeFLFromList focus list = - let len = length list - in - FocusList - { focusListFocus = focus - , focusListLen = len - , focusList = mapFromList $ zip [0..] list - } - -focusItemGetter :: Getter (FocusList a) (Maybe a) -focusItemGetter = to getFLFocusItem - --- | Safely create a 'FocusList' from a list. --- --- >>> flFromList (Focus 1) ["cat","dog","goat"] --- Just (FocusList (Focus 1) ["cat","dog","goat"]) --- --- >>> flFromList NoFocus [] --- Just (FocusList NoFocus []) --- --- If the 'Focus' is out of range for the list, then 'Nothing' will be returned. --- --- >>> flFromList (Focus (-1)) ["cat","dog","goat"] --- Nothing --- --- >>> flFromList (Focus 3) ["cat","dog","goat"] --- Nothing --- --- >>> flFromList NoFocus ["cat","dog","goat"] --- Nothing -flFromList :: Focus -> [a] -> Maybe (FocusList a) -flFromList NoFocus [] = Just emptyFL -flFromList _ [] = Nothing -flFromList NoFocus (_:_) = Nothing -flFromList (Focus i) list = - let len = length list - in - if i < 0 || i >= len - then Nothing - else - Just $ - FocusList - { focusListFocus = Focus i - , focusListLen = len - , focusList = mapFromList $ zip [0..] list - } - --- | Create a 'FocusList' with a single element. --- --- >>> singletonFL "hello" --- FocusList (Focus 0) ["hello"] -singletonFL :: a -> FocusList a -singletonFL a = - FocusList - { focusListFocus = Focus 0 - , focusListLen = 1 - , focusList = singletonMap 0 a - } - --- | Create an empty 'FocusList' without a 'Focus'. --- --- >>> emptyFL --- FocusList NoFocus [] -emptyFL :: FocusList a -emptyFL = - FocusList - { focusListFocus = NoFocus - , focusListLen = 0 - , focusList = mempty - } - --- | Return 'True' if the 'FocusList' is empty. --- --- >>> isEmptyFL emptyFL --- True --- --- >>> isEmptyFL $ singletonFL "hello" --- False --- --- Any 'FocusList' with a 'Focus' should never be empty. -isEmptyFL :: FocusList a -> Bool -isEmptyFL fl = fl ^. lensFocusListLen == 0 - --- | Append a value to the end of a 'FocusList'. --- --- This can be thought of as a \"snoc\" operation. --- --- >>> appendFL emptyFL "hello" --- FocusList (Focus 0) ["hello"] --- --- >>> appendFL (singletonFL "hello") "bye" --- FocusList (Focus 0) ["hello","bye"] --- --- Appending a value to an empty 'FocusList' is the same as using 'singletonFL'. --- --- prop> appendFL emptyFL a == singletonFL a -appendFL :: FocusList a -> a -> FocusList a -appendFL fl a = - if isEmptyFL fl - then singletonFL a - else unsafeInsertNewFL (fl ^. lensFocusListLen) a fl - --- | A combination of 'appendFL' and 'setFocusFL'. --- --- >>> let Just fl = flFromList (Focus 1) ["hello", "bye", "tree"] --- >>> appendSetFocusFL fl "pie" --- FocusList (Focus 3) ["hello","bye","tree","pie"] --- --- prop> (appendSetFocusFL fl a) ^. lensFocusListFocus /= fl ^. lensFocusListFocus -appendSetFocusFL :: FocusList a -> a -> FocusList a -appendSetFocusFL fl a = - let oldLen = fl ^. lensFocusListLen - in - case setFocusFL oldLen (appendFL fl a) of - Nothing -> error "Internal error with setting the focus. This should never happen." - Just newFL -> newFL - --- | Prepend a value to a 'FocusList'. --- --- This can be thought of as a \"cons\" operation. --- --- >>> prependFL "hello" emptyFL --- FocusList (Focus 0) ["hello"] --- --- The focus will be updated when prepending: --- --- >>> prependFL "bye" (singletonFL "hello") --- FocusList (Focus 1) ["bye","hello"] --- --- Prepending to a 'FocusList' will always update the 'Focus': --- --- prop> (fl ^. lensFocusListFocus) < (prependFL a fl ^. lensFocusListFocus) -prependFL :: a -> FocusList a -> FocusList a -prependFL a fl = - if isEmptyFL fl - then singletonFL a - else unsafeInsertNewFL 0 a $ unsafeShiftUpFrom 0 fl - --- | Unsafely get the 'Focus' from a 'FocusList'. If the 'Focus' is --- 'NoFocus', this function returns 'error'. -unsafeGetFLFocus :: FocusList a -> Int -unsafeGetFLFocus fl = - let focus = fl ^. lensFocusListFocus - in - case focus of - NoFocus -> error "unsafeGetFLFocus: the focus list doesn't have a focus" - Focus i -> i - --- | Unsafely get the value of the 'Focus' from a 'FocusList'. If the 'Focus' is --- 'NoFocus', this function returns 'error'. -unsafeGetFLFocusItem :: FocusList a -> a -unsafeGetFLFocusItem fl = - let focus = fl ^. lensFocusListFocus - in - case focus of - NoFocus -> error "unsafeGetFLFocusItem: the focus list doesn't have a focus" - Focus i -> - let intmap = fl ^. lensFocusList - in - case lookup i intmap of - Nothing -> - error $ - "unsafeGetFLFocusItem: internal error, i (" <> - show i <> - ") doesnt exist in intmap" - Just a -> a - -getFLFocusItem :: FocusList a -> Maybe a -getFLFocusItem fl = - let focus = fl ^. lensFocusListFocus - in - case focus of - NoFocus -> Nothing - Focus i -> - let intmap = fl ^. lensFocusList - in - case lookup i intmap of - Nothing -> - error $ - "getFLFocusItem: internal error, i (" <> - show i <> - ") doesnt exist in intmap" - Just a -> Just a - --- | Unsafely insert a new @a@ in a 'FocusList'. This sets the 'Int' value to --- @a@. The length of the 'FocusList' will be increased by 1. The --- 'FocusList's 'Focus' is not changed. --- --- If there is some value in the 'FocusList' already at the 'Int', then it will --- be overwritten. Also, the 'Int' is not checked to make sure it is above 0. --- --- This function is meant to be used after 'unsafeShiftUpFrom'. --- --- >>> let fl = unsafeShiftUpFrom 2 $ unsafeFLFromList (Focus 1) [0,1,200] --- >>> debugFL $ unsafeInsertNewFL 2 100 fl --- "FocusList {focusListFocus = Focus 1, focusListLen = 4, focusList = fromList [(0,0),(1,1),(2,100),(3,200)]}" --- --- >>> let fl = unsafeFLFromList NoFocus [] --- >>> debugFL $ unsafeInsertNewFL 0 100 fl --- "FocusList {focusListFocus = NoFocus, focusListLen = 1, focusList = fromList [(0,100)]}" -unsafeInsertNewFL :: Int -> a -> FocusList a -> FocusList a -unsafeInsertNewFL i a fl = - fl & - lensFocusListLen +~ 1 & - lensFocusListAt i ?~ a - --- | This unsafely shifts all values up in a 'FocusList' starting at a given --- index. It also updates the 'Focus' of the 'FocusList' if it has been --- shifted. This does not change the length of the 'FocusList'. --- --- It does not check that the 'Int' is greater than 0. It also does not check --- that there is a 'Focus'. --- --- ==== __EXAMPLES__ --- --- >>> let fl = unsafeShiftUpFrom 2 $ unsafeFLFromList (Focus 1) [0,1,200] --- >>> debugFL fl --- "FocusList {focusListFocus = Focus 1, focusListLen = 3, focusList = fromList [(0,0),(1,1),(3,200)]}" --- --- >>> let fl = unsafeShiftUpFrom 1 $ unsafeFLFromList (Focus 1) [0,1,200] --- >>> debugFL fl --- "FocusList {focusListFocus = Focus 2, focusListLen = 3, focusList = fromList [(0,0),(2,1),(3,200)]}" --- --- >>> let fl = unsafeShiftUpFrom 0 $ unsafeFLFromList (Focus 1) [0,1,200] --- >>> debugFL fl --- "FocusList {focusListFocus = Focus 2, focusListLen = 3, focusList = fromList [(1,0),(2,1),(3,200)]}" --- --- >>> let fl = unsafeShiftUpFrom 0 $ unsafeFLFromList (Focus 1) [0,1,200] --- >>> debugFL fl --- "FocusList {focusListFocus = Focus 2, focusListLen = 3, focusList = fromList [(1,0),(2,1),(3,200)]}" -unsafeShiftUpFrom :: forall a. Int -> FocusList a -> FocusList a -unsafeShiftUpFrom i fl = - let intMap = fl ^. lensFocusList - lastElemIdx = (fl ^. lensFocusListLen) - 1 - newIntMap = go i lastElemIdx intMap - oldFocus = unsafeGetFLFocus fl - newFocus = if i > oldFocus then oldFocus else oldFocus + 1 - in - fl & - lensFocusList .~ newIntMap & - lensFocusListFocus .~ Focus newFocus - where - go :: Int -> Int -> IntMap a -> IntMap a - go idxToInsert idxToShiftUp intMap - | idxToInsert <= idxToShiftUp = - let val = unsafeLookup idxToShiftUp intMap - newMap = - insertMap (idxToShiftUp + 1) val (deleteMap idxToShiftUp intMap) - in go idxToInsert (idxToShiftUp - 1) newMap - | otherwise = intMap - --- | This is an unsafe lookup function. This assumes that the 'Int' exists in --- the 'IntMap'. -unsafeLookup :: Int -> IntMap a -> a -unsafeLookup i intmap = - case lookup i intmap of - Nothing -> error $ "unsafeLookup: key " <> show i <> " not found in intmap" - Just a -> a - -lookupFL :: Int -> FocusList a -> Maybe a -lookupFL i fl = lookup i (fl ^. lensFocusList) - --- | Insert a new value into the 'FocusList'. The 'Focus' of the list is --- changed appropriately. --- --- >>> insertFL 0 "hello" emptyFL --- Just (FocusList (Focus 0) ["hello"]) --- --- >>> insertFL 0 "hello" (singletonFL "bye") --- Just (FocusList (Focus 1) ["hello","bye"]) --- --- >>> insertFL 1 "hello" (singletonFL "bye") --- Just (FocusList (Focus 0) ["bye","hello"]) --- --- This returns 'Nothing' if the index at which to insert the new value is --- either less than 0 or greater than the length of the list. --- --- >>> insertFL 100 "hello" emptyFL --- Nothing --- --- >>> insertFL 100 "bye" (singletonFL "hello") --- Nothing --- --- >>> insertFL (-1) "bye" (singletonFL "hello") --- Nothing -insertFL - :: Int -- ^ The index at which to insert the value. - -> a - -> FocusList a - -> Maybe (FocusList a) -insertFL i a fl - | i < 0 || i > (fl ^. lensFocusListLen) = - -- Return Nothing if the insertion position is out of bounds. - Nothing - | i == 0 && isEmptyFL fl = - -- Return a 'FocusList' with one element if the insertion position is 0 - -- and the 'FocusList' is empty. - Just $ singletonFL a - | otherwise = - -- Shift all existing values up one and insert the new - -- value in the opened place. - let shiftedUpFL = unsafeShiftUpFrom i fl - in Just $ unsafeInsertNewFL i a shiftedUpFL - --- | Unsafely remove a value from a 'FocusList'. It effectively leaves a hole --- inside the 'FocusList'. It updates the length of the 'FocusList'. --- --- This function does not check that a value actually exists in the --- 'FocusList'. It also does not update the 'Focus'. --- --- This function does update the length of the 'FocusList'. --- --- >>> debugFL $ unsafeRemove 1 $ unsafeFLFromList (Focus 0) [0..2] --- "FocusList {focusListFocus = Focus 0, focusListLen = 2, focusList = fromList [(0,0),(2,2)]}" --- --- >>> debugFL $ unsafeRemove 0 $ unsafeFLFromList (Focus 0) [0..2] --- "FocusList {focusListFocus = Focus 0, focusListLen = 2, focusList = fromList [(1,1),(2,2)]}" --- --- Trying to remove the last element is completely safe (unless, of course, it --- is the 'Focus'): --- --- >>> debugFL $ unsafeRemove 2 $ unsafeFLFromList (Focus 2) [0..2] --- "FocusList {focusListFocus = Focus 2, focusListLen = 2, focusList = fromList [(0,0),(1,1)]}" --- --- If this function is passed an empty 'FocusList', it will make the length -1. --- --- >>> debugFL $ unsafeRemove 0 emptyFL --- "FocusList {focusListFocus = NoFocus, focusListLen = -1, focusList = fromList []}" -unsafeRemove - :: Int - -> FocusList a - -> FocusList a -unsafeRemove i fl = - fl & - lensFocusListLen -~ 1 & - lensFocusListAt i .~ Nothing - --- | This shifts all the values down in a 'FocusList' starting at a given --- index. It does not change the 'Focus' of the 'FocusList'. It does not change the --- length of the 'FocusList'. --- --- It does not check that shifting elements down will not overwrite other elements. --- This function is meant to be called after 'unsafeRemove'. --- --- >>> let fl = unsafeRemove 1 $ unsafeFLFromList (Focus 0) [0..2] --- >>> debugFL $ unsafeShiftDownFrom 1 fl --- "FocusList {focusListFocus = Focus 0, focusListLen = 2, focusList = fromList [(0,0),(1,2)]}" --- --- >>> let fl = unsafeRemove 0 $ unsafeFLFromList (Focus 0) [0..2] --- >>> debugFL $ unsafeShiftDownFrom 0 fl --- "FocusList {focusListFocus = Focus 0, focusListLen = 2, focusList = fromList [(0,1),(1,2)]}" --- --- Trying to shift down from the last element after it has been removed is a no-op: --- --- >>> let fl = unsafeRemove 2 $ unsafeFLFromList (Focus 0) [0..2] --- >>> debugFL $ unsafeShiftDownFrom 2 fl --- "FocusList {focusListFocus = Focus 0, focusListLen = 2, focusList = fromList [(0,0),(1,1)]}" -unsafeShiftDownFrom :: forall a. Int -> FocusList a -> FocusList a -unsafeShiftDownFrom i fl = - let intMap = fl ^. lensFocusList - len = fl ^. lensFocusListLen - newIntMap = go (i + 1) len intMap - in fl & lensFocusList .~ newIntMap - where - go :: Int -> Int -> IntMap a -> IntMap a - go idxToShiftDown len intMap - | idxToShiftDown < len + 1 = - let val = unsafeLookup idxToShiftDown intMap - newMap = - insertMap (idxToShiftDown - 1) val (deleteMap idxToShiftDown intMap) - in go (idxToShiftDown + 1) len newMap - | otherwise = intMap - --- | Remove an element from a 'FocusList'. --- --- If the element to remove is not the 'Focus', then update the 'Focus' --- accordingly. --- --- For example, if the 'Focus' is on index 1, and we have removed index 2, then --- the focus is not affected, so it is not changed. --- --- >>> let focusList = unsafeFLFromList (Focus 1) ["cat","goat","dog","hello"] --- >>> removeFL 2 focusList --- Just (FocusList (Focus 1) ["cat","goat","hello"]) --- --- If the 'Focus' is on index 2 and we have removed index 1, then the 'Focus' --- will be moved back one element to set to index 1. --- --- >>> let focusList = unsafeFLFromList (Focus 2) ["cat","goat","dog","hello"] --- >>> removeFL 1 focusList --- Just (FocusList (Focus 1) ["cat","dog","hello"]) --- --- If we remove the 'Focus', then the next item is set to have the 'Focus'. --- --- >>> let focusList = unsafeFLFromList (Focus 0) ["cat","goat","dog","hello"] --- >>> removeFL 0 focusList --- Just (FocusList (Focus 0) ["goat","dog","hello"]) --- --- If the element to remove is the only element in the list, then the 'Focus' --- will be set to 'NoFocus'. --- --- >>> let focusList = unsafeFLFromList (Focus 0) ["hello"] --- >>> removeFL 0 focusList --- Just (FocusList NoFocus []) --- --- If the 'Int' for the index to remove is either less than 0 or greater then --- the length of the list, then 'Nothing' is returned. --- --- >>> let focusList = unsafeFLFromList (Focus 0) ["hello"] --- >>> removeFL (-1) focusList --- Nothing --- --- >>> let focusList = unsafeFLFromList (Focus 1) ["hello","bye","cat"] --- >>> removeFL 3 focusList --- Nothing --- --- If the 'FocusList' passed in is 'Empty', then 'Nothing' is returned. --- --- >>> removeFL 0 emptyFL --- Nothing -removeFL - :: Int -- ^ Index of the element to remove from the 'FocusList'. - -> FocusList a -- ^ The 'FocusList' to remove an element from. - -> Maybe (FocusList a) -removeFL i fl - | i < 0 || i >= (fl ^. lensFocusListLen) || isEmptyFL fl = - -- Return Nothing if the removal position is out of bounds. - Nothing - | fl ^. lensFocusListLen == 1 = - -- Return an empty focus list if there is currently only one element - Just emptyFL - | otherwise = - let newFLWithHole = unsafeRemove i fl - newFL = unsafeShiftDownFrom i newFLWithHole - focus = unsafeGetFLFocus fl - in - if focus >= i && focus /= 0 - then Just $ newFL & lensFocusListFocus . _Focus -~ 1 - else Just newFL - --- | Find the index of the first element in the 'FocusList'. --- --- >>> let Just fl = flFromList (Focus 1) ["hello", "bye", "tree"] --- >>> indexOfFL "hello" fl --- Just 0 --- --- If more than one element exists, then return the index of the first one. --- --- >>> let Just fl = flFromList (Focus 1) ["dog", "cat", "cat"] --- >>> indexOfFL "cat" fl --- Just 1 --- --- If the element doesn't exist, then return 'Nothing' --- --- >>> let Just fl = flFromList (Focus 1) ["foo", "bar", "baz"] --- >>> indexOfFL "hogehoge" fl --- Nothing -indexOfFL :: Eq a => a -> FocusList a -> Maybe Int -indexOfFL a fl = - let intmap = focusList fl - keyVals = sortOn fst $ mapToList intmap - maybeKeyVal = find (\(_, val) -> val == a) keyVals - in fmap fst maybeKeyVal - --- | Delete an element from a 'FocusList'. --- --- >>> let Just fl = flFromList (Focus 0) ["hello", "bye", "tree"] --- >>> deleteFL "bye" fl --- FocusList (Focus 0) ["hello","tree"] --- --- The focus will be updated if an item before it is deleted. --- --- >>> let Just fl = flFromList (Focus 1) ["hello", "bye", "tree"] --- >>> deleteFL "hello" fl --- FocusList (Focus 0) ["bye","tree"] --- --- If there are multiple matching elements in the 'FocusList', remove them all. --- --- >>> let Just fl = flFromList (Focus 0) ["hello", "bye", "bye"] --- >>> deleteFL "bye" fl --- FocusList (Focus 0) ["hello"] --- --- If there are no matching elements, return the original 'FocusList'. --- --- >>> let Just fl = flFromList (Focus 2) ["hello", "good", "bye"] --- >>> deleteFL "frog" fl --- FocusList (Focus 2) ["hello","good","bye"] -deleteFL - :: forall a. - (Eq a) - => a - -> FocusList a - -> FocusList a -deleteFL item = go - where - go :: FocusList a -> FocusList a - go fl = - let maybeIndex = indexOfFL item fl - in - case maybeIndex of - Nothing -> fl - Just i -> - let maybeNewFL = removeFL i fl - in - case maybeNewFL of - Nothing -> fl - Just newFL -> go newFL - --- | Set the 'Focus' for a 'FocusList'. --- --- This is just like 'updateFocusFL', but doesn't return the new focused item. --- --- prop> setFocusFL i fl == fmap snd (updateFocusFL i fl) -setFocusFL :: Int -> FocusList a -> Maybe (FocusList a) -setFocusFL i fl - -- Can't set a 'Focus' for an empty 'FocusList'. - | isEmptyFL fl = Nothing - | otherwise = - let len = fl ^. lensFocusListLen - in - if i < 0 || i >= len - then Nothing - else Just $ fl & lensFocusListFocus . _Focus .~ i - --- | Update the 'Focus' for a 'FocusList' and get the new focused element. --- --- >>> updateFocusFL 1 =<< flFromList (Focus 2) ["hello","bye","dog","cat"] --- Just ("bye",FocusList (Focus 1) ["hello","bye","dog","cat"]) --- --- If the 'FocusList' is empty, then return 'Nothing'. --- --- >>> updateFocusFL 1 emptyFL --- Nothing --- --- If the new focus is less than 0, or greater than or equal to the length of --- the 'FocusList', then return 'Nothing'. --- --- >>> updateFocusFL (-1) =<< flFromList (Focus 2) ["hello","bye","dog","cat"] --- Nothing --- --- >>> updateFocusFL 4 =<< flFromList (Focus 2) ["hello","bye","dog","cat"] --- Nothing -updateFocusFL :: Int -> FocusList a -> Maybe (a, FocusList a) -updateFocusFL i fl - | isEmptyFL fl = Nothing - | otherwise = - let len = fl ^. lensFocusListLen - in - if i < 0 || i >= len - then Nothing - else - let newFL = fl & lensFocusListFocus . _Focus .~ i - in Just (unsafeGetFLFocusItem newFL, newFL) - --- | Find a value in a 'FocusList'. Similar to @Data.List.'Data.List.find'@. --- --- >>> let Just fl = flFromList (Focus 1) ["hello", "bye", "tree"] --- >>> findFL (\_ a -> a == "hello") fl --- Just (0,"hello") --- --- This will only find the first value. --- --- >>> let Just fl = flFromList (Focus 0) ["hello", "bye", "bye"] --- >>> findFL (\_ a -> a == "bye") fl --- Just (1,"bye") --- --- If no values match the comparison, this will return 'Nothing'. --- --- >>> let Just fl = flFromList (Focus 1) ["hello", "bye", "parrot"] --- >>> findFL (\_ a -> a == "ball") fl --- Nothing -findFL :: (Int -> a -> Bool) -> FocusList a -> Maybe (Int, a) -findFL f fl = - let intmap = fl ^. lensFocusList - vals = sortOn fst $ mapToList intmap - in find (\(i, a) -> f i a) vals - - --- | Move an existing item in a 'FocusList' to a new index. --- --- The 'Focus' gets updated appropriately when moving items. --- --- >>> let Just fl = flFromList (Focus 1) ["hello", "bye", "parrot"] --- >>> moveFromToFL 0 1 fl --- Just (FocusList (Focus 0) ["bye","hello","parrot"]) --- --- The 'Focus' may not get updated if it is not involved. --- --- >>> let Just fl = flFromList (Focus 0) ["hello", "bye", "parrot"] --- >>> moveFromToFL 1 2 fl --- Just (FocusList (Focus 0) ["hello","parrot","bye"]) --- --- If the element with the 'Focus' is moved, then the 'Focus' will be updated appropriately. --- --- >>> let Just fl = flFromList (Focus 2) ["hello", "bye", "parrot"] --- >>> moveFromToFL 2 0 fl --- Just (FocusList (Focus 0) ["parrot","hello","bye"]) --- --- If the index of the item to move is out bounds, then 'Nothing' will be returned. --- --- >>> let Just fl = flFromList (Focus 2) ["hello", "bye", "parrot"] --- >>> moveFromToFL 3 0 fl --- Nothing --- --- If the new index is out of bounds, then 'Nothing' wil be returned. --- --- >>> let Just fl = flFromList (Focus 2) ["hello", "bye", "parrot"] --- >>> moveFromToFL 1 (-1) fl --- Nothing -moveFromToFL - :: Show a => Int -- ^ Index of the item to move. - -> Int -- ^ New index for the item. - -> FocusList a - -> Maybe (FocusList a) -moveFromToFL oldPos newPos fl - | oldPos < 0 || oldPos >= length fl = Nothing - | newPos < 0 || newPos >= length fl = Nothing - | otherwise = - let oldFocus = fl ^. lensFocusListFocus - in - case lookupFL oldPos fl of - Nothing -> error "moveFromToFL should have been able to lookup the item" - Just item -> - case removeFL oldPos fl of - Nothing -> error "moveFromToFL should have been able to remove old position" - Just flAfterRemove -> - case insertFL newPos item flAfterRemove of - Nothing -> error "moveFromToFL should have been able to reinsert the item" - Just flAfterInsert -> - if Focus oldPos == oldFocus - then - case setFocusFL newPos flAfterInsert of - Nothing -> error "moveFromToFL should have been able to reset the focus" - Just flWithUpdatedFocus -> Just flWithUpdatedFocus - else Just flAfterInsert diff --git a/src/Termonad/Gtk.hs b/src/Termonad/Gtk.hs --- a/src/Termonad/Gtk.hs +++ b/src/Termonad/Gtk.hs @@ -4,14 +4,14 @@ import Termonad.Prelude +import Data.GI.Base (ManagedPtr, withManagedPtr) import GHC.Stack (HasCallStack) import GI.Gdk ( GObject - , ManagedPtr , castTo ) import GI.Gio (ApplicationFlags) -import GI.Gtk (Application, applicationNew, builderGetObject) +import GI.Gtk (Application, IsWidget, Widget(Widget), applicationNew, builderGetObject, toWidget) import qualified GI.Gtk as Gtk @@ -31,9 +31,31 @@ " from builder, but couldn't convert to object!" Just obj -> pure obj -appNew :: (HasCallStack, MonadIO m) => Maybe Text -> [ApplicationFlags] -> m Application +-- | Unsafely creates a new 'Application'. This calls 'fail' if it cannot +-- create the 'Application' for some reason. +-- +-- This can fail for different reasons, one of which being that application +-- name does not have a period in it. +appNew :: + (HasCallStack, MonadIO m) + => Maybe Text + -- ^ The application name. Must have a period in it if specified. If passed + -- as 'Nothing', then no application name will be used. + -> [ApplicationFlags] + -> m Application appNew appName appFlags = do maybeApp <- applicationNew appName appFlags case maybeApp of Nothing -> fail "Could not create application for some reason!" Just app -> pure app + +-- | Tests to see if two GTK widgets point to the same thing. This should only +-- happen if they are actually the same thing. +widgetEq :: (MonadIO m, IsWidget a, IsWidget b) => a -> b -> m Bool +widgetEq a b = do + Widget managedPtrA <- toWidget a + Widget managedPtrB <- toWidget b + liftIO $ + withManagedPtr managedPtrA $ \ptrA -> + withManagedPtr managedPtrB $ \ptrB -> + pure (ptrA == ptrB) diff --git a/src/Termonad/Keys.hs b/src/Termonad/Keys.hs --- a/src/Termonad/Keys.hs +++ b/src/Termonad/Keys.hs @@ -6,6 +6,7 @@ import Control.Lens (imap) import GI.Gdk ( EventKey + , pattern KEY_0 , pattern KEY_1 , pattern KEY_2 , pattern KEY_3 @@ -71,6 +72,7 @@ , KEY_7 , KEY_8 , KEY_9 + , KEY_0 ] altNumKeys = imap diff --git a/src/Termonad/Lenses.hs b/src/Termonad/Lenses.hs new file mode 100644 --- /dev/null +++ b/src/Termonad/Lenses.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Termonad.Lenses where + +import Control.Lens (makeLensesFor, makePrisms) +import Termonad.Types + +$(makeLensesFor + [ ("term", "lensTerm") + , ("pid", "lensPid") + , ("unique", "lensUnique") + ] + ''TMTerm + ) + +$(makeLensesFor + [ ("tmNotebookTabTermContainer", "lensTMNotebookTabTermContainer") + , ("tmNotebookTabTerm", "lensTMNotebookTabTerm") + , ("tmNotebookTabLabel", "lensTMNotebookTabLabel") + ] + ''TMNotebookTab + ) + +$(makeLensesFor + [ ("tmNotebook", "lensTMNotebook") + , ("tmNotebookTabs", "lensTMNotebookTabs") + ] + ''TMNotebook + ) + +$(makeLensesFor + [ ("tmStateApp", "lensTMStateApp") + , ("tmStateAppWin", "lensTMStateAppWin") + , ("tmStateNotebook", "lensTMStateNotebook") + , ("tmStateFontDesc", "lensTMStateFontDesc") + , ("tmStateConfig", "lensTMStateConfig") + , ("tmStateUserReqExit", "lensTMStateUserReqExit") + ] + ''TMState' + ) + +$(makePrisms ''FontSize) + +$(makeLensesFor + [ ("fontFamily", "lensFontFamily") + , ("fontSize", "lensFontSize") + ] + ''FontConfig + ) + +$(makeLensesFor + [ ("fontConfig", "lensFontConfig") + , ("showScrollbar", "lensShowScrollbar") + , ("colourConfig", "lensColourConfig") + , ("scrollbackLen", "lensScrollbackLen") + , ("confirmExit", "lensConfirmExit") + , ("wordCharExceptions", "lensWordCharExceptions") + , ("showMenu", "lensShowMenu") + , ("showTabBar", "lensShowTabBar") + , ("cursorBlinkMode", "lensCursorBlinkMode") + ] + ''ConfigOptions + ) + +$(makeLensesFor + [ ("createTermHook", "lensCreateTermHook") + ] + ''ConfigHooks + ) + +$(makeLensesFor + [ ("options", "lensOptions") + , ("hooks", "lensHooks") + ] + ''TMConfig + ) diff --git a/src/Termonad/Prelude.hs b/src/Termonad/Prelude.hs --- a/src/Termonad/Prelude.hs +++ b/src/Termonad/Prelude.hs @@ -1,8 +1,11 @@ -{-# LANGUAGE NoImplicitPrelude #-} - module Termonad.Prelude ( module X + , whenJust ) where +import Control.Lens as X ((&)) import ClassyPrelude as X import Data.Proxy as X + +whenJust :: Monoid m => Maybe a -> (a -> m) -> m +whenJust = flip foldMap diff --git a/src/Termonad/Term.hs b/src/Termonad/Term.hs --- a/src/Termonad/Term.hs +++ b/src/Termonad/Term.hs @@ -5,7 +5,8 @@ import Termonad.Prelude import Control.Lens ((^.), (&), (.~), set, to) -import Data.Colour.SRGB (RGB(RGB), toSRGB) +import Data.Colour.SRGB (Colour, RGB(RGB), toSRGB) +import Data.FocusList (appendFL, deleteFL, getFocusItemFL) import GI.Gdk ( EventKey , RGBA @@ -48,8 +49,10 @@ , noAdjustment , notebookAppendPage , notebookDetachTab + , notebookGetNPages , notebookPageNum , notebookSetCurrentPage + , notebookSetShowTabs , notebookSetTabReorderable , onButtonClicked , onWidgetKeyPressEvent @@ -59,51 +62,63 @@ , widgetDestroy , widgetGrabFocus , widgetSetCanFocus + , widgetSetFocusOnClick , widgetSetHalign , widgetSetHexpand , widgetShow + , windowSetFocus , windowSetTransientFor ) import GI.Pango (EllipsizeMode(EllipsizeModeMiddle)) import GI.Vte - ( CursorBlinkMode(CursorBlinkModeOn) - , PtyFlags(PtyFlagsDefault) + ( PtyFlags(PtyFlagsDefault) , Terminal , onTerminalChildExited , onTerminalWindowTitleChanged , terminalGetWindowTitle , terminalNew , terminalSetCursorBlinkMode - , terminalSetColorCursor , terminalSetFont , terminalSetScrollbackLines , terminalSpawnSync + , terminalSetWordCharExceptions ) import System.FilePath (()) import System.Directory (getSymbolicLinkTarget) +import System.Environment (lookupEnv) -import Termonad.Config (ShowScrollbar(..), TMConfig(cursorColor, scrollbackLen), lensShowScrollbar) -import Termonad.FocusList (appendFL, deleteFL, getFLFocusItem) -import Termonad.Types - ( TMNotebookTab - , TMState - , TMState'(TMState, tmStateConfig, tmStateFontDesc, tmStateNotebook) - , TMTerm - , createTMNotebookTab - , lensTerm +import Termonad.Lenses + ( lensConfirmExit + , lensOptions + , lensShowScrollbar + , lensShowTabBar , lensTMNotebookTabLabel - , lensTMNotebookTabs , lensTMNotebookTabTerm , lensTMNotebookTabTermContainer + , lensTMNotebookTabs , lensTMStateApp , lensTMStateConfig , lensTMStateNotebook + , lensTerm + ) +import Termonad.Types + ( ConfigHooks(createTermHook) + , ConfigOptions(scrollbackLen, wordCharExceptions, cursorBlinkMode) + , ShowScrollbar(..) + , ShowTabBar(..) + , TMConfig(hooks, options) + , TMNotebookTab + , TMState + , TMState'(TMState, tmStateAppWin, tmStateConfig, tmStateFontDesc, tmStateNotebook) + , TMTerm + , assertInvariantTMState + , createTMNotebookTab , newTMTerm , pid , tmNotebook - , tmNotebookTabs , tmNotebookTabTerm , tmNotebookTabTermContainer + , tmNotebookTabs ) focusTerm :: Int -> TMState -> IO () @@ -118,11 +133,18 @@ termExitFocused mvarTMState = do tmState <- readMVar mvarTMState let maybeTab = - tmState ^. lensTMStateNotebook . lensTMNotebookTabs . to getFLFocusItem + tmState ^. lensTMStateNotebook . lensTMNotebookTabs . to getFocusItemFL case maybeTab of Nothing -> pure () - Just tab -> termExitWithConfirmation tab mvarTMState + Just tab -> termClose tab mvarTMState +termClose :: TMNotebookTab -> TMState -> IO () +termClose tab mvarTMState = do + tmState <- readMVar mvarTMState + let confirm = tmState ^. lensTMStateConfig . lensOptions . lensConfirmExit + close = if confirm then termExitWithConfirmation else termExit + close tab mvarTMState + termExitWithConfirmation :: TMNotebookTab -> TMState -> IO () termExitWithConfirmation tab mvarTMState = do tmState <- readMVar mvarTMState @@ -185,7 +207,7 @@ relabelTab notebook label scrolledWin term' = do pageNum <- notebookPageNum notebook scrolledWin maybeTitle <- terminalGetWindowTitle term' - let title = fromMaybe "bash" maybeTitle + let title = fromMaybe "shell" maybeTitle labelSetLabel label $ tshow (pageNum + 1) <> ". " <> title showScrollbarToPolicy :: ShowScrollbar -> PolicyType @@ -196,7 +218,7 @@ createScrolledWin :: TMState -> IO ScrolledWindow createScrolledWin mvarTMState = do tmState <- readMVar mvarTMState - let showScrollbarVal = tmState ^. lensTMStateConfig . lensShowScrollbar + let showScrollbarVal = tmState ^. lensTMStateConfig . lensOptions . lensShowScrollbar vScrollbarPolicy = showScrollbarToPolicy showScrollbarVal scrolledWin <- scrolledWindowNew noAdjustment noAdjustment widgetShow scrolledWin @@ -219,17 +241,29 @@ containerAdd box label containerAdd box button widgetSetCanFocus button False + widgetSetFocusOnClick button False widgetSetCanFocus label False + widgetSetFocusOnClick label False widgetSetCanFocus box False + widgetSetFocusOnClick box False widgetShow box widgetShow label widgetShow button pure (box, label, button) -getCursorColor :: TMConfig -> IO RGBA -getCursorColor tmConfig = do - let color = cursorColor tmConfig - RGB red green blue = toSRGB color +setShowTabs :: TMConfig -> Notebook -> IO () +setShowTabs tmConfig note = do + npages <- notebookGetNPages note + let shouldShowTabs = + case tmConfig ^. lensOptions . lensShowTabBar of + ShowTabBarIfNeeded -> npages > 1 + ShowTabBarAlways -> True + ShowTabBarNever -> False + notebookSetShowTabs note shouldShowTabs + +toRGBA :: Colour Double -> IO RGBA +toRGBA colour = do + let RGB red green blue = toSRGB colour rgba <- newZeroRGBA setRGBARed rgba red setRGBAGreen rgba green @@ -259,24 +293,29 @@ createTerm :: (TMState -> EventKey -> IO Bool) -> TMState -> IO TMTerm createTerm handleKeyPress mvarTMState = do + assertInvariantTMState mvarTMState scrolledWin <- createScrolledWin mvarTMState - TMState{tmStateFontDesc, tmStateConfig, tmStateNotebook=currNote} <- readMVar mvarTMState - let maybeCurrFocusedTabPid = pid . tmNotebookTabTerm <$> getFLFocusItem (tmNotebookTabs currNote) + TMState{tmStateAppWin, tmStateFontDesc, tmStateConfig, tmStateNotebook=currNote} <- + readMVar mvarTMState + let maybeCurrFocusedTabPid = pid . tmNotebookTabTerm <$> getFocusItemFL (tmNotebookTabs currNote) maybeCurrDir <- maybe (pure Nothing) cwdOfPid maybeCurrFocusedTabPid vteTerm <- terminalNew terminalSetFont vteTerm (Just tmStateFontDesc) - terminalSetScrollbackLines vteTerm (fromIntegral (scrollbackLen tmStateConfig)) - cursorColor <- getCursorColor tmStateConfig - terminalSetColorCursor vteTerm (Just cursorColor) - terminalSetCursorBlinkMode vteTerm CursorBlinkModeOn + let curOpts = options tmStateConfig + terminalSetWordCharExceptions vteTerm $ wordCharExceptions curOpts + terminalSetScrollbackLines vteTerm (fromIntegral (scrollbackLen curOpts)) + terminalSetCursorBlinkMode vteTerm (cursorBlinkMode curOpts) widgetShow vteTerm - widgetGrabFocus $ vteTerm + -- Should probably use GI.Vte.Functions.getUserShell, but contrary to its + -- documentation it raises an exception rather wrap in Maybe. + mShell <- lookupEnv "SHELL" + let argv = fromMaybe ["/usr/bin/env", "bash"] (pure <$> mShell) terminalProcPid <- terminalSpawnSync vteTerm [PtyFlagsDefault] maybeCurrDir - ["/usr/bin/env", "bash"] + argv Nothing ([SpawnFlagsDefault] :: [SpawnFlags]) Nothing @@ -287,21 +326,21 @@ let notebookTab = createTMNotebookTab tabLabel scrolledWin tmTerm void $ onButtonClicked tabCloseButton $ - termExitWithConfirmation notebookTab mvarTMState - setCurrPageAction <- + termClose notebookTab mvarTMState + mvarReturnAction <- modifyMVar mvarTMState $ \tmState -> do let notebook = tmStateNotebook tmState note = tmNotebook notebook tabs = tmNotebookTabs notebook pageIndex <- notebookAppendPage note scrolledWin (Just tabLabelBox) notebookSetTabReorderable note scrolledWin True + setShowTabs (tmState ^. lensTMStateConfig) note let newTabs = appendFL tabs notebookTab newTMState = tmState & lensTMStateNotebook . lensTMNotebookTabs .~ newTabs - setCurrPageAction = do - notebookSetCurrentPage note pageIndex - pure (newTMState, setCurrPageAction) - setCurrPageAction + mvarReturnAction = notebookSetCurrentPage note pageIndex + pure (newTMState, mvarReturnAction) + mvarReturnAction relabelTab (tmNotebook currNote) tabLabel scrolledWin vteTerm void $ onTerminalWindowTitleChanged vteTerm $ do TMState{tmStateNotebook} <- readMVar mvarTMState @@ -310,4 +349,8 @@ void $ onWidgetKeyPressEvent vteTerm $ handleKeyPress mvarTMState void $ onWidgetKeyPressEvent scrolledWin $ handleKeyPress mvarTMState void $ onTerminalChildExited vteTerm $ \_ -> termExit notebookTab mvarTMState + widgetGrabFocus vteTerm + windowSetFocus tmStateAppWin (Just vteTerm) + assertInvariantTMState mvarTMState + createTermHook (hooks tmStateConfig) mvarTMState vteTerm pure tmTerm diff --git a/src/Termonad/Types.hs b/src/Termonad/Types.hs --- a/src/Termonad/Types.hs +++ b/src/Termonad/Types.hs @@ -1,30 +1,40 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StandaloneDeriving #-} module Termonad.Types where import Termonad.Prelude -import Control.Lens ((&), (.~), (^.), firstOf, makeLensesFor) +import Data.FocusList (FocusList, emptyFL, singletonFL, getFocusItemFL, lengthFL) import Data.Unique (Unique, hashUnique, newUnique) import GI.Gtk ( Application , ApplicationWindow + , IsWidget , Label , Notebook , ScrolledWindow + , Widget + , notebookGetCurrentPage + , notebookGetNthPage + , notebookGetNPages ) import GI.Pango (FontDescription) -import GI.Vte (Terminal) +import GI.Vte (Terminal, CursorBlinkMode(CursorBlinkModeOn)) import Text.Pretty.Simple (pPrint) import Text.Show (Show(showsPrec), ShowS, showParen, showString) -import Termonad.Config (TMConfig) -import Termonad.FocusList (FocusList, emptyFL, focusItemGetter, singletonFL) +import Termonad.Gtk (widgetEq) +-- | 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 +-- comparing terminals. data TMTerm = TMTerm { term :: !Terminal + -- ^ The actual 'Terminal'. , pid :: !Int + -- ^ The process ID of the process running in 'term'. , unique :: !Unique + -- ^ A 'Unique' for comparing different 'TMTerm' for uniqueness. } instance Show TMTerm where @@ -42,18 +52,16 @@ showsPrec (d + 1) (hashUnique unique) . showString "}" -$(makeLensesFor - [ ("term", "lensTerm") - , ("pid", "lensPid") - , ("unique", "lensUnique") - ] - ''TMTerm - ) - +-- | A container that holds everything in a given terminal window. The 'term' +-- in the 'TMTerm' is inside the 'tmNotebookTabTermContainer' 'ScrolledWindow'. +-- The notebook tab 'Label' is also available. data TMNotebookTab = TMNotebookTab { tmNotebookTabTermContainer :: !ScrolledWindow + -- ^ The 'ScrolledWindow' holding the VTE 'Terminal'. , tmNotebookTabTerm :: !TMTerm + -- ^ The 'Terminal' insidie the 'ScrolledWindow'. , tmNotebookTabLabel :: !Label + -- ^ The 'Label' holding the title of the 'Terminal' in the 'Notebook' tab. } instance Show TMNotebookTab where @@ -71,17 +79,13 @@ showString "(GI.GTK.Label)" . showString "}" -$(makeLensesFor - [ ("tmNotebookTabTermContainer", "lensTMNotebookTabTermContainer") - , ("tmNotebookTabTerm", "lensTMNotebookTabTerm") - , ("tmNotebookTabLabel", "lensTMNotebookTabLabel") - ] - ''TMNotebookTab - ) - +-- | This holds the GTK 'Notebook' containing multiple tabs of 'Terminal's. We +-- keep a separate list of terminals in 'tmNotebookTabs'. data TMNotebook = TMNotebook { tmNotebook :: !Notebook + -- ^ This is the GTK 'Notebook' that holds multiple tabs of 'Terminal's. , tmNotebookTabs :: !(FocusList TMNotebookTab) + -- ^ A 'FocusList' containing references to each individual 'TMNotebookTab'. } instance Show TMNotebook where @@ -96,28 +100,12 @@ showsPrec (d + 1) tmNotebookTabs . showString "}" -$(makeLensesFor - [ ("tmNotebook", "lensTMNotebook") - , ("tmNotebookTabs", "lensTMNotebookTabs") - ] - ''TMNotebook - ) - -data UserRequestedExit = UserRequestedExit | UserDidNotRequestExit deriving (Eq, Show) - data TMState' = TMState { tmStateApp :: !Application , tmStateAppWin :: !ApplicationWindow , tmStateNotebook :: !TMNotebook , tmStateFontDesc :: !FontDescription , tmStateConfig :: !TMConfig - , tmStateUserReqExit :: !UserRequestedExit - -- ^ This signifies whether or not the user has requested that Termonad - -- exit by either closing all terminals or clicking the exit button. If so, - -- 'tmStateUserReqExit' should have a value of 'UserRequestedExit'. However, - -- if the window manager requested Termonad to exit (probably through the user - -- trying to close Termonad through their window manager), then this will be - -- set to 'UserDidNotRequestExit'. } instance Show TMState' where @@ -139,22 +127,8 @@ showString ", " . showString "tmStateConfig = " . showsPrec (d + 1) tmStateConfig . - showString ", " . - showString "tmStateUserReqExit = " . - showsPrec (d + 1) tmStateUserReqExit . showString "}" -$(makeLensesFor - [ ("tmStateApp", "lensTMStateApp") - , ("tmStateAppWin", "lensTMStateAppWin") - , ("tmStateNotebook", "lensTMStateNotebook") - , ("tmStateFontDesc", "lensTMStateFontDesc") - , ("tmStateConfig", "lensTMStateConfig") - , ("tmStateUserReqExit", "lensTMStateUserReqExit") - ] - ''TMState' - ) - type TMState = MVar TMState' instance Eq TMTerm where @@ -178,6 +152,16 @@ unq <- newUnique pure $ createTMTerm trm pd unq +getFocusedTermFromState :: TMState -> IO (Maybe Terminal) +getFocusedTermFromState mvarTMState = + withMVar mvarTMState go + where + go :: TMState' -> IO (Maybe Terminal) + go tmState = do + let maybeNotebookTab = + getFocusItemFL $ tmNotebookTabs $ tmStateNotebook tmState + pure $ fmap (term . tmNotebookTabTerm) maybeNotebookTab + createTMNotebookTab :: Label -> ScrolledWindow -> TMTerm -> TMNotebookTab createTMNotebookTab tabLabel scrollWin trm = TMNotebookTab @@ -196,6 +180,16 @@ createEmptyTMNotebook :: Notebook -> TMNotebook createEmptyTMNotebook notebook = createTMNotebook notebook emptyFL +notebookToList :: Notebook -> IO [Widget] +notebookToList notebook = + unfoldHelper 0 [] + where unfoldHelper :: Int32 -> [Widget] -> IO [Widget] + unfoldHelper index32 acc = do + notePage <- notebookGetNthPage notebook index32 + case notePage of + 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 $ @@ -205,7 +199,6 @@ , tmStateNotebook = note , tmStateFontDesc = fontDesc , tmStateConfig = tmConfig - , tmStateUserReqExit = UserDidNotRequestExit } newEmptyTMState :: TMConfig -> Application -> ApplicationWindow -> Notebook -> FontDescription -> IO TMState @@ -217,7 +210,6 @@ , tmStateNotebook = createEmptyTMNotebook note , tmStateFontDesc = fontDesc , tmStateConfig = tmConfig - , tmStateUserReqExit = UserDidNotRequestExit } newTMStateSingleTerm :: @@ -243,32 +235,334 @@ tmState <- readMVar mvarTMState print tmState -pTraceShowMTMState :: TMState -> IO () -pTraceShowMTMState mvarTMState = do - tmState <- readMVar mvarTMState - pPrint tmState +------------ +-- Config -- +------------ -getFocusedTermFromState :: TMState -> IO (Maybe Terminal) -getFocusedTermFromState mvarTMState = do - withMVar - mvarTMState - ( pure . - firstOf - ( lensTMStateNotebook . - lensTMNotebookTabs . - focusItemGetter . - traverse . - lensTMNotebookTabTerm . - lensTerm - ) - ) +-- | The font size for the Termonad terminal. There are two ways to set the +-- fontsize, corresponding to the two different ways to set the font size in +-- the Pango font rendering library. +-- +-- If you're not sure which to use, try 'FontSizePoints' first and see how it +-- looks. It should generally correspond to font sizes you are used to from +-- other applications. +data FontSize + = FontSizePoints Int + -- ^ This sets the font size based on \"points\". The conversion between a + -- point and an actual size depends on the system configuration and the + -- output device. The function 'GI.Pango.fontDescriptionSetSize' is used + -- to set the font size. See the documentation for that function for more + -- info. + | FontSizeUnits Double + -- ^ This sets the font size based on \"device units\". In general, this + -- can be thought of as one pixel. The function + -- 'GI.Pango.fontDescriptionSetAbsoluteSize' is used to set the font size. + -- See the documentation for that function for more info. + deriving (Eq, Show) -setUserRequestedExit :: TMState -> IO () -setUserRequestedExit mvarTMState = do - modifyMVar_ mvarTMState $ \tmState -> do - pure $ tmState & lensTMStateUserReqExit .~ UserRequestedExit +-- | The default 'FontSize' used if not specified. +-- +-- >>> defaultFontSize +-- FontSizePoints 12 +defaultFontSize :: FontSize +defaultFontSize = FontSizePoints 12 -getUserRequestedExit :: TMState -> IO UserRequestedExit -getUserRequestedExit mvarTMState = do +-- | Settings for the font to be used in Termonad. +data FontConfig = FontConfig + { fontFamily :: !Text + -- ^ The font family to use. Example: @"DejaVu Sans Mono"@ or @"Source Code Pro"@ + , fontSize :: !FontSize + -- ^ The font size. + } deriving (Eq, Show) + +-- | The default 'FontConfig' to use if not specified. +-- +-- >>> defaultFontConfig == FontConfig {fontFamily = "Monospace", fontSize = defaultFontSize} +-- True +defaultFontConfig :: FontConfig +defaultFontConfig = + FontConfig + { fontFamily = "Monospace" + , fontSize = defaultFontSize + } + +-- | 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 +-- in a special state that is not representable by setting any specific value. +-- +-- Examples of this include the 'cursorFgColour' and 'cursorBgColour' options +-- 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'. +data Option a = Unset | Set !a + deriving (Show, Read, Eq, Ord, Functor, Foldable) + +-- | Run a function over the value contained in an 'Option'. Return 'mempty' +-- when 'Option' is 'Unset'. +-- +-- >>> whenSet (Set [1,2,3]) (++ [4,5,6]) :: [Int] +-- [1,2,3,4,5,6] +-- >>> whenSet Unset (++ [4,5,6]) :: [Int] +-- [] +whenSet :: Monoid m => Option a -> (a -> m) -> m +whenSet = \case + Unset -> \_ -> mempty + Set x -> \f -> f x + +-- | Whether or not to show the scroll bar in a terminal. +data ShowScrollbar + = ShowScrollbarNever -- ^ Never show the scroll bar, even if there are too + -- many lines on the terminal to show all at once. You + -- should still be able to scroll with the mouse wheel. + | ShowScrollbarAlways -- ^ Always show the scrollbar, even if it is not + -- needed. + | ShowScrollbarIfNeeded -- ^ Only show the scrollbar if there are too many + -- lines on the terminal to show all at once. + deriving (Eq, Show) + +-- | 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 + -- open. This may be confusing if you plan on using multiple tabs. + | ShowTabBarAlways -- ^ Always show the tab bar, even if you only have one tab open. + | ShowTabBarIfNeeded -- ^ Only show the tab bar if you have multiple tabs open. + deriving (Eq, Show) + +-- | Configuration options for Termonad. +-- +-- See 'defaultConfigOptions' for the default values. +data ConfigOptions = ConfigOptions + { fontConfig :: !FontConfig + -- ^ Specific options for fonts. + , showScrollbar :: !ShowScrollbar + -- ^ When to show the scroll bar. + , scrollbackLen :: !Integer + -- ^ The number of lines to keep in the scroll back history for each terminal. + , confirmExit :: !Bool + -- ^ Whether or not to ask you for confirmation when closing individual + -- terminals or Termonad itself. It is generally safer to keep this as + -- 'True'. + , wordCharExceptions :: !Text + -- ^ When double-clicking on text in the terminal with the mouse, Termonad + -- will use this value to determine what to highlight. The individual + -- characters in this list will be counted as part of a word. + -- + -- For instance if 'wordCharExceptions' is @""@, then when you double-click + -- on the text @http://@, only the @http@ portion will be highlighted. If + -- 'wordCharExceptions' is @":"@, then the @http:@ portion will be + -- highlighted. + , showMenu :: !Bool + -- ^ Whether or not to show the @File@ @Edit@ etc menu. + , showTabBar :: !ShowTabBar + -- ^ When to show the tab bar. + , cursorBlinkMode :: !CursorBlinkMode + -- ^ How to handle cursor blink. + } deriving (Eq, Show) + +-- | The default 'ConfigOptions'. +-- +-- >>> :{ +-- let defConfOpt = +-- ConfigOptions +-- { fontConfig = defaultFontConfig +-- , showScrollbar = ShowScrollbarIfNeeded +-- , scrollbackLen = 10000 +-- , confirmExit = True +-- , wordCharExceptions = "-#%&+,./=?@\\_~\183:" +-- , showMenu = True +-- , showTabBar = ShowTabBarIfNeeded +-- , cursorBlinkMode = CursorBlinkModeOn +-- } +-- in defaultConfigOptions == defConfOpt +-- :} +-- True +defaultConfigOptions :: ConfigOptions +defaultConfigOptions = + ConfigOptions + { fontConfig = defaultFontConfig + , showScrollbar = ShowScrollbarIfNeeded + , scrollbackLen = 10000 + , confirmExit = True + , wordCharExceptions = "-#%&+,./=?@\\_~\183:" + , showMenu = True + , showTabBar = ShowTabBarIfNeeded + , cursorBlinkMode = CursorBlinkModeOn + } + +-- | The Termonad 'ConfigOptions' along with the 'ConfigHooks'. +data TMConfig = TMConfig + { options :: !ConfigOptions + , hooks :: !ConfigHooks + } deriving Show + +-- | The default 'TMConfig'. +-- +-- 'options' is 'defaultConfigOptions' and 'hooks' is 'defaultConfigHooks'. +defaultTMConfig :: TMConfig +defaultTMConfig = + TMConfig + { options = defaultConfigOptions + , hooks = defaultConfigHooks + } + +--------------------- +-- ConfigHooks -- +--------------------- + +-- | Hooks into certain termonad operations and VTE events. Used to modify +-- termonad's behaviour in order to implement new functionality. Fields should +-- have sane @Semigroup@ and @Monoid@ instances so that config extensions can +-- be combined uniformly and new hooks can be added without incident. +data ConfigHooks = ConfigHooks { + -- | Produce an IO action to run on creation of new @Terminal@, given @TMState@ + -- and the @Terminal@ in question. + createTermHook :: TMState -> Terminal -> IO () +} + +instance Show ConfigHooks where + showsPrec :: Int -> ConfigHooks -> ShowS + showsPrec _ _ = + showString "ConfigHooks {" . + showString "createTermHook = " . + showString "}" + +-- | Default values for the 'ConfigHooks'. +-- +-- - The default function for 'createTermHook' is 'defaultCreateTermHook'. +defaultConfigHooks :: ConfigHooks +defaultConfigHooks = + ConfigHooks + { createTermHook = defaultCreateTermHook + } + +-- | Default value for 'createTermHook'. Does nothing. +defaultCreateTermHook :: TMState -> Terminal -> IO () +defaultCreateTermHook _ _ = pure () + +---------------- +-- Invariants -- +---------------- + +data FocusNotSameErr + = FocusListFocusExistsButNoNotebookTabWidget + | NotebookTabWidgetDiffersFromFocusListFocus + | NotebookTabWidgetExistsButNoFocusListFocus + deriving Show + +data TabsDoNotMatch + = TabLengthsDifferent Int Int -- ^ The first 'Int' is the number of tabs in the + -- actual GTK 'Notebook'. The second 'Int' is + -- the number of tabs in the 'FocusList'. + | TabAtIndexDifferent Int -- ^ The tab at index 'Int' is different between + -- the actual GTK 'Notebook' and the 'FocusList'. + deriving (Show) + +data TMStateInvariantErr + = 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 = + runInvariants + [ invariantFocusSame + , invariantTMTabLength + , invariantTabsAllMatch + ] + where + runInvariants :: [IO (Maybe TMStateInvariantErr)] -> IO [TMStateInvariantErr] + runInvariants = fmap catMaybes . sequence + + invariantFocusSame :: IO (Maybe TMStateInvariantErr) + invariantFocusSame = do + let tmNote = tmNotebook $ tmStateNotebook tmState + index32 <- notebookGetCurrentPage tmNote + maybeWidgetFromNote <- notebookGetNthPage tmNote index32 + let focusList = tmNotebookTabs $ tmStateNotebook tmState + maybeScrollWinFromFL = + fmap tmNotebookTabTermContainer $ getFocusItemFL $ focusList + idx = fromIntegral index32 + case (maybeWidgetFromNote, maybeScrollWinFromFL) of + (Nothing, Nothing) -> pure Nothing + (Just _, Nothing) -> + pure $ + Just $ + FocusNotSame NotebookTabWidgetExistsButNoFocusListFocus idx + (Nothing, Just _) -> + pure $ + Just $ + FocusNotSame FocusListFocusExistsButNoNotebookTabWidget idx + (Just widgetFromNote, Just scrollWinFromFL) -> do + isEq <- widgetEq widgetFromNote scrollWinFromFL + if isEq + then pure Nothing + else + pure $ + Just $ + FocusNotSame NotebookTabWidgetDiffersFromFocusListFocus idx + + invariantTMTabLength :: IO (Maybe TMStateInvariantErr) + invariantTMTabLength = do + let tmNote = tmNotebook $ tmStateNotebook tmState + noteLength32 <- notebookGetNPages tmNote + let noteLength = fromIntegral noteLength32 + focusListLength = lengthFL $ tmNotebookTabs $ tmStateNotebook tmState + lengthEqual = focusListLength == noteLength + if lengthEqual + then pure Nothing + else pure $ + Just $ + TabsDoNotMatch $ + TabLengthsDifferent noteLength focusListLength + + -- Turns a FocusList and Notebook into two lists of widgets and compares each widget for equality + invariantTabsAllMatch :: IO (Maybe TMStateInvariantErr) + invariantTabsAllMatch = do + let tmNote = tmNotebook $ tmStateNotebook tmState + focusList = tmNotebookTabs $ tmStateNotebook tmState + flList = fmap tmNotebookTabTermContainer $ toList focusList + noteList <- notebookToList tmNote + tabsMatch noteList flList + where + tabsMatch + :: forall a b + . (IsWidget a, IsWidget b) + => [a] + -> [b] + -> IO (Maybe TMStateInvariantErr) + tabsMatch xs ys = foldr go (pure Nothing) (zip3 xs ys [0..]) + where + go :: (a, b, Int) -> IO (Maybe TMStateInvariantErr) -> IO (Maybe TMStateInvariantErr) + go (x, y, i) acc = do + isEq <- widgetEq x y + if isEq + then acc + else pure . Just $ TabsDoNotMatch (TabAtIndexDifferent i) + +-- | Check the invariants for 'TMState', and call 'fail' if we find that they +-- have been violated. +assertInvariantTMState :: TMState -> IO () +assertInvariantTMState mvarTMState = do tmState <- readMVar mvarTMState - pure $ tmState ^. lensTMStateUserReqExit + assertValue <- invariantTMState' tmState + case assertValue of + [] x-> pure () + errs@(_:_) -> do + putStrLn "In assertInvariantTMState, some invariants for TMState are being violated." + putStrLn "\nInvariants violated:" + print errs + putStrLn "\nTMState:" + pPrint tmState + putStrLn "" + fail "Invariants violated for TMState" + +pPrintTMState :: TMState -> IO () +pPrintTMState mvarTMState = do + tmState <- readMVar mvarTMState + pPrint tmState diff --git a/termonad.cabal b/termonad.cabal --- a/termonad.cabal +++ b/termonad.cabal @@ -1,5 +1,5 @@ name: termonad -version: 0.2.1.0 +version: 1.0.0.0 synopsis: Terminal emulator configurable in Haskell description: Please see . homepage: https://github.com/cdepillabout/termonad @@ -17,9 +17,8 @@ , img/termonad.png , .nix-helpers/nixops.nix , .nix-helpers/nixpkgs.nix - , .nix-helpers/running-termonad.nix , .nix-helpers/stack-nix-shell.nix - , .nix-helpers/termonad.nix + , .nix-helpers/termonad-with-packages.nix , shell.nix data-files: img/termonad-lambda.png custom-setup @@ -27,60 +26,90 @@ , Cabal , cabal-doctest >=1.0.2 && <1.1 +-- This flag builds the example code in the example-config/ directory, as well +-- as the example from the README.md file. It is only used for testing. It +-- should be enabled for CI. +flag buildexamples + description: Build an executable from the examples in the example-config/ + directory, as well as the example from the README.md file. This + is normally only used for testing. + default: False + library hs-source-dirs: src exposed-modules: Termonad , Termonad.App , Termonad.Config - , Termonad.FocusList + , Termonad.Config.Colour + , Termonad.Config.Vec , Termonad.Gtk , Termonad.Keys + , Termonad.Lenses , Termonad.Prelude , Termonad.Term , Termonad.Types , Termonad.XML other-modules: Paths_termonad build-depends: base >= 4.7 && < 5 + , adjunctions , classy-prelude , colour , constraints + , containers , data-default , directory >= 1.3.1.0 + , distributive , dyre , filepath + , focuslist , gi-gdk , gi-gio , gi-glib , gi-gtk >= 3.0.24 , gi-pango , gi-vte >= 2.91.19 - , haskell-gi-base + , haskell-gi-base >= 0.21.2 , lens + , mono-traversable , pretty-simple , QuickCheck + , singletons , xml-conduit , xml-html-qq default-language: Haskell2010 ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates default-extensions: DataKinds + , DefaultSignatures + , DeriveAnyClass + , DeriveFoldable + , DeriveFunctor + , DerivingStrategies + , EmptyCase + , ExistentialQuantification + , FlexibleContexts + , FlexibleInstances , GADTs , GeneralizedNewtypeDeriving , InstanceSigs , KindSignatures + , LambdaCase + , MultiParamTypeClasses , NamedFieldPuns , NoImplicitPrelude - , OverloadedStrings , OverloadedLabels , OverloadedLists + , OverloadedStrings , PatternSynonyms , PolyKinds , RankNTypes , RecordWildCards , ScopedTypeVariables + , StandaloneDeriving , TypeApplications , TypeFamilies , TypeOperators other-extensions: TemplateHaskell + , UndecidableInstances pkgconfig-depends: gtk+-3.0 executable termonad @@ -106,12 +135,18 @@ type: exitcode-stdio-1.0 main-is: Test.hs hs-source-dirs: test + -- other-modules: Test.FocusList + -- , Test.FocusList.Invariants 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 @@ -133,6 +168,37 @@ , TypeFamilies , TypeOperators other-extensions: TemplateHaskell + +executable termonad-readme + main-is: README.lhs + hs-source-dirs: test/readme + build-depends: base + , markdown-unlit + , termonad + , colour + ghc-options: -pgmL markdown-unlit + default-language: Haskell2010 + + if flag(buildexamples) + buildable: True + else + buildable: False + +executable termonad-example-colour-extension + main-is: example-config/ExampleColourExtension.hs + build-depends: base + , termonad + , colour + default-language: Haskell2010 + + if flag(buildexamples) + buildable: True + else + buildable: False + +source-repository head + type: git + location: https://github.com/cdepillabout/termonad/ -- benchmark termonad-bench -- type: exitcode-stdio-1.0 diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -3,36 +3,8 @@ import Termonad.Prelude -import Control.Lens ((^.)) -import Hedgehog - ( Gen - , Property - , PropertyT - , annotate - , annotateShow - , failure - , forAll - , property - , success - ) -import Hedgehog.Gen (alphaNum, choice, int, string) -import Hedgehog.Range (constant, linear) import Test.Tasty (TestTree, defaultMain, testGroup) -import Test.Tasty.Hedgehog (testProperty) -import Termonad.FocusList - ( FocusList - , debugFL - , deleteFL - , emptyFL - , insertFL - , invariantFL - , isEmptyFL - , lensFocusListLen - , lookupFL - , removeFL - ) - main :: IO () main = do tests <- testsIO @@ -43,105 +15,5 @@ pure $ testGroup "tests" - [ testProperty "invariants in FocusList" testInvariantsInFocusList + [ -- focusListTests ] - -testInvariantsInFocusList :: Property -testInvariantsInFocusList = - property $ do - numOfActions <- forAll $ int (linear 1 200) - let initialState = emptyFL - let strGen = string (constant 0 25) alphaNum - -- traceM "----------------------------------" - -- traceM $ "starting bar, numOfActions: " <> show numOfActions - runActions numOfActions strGen initialState - -data Action a - = InsertFL Int a - | RemoveFL Int - | DeleteFL a - deriving (Eq, Show) - -genInsertFL :: Gen a -> FocusList a -> Maybe (Gen (Action a)) -genInsertFL valGen fl - | isEmptyFL fl = Just $ do - val <- valGen - pure $ InsertFL 0 val - | otherwise = Just $ do - let len = fl ^. lensFocusListLen - key <- int $ constant 0 len - val <- valGen - pure $ InsertFL key val - -genRemoveFL :: FocusList a -> Maybe (Gen (Action a)) -genRemoveFL fl - | isEmptyFL fl = Nothing - | otherwise = Just $ do - let len = fl ^. lensFocusListLen - keyToRemove <- int $ constant 0 (len - 1) - pure $ RemoveFL keyToRemove - -genDeleteFL :: Show a => FocusList a -> Maybe (Gen (Action a)) -genDeleteFL fl - | isEmptyFL fl = Nothing - | otherwise = Just $ do - let len = fl ^. lensFocusListLen - keyForItemToDelete <- int $ constant 0 (len - 1) - let maybeItemToDelete = lookupFL keyForItemToDelete fl - case maybeItemToDelete of - Nothing -> - let msg = - "Could not find item in focuslist even though " <> - "it should be there." <> - "\nkey: " <> - show keyForItemToDelete <> - "\nfocus list: " <> - debugFL fl - in error msg - Just item -> pure $ DeleteFL item - -generateAction :: Show a => Gen a -> FocusList a -> Gen (Action a) -generateAction valGen fl = do - let generators = - catMaybes - [ genInsertFL valGen fl - , genRemoveFL fl - , genDeleteFL fl - ] - case generators of - [] -> - let msg = - "No generators available for fl:\n" <> - debugFL fl - in error msg - _ -> do - choice generators - -performAction :: Eq a => FocusList a -> Action a -> Maybe (FocusList a) -performAction fl (InsertFL key val) = insertFL key val fl -performAction fl (RemoveFL keyToRemove) = removeFL keyToRemove fl -performAction fl (DeleteFL valToDelete) = Just $ deleteFL valToDelete fl - -runActions :: (Eq a, Monad m, Show a) => Int -> Gen a -> FocusList a -> PropertyT m () -runActions i valGen startingFL - | i <= 0 = success - | otherwise = do - action <- forAll $ generateAction valGen startingFL - -- traceM $ "runActions, startingFL: " <> show startingFL - -- traceM $ "runActions, action: " <> show action - let maybeEndingFL = performAction startingFL action - case maybeEndingFL of - Nothing -> do - annotate "Failed to perform action." - annotateShow startingFL - annotateShow action - failure - Just endingFL -> - if invariantFL endingFL - then runActions (i - 1) valGen endingFL - else do - annotate "Ending FocusList failed invariants." - annotateShow startingFL - annotateShow action - annotateShow endingFL - failure diff --git a/test/readme/README.lhs b/test/readme/README.lhs new file mode 100644 --- /dev/null +++ b/test/readme/README.lhs @@ -0,0 +1,405 @@ + +Termonad +========= + +[![Build Status](https://secure.travis-ci.org/cdepillabout/termonad.svg)](http://travis-ci.org/cdepillabout/termonad) +[![Hackage](https://img.shields.io/hackage/v/termonad.svg)](https://hackage.haskell.org/package/termonad) +[![Stackage LTS](http://stackage.org/package/termonad/badge/lts)](http://stackage.org/lts/package/termonad) +[![Stackage Nightly](http://stackage.org/package/termonad/badge/nightly)](http://stackage.org/nightly/package/termonad) +[![BSD3 license](https://img.shields.io/badge/license-BSD3-blue.svg)](./LICENSE) +[![Join the chat at https://gitter.im/termonad/Lobby](https://badges.gitter.im/termonad/Lobby.svg)](https://gitter.im/termonad/Lobby?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) +[![Join the chat in #termonad on irc.freenode.net](https://img.shields.io/badge/%23termonad-irc.freenode.net-brightgreen.svg)](https://webchat.freenode.net/) + +Termonad is a terminal emulator configurable in Haskell. It is extremely +customizable and provides hooks to modify the default behavior. It can be +thought of as the "XMonad" of terminal emulators. + +![image of Termonad](./img/termonad.png) + + +**Table of Contents** + +- [Termonad](#termonad) + - [Installation](#installation) + - [Arch Linux](#arch-linux) + - [Ubuntu / Debian](#ubuntu--debian) + - [Nix](#nix) + - [Mac OS X](#mac-os-x) + - [Installing with just `stack`](#installing-with-just-stack) + - [Installing with just `nix`](#installing-with-just-nix) + - [Installing with `stack` using `nix`](#installing-with-stack-using-nix) + - [Windows](#windows) + - [How to use Termonad](#how-to-use-termonad) + - [Default Keybindings](#default-keybindings) + - [Configuring Termonad](#configuring-termonad) + - [Compiling Local Settings](#compiling-local-settings) + - [Running with `stack`](#running-with-stack) + - [Running with `nix`](#running-with-nix) + - [Goals](#goals) + - [Where to get help](#where-to-get-help) + - [Contributions](#contributions) + - [Maintainers](#maintainers) + + + +## Installation + +Termonad can be installed on any system as long as the necessary GTK libraries +are available. The following are instructions for installing Termonad on a few +different distributions and systems. If the given steps don't work for you, or +you want to add instructions for an additional system, please send a pull +request. + +The following steps use the +[`stack`](https://docs.haskellstack.org/en/stable/README/) build tool to build +Termonad, but [`cabal`](https://www.haskell.org/cabal/) can be used as well. Steps for +installing `stack` can be found on +[this page](https://docs.haskellstack.org/en/stable/install_and_upgrade/). + + +### Arch Linux + +First, you must install the required GTK system libraries: + +```sh +$ pacman -S vte3 +``` + +In order to install Termonad, clone this repository and run `stack install`. +This will install the `termonad` binary to `~/.local/bin/`: + +```sh +$ git clone https://github.com/cdepillabout/termonad +$ cd termonad/ +$ stack install +``` + +### Ubuntu / Debian + +First, you must install the required GTK system libraries: + +```sh +$ apt-get install gobject-introspection libgirepository1.0-dev libgtk-3-dev libvte-2.91-dev +``` + +In order to install Termonad, clone this repository and run `stack install`. +This will install the `termonad` binary to `~/.local/bin/`: + +```sh +$ git clone https://github.com/cdepillabout/termonad +$ cd termonad/ +$ stack install +``` + +### Nix + +If you have `nix` installed, you should be able to use it to build Termonad. +This means that it will work on NixOS, or with `nix` on another distro. There +are two different ways to use `nix` to build Termonad: + +The first is using `stack`. The following commands install `stack` for your +user, clone this repository, and install the `termonad` binary to `~/.local/bin/`: + +```sh +$ nix-env -i stack +$ git clone https://github.com/cdepillabout/termonad +$ cd termonad/ +$ stack --nix install +``` + +The second is using the normal `nix-build` machinery. The following commands +clone this repository and build the `termonad` binary at `./result/bin/`: + +```sh +$ git clone https://github.com/cdepillabout/termonad +$ cd termonad/ +$ nix-build +``` + +### Mac OS X + +Building and installing Termonad on Mac OS X should be possible with any of the following three methods: + +- Install the required system libraries (like GTK and VTE) by hand, then use + `stack` to build Termonad. + + This is probably the easiest method. You don't have to understand anything + about `nix`. However, it is slightly annoying to have to install GTK and + VTE by hand. + +- Use `nix` to install both the required system libraries and Termonad itself. + + If you are a nix user and want an easy way to install Termonad, this + is the recommended method. + +- Use `nix` to install install the required system libraries, and `stack` to + build Termonad. + + If you are a nix user, but want to use `stack` to actually do development + on Termonad, using `stack` may be easier than using `cabal`. + +The following sections describe each method. + +#### Installing with just `stack` + +(*currently no instructions available. please send a PR adding instructions if you get termonad to build using this method.*) + +#### Installing with just `nix` + +`nix` can be used to install Termonad with the following steps, assuming you +have `nix` [installed](https://nixos.org/nix/download.html). These commands +clone this repository and build the `termonad` binary at `./result/bin/`: + +```sh +$ git clone https://github.com/cdepillabout/termonad +$ cd termonad/ +$ nix-build +``` + +#### Installing with `stack` using `nix` + +`stack` can be used in conjunction with `nix` to install Termonad. `nix` will +handle installing system dependencies (like GTK and VTE), while `stack` will +handle compiling and installing Haskell packages. + +You must have `nix` [installed](https://nixos.org/nix/download.html). + +You will also need `stack` installed. You can do that with the following command: + +```sh +$ nix-env -i stack +``` + +After `stack` is installed, you will need to clone Termonad and build it: + +``` +$ git clone https://github.com/cdepillabout/termonad +$ cd termonad/ +$ stack --nix install +``` + +This will install the `termonad` binary to `~/.local/bin/`. + +### Windows + +(*currently no instructions available. please send a PR adding instructions if you get termonad to build.*) + +## How to use Termonad + +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: + +```sh +$ ~/.local/bin/termonad +``` + +The following section describes the default keybindings. + +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 +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 +`~/.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 +`~/.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. + +### Default Keybindings + +Termonad provides the following default key bindings. + +| Keybinding | Action | +|------------|--------| +| Ctrl Shift t | Open new tab. | +| Ctrl Shift w | Close tab. | +| Alt (number key) | Switch to tab `number`. For example, Alt 2 switches to tab 2. | + +### Configuring Termonad + +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 +configuration options within the +[`Termonad.Config`](https://hackage.haskell.org/package/termonad/docs/Termonad-Config.html) +module. + +```haskell +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Data.Colour.SRGB (Colour, sRGB24) +import Termonad.App (defaultMain) +import Termonad.Config + ( FontConfig, FontSize(FontSizePoints), Option(Set) + , ShowScrollbar(ShowScrollbarAlways), defaultConfigOptions, defaultFontConfig + , defaultTMConfig, fontConfig, fontFamily, fontSize, options, showScrollbar + ) +import Termonad.Config.Colour + (ColourConfig, addColourExtension, createColourExtension, cursorBgColour + , defaultColourConfig + ) + +-- | This sets the color of the cursor in the terminal. +-- +-- This uses the "Data.Colour" module to define a dark-red color. +-- There are many default colors defined in "Data.Colour.Names". +cursBgColor :: Colour Double +cursBgColor = sRGB24 204 0 0 + +-- | This sets the colors used for the terminal. We only specify the background +-- color of the cursor. +colConf :: ColourConfig (Colour Double) +colConf = + defaultColourConfig + { cursorBgColour = Set cursBgColor + } + +-- | This defines the font for the terminal. +fontConf :: FontConfig +fontConf = + defaultFontConfig + { fontFamily = "DejaVu Sans Mono" + , fontSize = FontSizePoints 13 + } + +main :: IO () +main = do + colExt <- createColourExtension colConf + let termonadConf = + defaultTMConfig + { options = + defaultConfigOptions + { fontConfig = fontConf + -- Make sure the scrollbar is always visible. + , showScrollbar = ShowScrollbarAlways + } + } + `addColourExtension` colExt + defaultMain termonadConf +``` + +### Compiling Local Settings + +If you launch Termonad by calling `~/.local/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 +Haskell libraries to be able to compile `~/.config/termonad/termonad.hs`. + +There are a couple solutions to this problem, listed in the sections below. + +(These steps are definitely confusing. I would love to figure out a better +way to do this. Please submit an issue or PR if you have a good idea about +how to fix this.) + +#### 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`: + +```sh +$ cd termonad/ # change to the termonad source code directory +$ stack exec -- termonad +``` + +`stack` will pick up the correct GHC version and libraries from the +`stack.yaml` and `termonad.cabal` file. `termonad` will be run in an +environment with GHC available. `termonad` will use this GHC and libraries to +compile your `~/.config/termonad/termonad.hs` file. It if succeeds, it should +create a `~/.cache/termonad/termonad-linux-x86_64` binary. + +If you need extra Haskell libraries available when compiling your +`~/.config/termonad/termonad.hs` file, you can specify them to `stack exec`: + +```sh +$ stack exec --package lens --package conduit -- termonad +``` + +The problem with this is that `stack exec` changes quite a few of your +environment variables. It is not recommended to actually run Termonad from +within `stack exec`. After you run `stack exec -- termonad` and let it +recompile your `~/.config/termonad/termonad.hs` file, exit Termonad. +Re-run Termonad by calling it directly. Termonad will notice that +`~/.config/termonad/termonad.hs` hasn't changed since +`~/.cache/termonad/termonad-linux-x86_64` has been recompiled, so it will +directly execute `~/.cache/termonad/termonad-linux-x86_64`. + +#### Running with `nix` + +Building Termonad with `nix` (by running `nix-build` in the top +directory) sets it up so that Termonad can see GHC. Termonad should be able +to compile the `~/.config/termonad/termonad.hs` file by default. + +If you're interested in how this works, or want to change which Haskell +packages are available from your `~/.config/termonad/termonad.hs` file, please +see the documentation in the +[`.nix-helpers/termonad-with-packages.nix`](./.nix-helpers/termonad-with-packages.nix) +file. + +## Goals + +Termonad has the following goals: + +* fully configurable in Haskell + + There are already + [many](https://gnometerminator.blogspot.com/p/introduction.html) + [good](https://www.enlightenment.org/about-terminology.md) + [terminal](http://software.schmorp.de/pkg/rxvt-unicode.html) + [emulators](https://launchpad.net/sakura). However, there are no terminal + emulators fully configurable in Haskell. Termonad fills this niche. + +* flexible + + Most people only need a terminal emulator that lets you change the font-size, + cursor color, etc. They don't need tons of configuration options. Termonad + should be for people that like lots of configuration options. Termonad + should provide many hooks to allow the user full control over its behavior. + +* stable + + Termonad should be able to be used everyday as your main terminal + emulator. It should not crash for any reason. If you experience a crash, + please file an issue or a pull request! + +* good documentation + + The [documentation](https://hackage.haskell.org/package/termonad) for + Termonad on Hackage should be good. You shouldn't have to guess at what + certain data types or functions do. If you have a hard time understanding + anything in the documentation, please submit an issue or PR. + +## Where to get help + +If you find a bug in Termonad, please either +[send a PR](https://github.com/cdepillabout/termonad/pulls) fixing it or create +an [issue](https://github.com/cdepillabout/termonad/issues) explaining it. + +If you just need help with configuring Termonad, you can either join the +[Gitter room](https://gitter.im/termonad/Lobby) or +[#termonad on irc.freenode.net](https://webchat.freenode.net/). + +## Contributions + +Contributions are highly appreciated. Termonad is currently missing many +helpful configuration options and behavior hooks. If there is something you +would like to add, please submit an issue or PR. + +## Maintainers + +- [cdepillabout](https://github.com/cdepillabout) +- [LSLeary](https://github.com/LSLeary)