termonad 0.2.1.0 → 1.0.0.0

raw patch · 26 files changed

+2883/−1399 lines, 26 filesdep +adjunctionsdep +containersdep +distributivedep ~basedep ~haskell-gi-basenew-component:exe:termonad-example-colour-extensionnew-component:exe:termonad-readmePVP ok

version bump matches the API change (PVP)

Dependencies added: adjunctions, containers, distributive, focuslist, genvalidity-containers, genvalidity-hspec, markdown-unlit, mono-traversable, singletons, tasty-hspec

Dependency ranges changed: base, haskell-gi-base

API changes (from Hackage documentation)

Files

• .nix-helpers/nixpkgs.nix +93/−8
• .nix-helpers/running-termonad.nix +0/−26
• .nix-helpers/stack-nix-shell.nix +15/−13
• .nix-helpers/termonad-with-packages.nix +122/−0
• .nix-helpers/termonad.nix +0/−34
• CHANGELOG.md +8/−0
• README.md +150/−58
• default.nix +19/−28
• example-config/ExampleColourExtension.hs +72/−0
• img/termonad-lambda.png binary
• shell.nix +43/−9
• src/Termonad.hs +13/−1
• src/Termonad/App.hs +169/−82
• src/Termonad/Config.hs +59/−55
• src/Termonad/Config/Colour.hs +518/−0
• src/Termonad/Config/Vec.hs +564/−0
• src/Termonad/FocusList.hs +0/−830
• src/Termonad/Gtk.hs +25/−3
• src/Termonad/Keys.hs +2/−0
• src/Termonad/Lenses.hs +76/−0
• src/Termonad/Prelude.hs +5/−2
• src/Termonad/Term.hs +80/−37
• src/Termonad/Types.hs +372/−78
• termonad.cabal +72/−6
• test/Test.hs +1/−129
• test/readme/README.lhs +405/−0

@@ -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 ]; }+

@@ -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 ]; } ""

@@ -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"   ]; }

@@ -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 '<nixpkgs>' --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;+}

@@ -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;-}

@@ -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".

@@ -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 |+|------------|--------|+| <kbd>Ctrl</kbd> <kbd>Shift</kbd> <kbd>t</kbd> | Open new tab. |+| <kbd>Ctrl</kbd> <kbd>Shift</kbd> <kbd>w</kbd> | Close tab. |+| <kbd>Alt</kbd> <kbd>(number key)</kbd> | Switch to tab `number`.  For example, <kbd>Alt</kbd> <kbd>2</kbd> 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)

@@ -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;-}

@@ -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

binary file changed (23829 → 12047 bytes)

@@ -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;+    }

@@ -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

@@ -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" ["<Shift><Ctrl>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" ["<Shift><Ctrl>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 =

@@ -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+-- <https://github.com/cdepillabout/termonad#configuring-termonad README>. -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

@@ -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 <https://github.com/cdepillabout/termonad/blob/master/example-config/ExampleColourExtension.hs this code> 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+-- <https://en.wikipedia.org/wiki/ANSI_escape_code#Colors ANSI escape color codes>.+--+-- 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:+--+-- <<https://raw.githubusercontent.com/cdepillabout/termonad/master/img/terminal-colors.png>>+--+-- 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+-- <https://github.com/cdepillabout/termonad/issues/29 this issue>.+--+-- 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

@@ -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+-- <http://hackage.haskell.org/package/type-combinators type-combinators> library.+-- Ideally this module would be split out to a separate package.+-- If you're interested in working on something like this, please see+-- <https://github.com/cdepillabout/termonad/issues/70 this issue> 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

@@ -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

@@ -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)

@@ -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

@@ -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+ )

@@ -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

@@ -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

@@ -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 = <function>" .+    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

@@ -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 <https://github.com/cdepillabout/termonad#readme README.md>. 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

@@ -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

@@ -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)++<!-- markdown-toc start - Don't edit this section. Run M-x markdown-toc-refresh-toc -->+**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)++<!-- markdown-toc end -->++## 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 |+|------------|--------|+| <kbd>Ctrl</kbd> <kbd>Shift</kbd> <kbd>t</kbd> | Open new tab. |+| <kbd>Ctrl</kbd> <kbd>Shift</kbd> <kbd>w</kbd> | Close tab. |+| <kbd>Alt</kbd> <kbd>(number key)</kbd> | Switch to tab `number`.  For example, <kbd>Alt</kbd> <kbd>2</kbd> 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)