summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--default.nix36
-rw-r--r--krebs/4lib/default.nix9
-rw-r--r--krebs/4lib/git.nix42
-rw-r--r--krebs/5pkgs/git-hooks/default.nix168
-rw-r--r--krebs/5pkgs/haskell-overrides/xmonad-stockholm.nix16
-rw-r--r--tv/1systems/mkdir.nix1
-rw-r--r--tv/1systems/xu.nix1
-rw-r--r--tv/2configs/default.nix14
-rw-r--r--tv/2configs/git.nix22
-rw-r--r--tv/2configs/vim.nix4
-rw-r--r--tv/4lib/default.nix11
-rw-r--r--tv/4lib/git.nix202
-rw-r--r--tv/4lib/modules.nix21
-rw-r--r--tv/5pkgs/xmonad-tv/Main.hs6
-rw-r--r--tv/5pkgs/xmonad-tv/Util/Font.hs123
-rw-r--r--tv/5pkgs/xmonad-tv/Util/Pager.hs172
-rw-r--r--tv/5pkgs/xmonad-tv/Util/Rhombus.hs369
-rw-r--r--tv/5pkgs/xmonad-tv/Util/Shutdown.hs53
-rw-r--r--tv/5pkgs/xmonad-tv/Util/Submap.hs31
-rw-r--r--tv/5pkgs/xmonad-tv/Util/XUtils.hs47
-rw-r--r--tv/5pkgs/xmonad-tv/xmonad.cabal6
21 files changed, 285 insertions, 1069 deletions
diff --git a/default.nix b/default.nix
index c001b8c13..1637aa464 100644
--- a/default.nix
+++ b/default.nix
@@ -13,40 +13,36 @@ let stockholm = {
krebs = import ./krebs (args // { inherit lib stockholm; });
- lib =
- let
- lib = import <nixpkgs/lib>;
- klib = import ./krebs/4lib { inherit lib; };
- #ulib = import (./. + "/${current-user-name}/4lib") { lib = lib // klib; };
- ulib = {}; # TODO
- in
- builtins // lib // klib // ulib // rec {
- # TODO move this stuff
+ lib = let
+ nlib = import <nixpkgs/lib>;
+ klib = import (slib.kpath "4lib") { lib = nlib; };
+ slib = rec {
stockholm-path = ./.;
nspath = ns: p: stockholm-path + "/${ns}/${p}";
+ kpath = nspath "krebs";
+ upath = nspath current-user-name;
};
+ ulib = let p = slib.upath "4lib"; in
+ nlib.optionalAttrs (klib.dir.has-default-nix p)
+ (import p { lib = nlib // klib; });
+ in nlib // klib // slib // ulib // builtins;
inherit (eval {}) pkgs;
- kpath = lib.nspath "krebs";
- upath = lib.nspath current-user-name;
-
base-module = { config, ... }: {
imports = builtins.filter lib.dir.has-default-nix (lib.concatLists [
- (map (f: f "2configs") [ upath ])
- (map (f: f "3modules") [ kpath upath ])
+ (map (f: f "2configs") [ lib.upath ])
+ (map (f: f "3modules") [ lib.kpath lib.upath ])
]);
krebs.current.enable = true;
krebs.current.host = config.krebs.hosts.${current-host-name};
krebs.current.user = config.krebs.users.${current-user-name};
- nixpkgs.config.packageOverrides = pkgs:
- let
- kpkgs = import (kpath "5pkgs") { inherit lib pkgs; };
- upkgs = import (upath "5pkgs") { inherit lib; pkgs = pkgs // kpkgs; };
- in
- kpkgs // upkgs;
+ nixpkgs.config.packageOverrides = pkgs: let
+ kpkgs = import (lib.kpath "5pkgs") { inherit lib pkgs; };
+ upkgs = import (lib.upath "5pkgs") { inherit lib; pkgs = pkgs // kpkgs; };
+ in kpkgs // upkgs;
};
eval = config: import <nixpkgs/nixos/lib/eval-config.nix> {
diff --git a/krebs/4lib/default.nix b/krebs/4lib/default.nix
index f907fe871..1cabeae27 100644
--- a/krebs/4lib/default.nix
+++ b/krebs/4lib/default.nix
@@ -3,7 +3,7 @@
with builtins;
with lib;
-rec {
+let out = rec {
eq = x: y: x == y;
@@ -17,6 +17,7 @@ rec {
dir.has-default-nix = path: pathExists (path + "/default.nix");
dns = import ./dns.nix { inherit lib; };
+ git = import ./git.nix { lib = lib // out; };
listset = import ./listset.nix { inherit lib; };
shell = import ./shell.nix { inherit lib; };
tree = import ./tree.nix { inherit lib; };
@@ -30,4 +31,8 @@ rec {
subdirsOf = path:
mapAttrs (name: _: path + "/${name}")
(filterAttrs (_: eq "directory") (readDir path));
-}
+
+ mapAttrValues = f: mapAttrs (_: f);
+ setAttr = name: value: set: set // { ${name} = value; };
+
+}; in out
diff --git a/krebs/4lib/git.nix b/krebs/4lib/git.nix
new file mode 100644
index 000000000..d50ba2018
--- /dev/null
+++ b/krebs/4lib/git.nix
@@ -0,0 +1,42 @@
+{ lib, ... }:
+
+let
+ inherit (lib) addNames escapeShellArg makeSearchPath optionalString;
+
+ commands = addNames {
+ git-receive-pack = {};
+ git-upload-pack = {};
+ };
+
+ receive-modes = addNames {
+ fast-forward = {};
+ non-fast-forward = {};
+ create = {};
+ delete = {};
+ merge = {}; # TODO implement in git.nix
+ };
+
+ permissions = {
+ fetch = {
+ allow-commands = [
+ commands.git-upload-pack
+ ];
+ };
+
+ push = ref: extra-modes: {
+ allow-commands = [
+ commands.git-receive-pack
+ commands.git-upload-pack
+ ];
+ allow-receive-ref = ref;
+ allow-receive-modes = [ receive-modes.fast-forward ] ++ extra-modes;
+ };
+ };
+
+ refs = {
+ master = "refs/heads/master";
+ all-heads = "refs/heads/*";
+ };
+
+in
+commands // receive-modes // permissions // refs
diff --git a/krebs/5pkgs/git-hooks/default.nix b/krebs/5pkgs/git-hooks/default.nix
new file mode 100644
index 000000000..5697c31be
--- /dev/null
+++ b/krebs/5pkgs/git-hooks/default.nix
@@ -0,0 +1,168 @@
+{ lib, pkgs, ... }:
+
+with lib;
+
+let
+ out = {
+ inherit irc-announce;
+ };
+
+ # TODO irc-announce should return a derivation
+ irc-announce = { nick, channel, server, port ? 6667, verbose ? false }: ''
+ #! /bin/sh
+ set -euf
+
+ export PATH=${makeSearchPath "bin" (with pkgs; [
+ coreutils
+ git
+ gnused
+ ])}
+
+ green() { printf '\x0303,99%s\x0F' "$1"; }
+ red() { printf '\x0304,99%s\x0F' "$1"; }
+ orange() { printf '\x0307,99%s\x0F' "$1"; }
+ pink() { printf '\x0313,99%s\x0F' "$1"; }
+ gray() { printf '\x0314,99%s\x0F' "$1"; }
+
+ unset message
+ add_message() {
+ message="''${message+$message
+ }$*"
+ }
+
+ nick=${escapeShellArg nick}
+ channel=${escapeShellArg channel}
+ server=${escapeShellArg server}
+ port=${toString port}
+
+ host=$nick
+ cgit_endpoint=http://cgit.$host
+
+ empty=0000000000000000000000000000000000000000
+
+ while read oldrev newrev ref; do
+
+ if [ $oldrev = $empty ]; then
+ receive_mode=create
+ elif [ $newrev = $empty ]; then
+ receive_mode=delete
+ elif [ "$(git merge-base $oldrev $newrev)" = $oldrev ]; then
+ receive_mode=fast-forward
+ else
+ receive_mode=non-fast-forward
+ fi
+
+ h=$(echo $ref | sed 's:^refs/heads/::')
+
+ # empty_tree=$(git hash-object -t tree /dev/null)
+ empty_tree=4b825dc6
+
+ id=$(echo $newrev | cut -b-7)
+ id2=$(echo $oldrev | cut -b-7)
+ if [ $newrev = $empty ]; then id=$empty_tree; fi
+ if [ $oldrev = $empty ]; then id2=$empty_tree; fi
+
+ case $receive_mode in
+ create)
+ link="$cgit_endpoint/$GIT_SSH_REPO/?h=$h"
+ ;;
+ delete)
+ link="$cgit_endpoint/$GIT_SSH_REPO/ ($h)"
+ ;;
+ fast-forward|non-fast-forward)
+ link="$cgit_endpoint/$GIT_SSH_REPO/diff/?h=$h&id=$id&id2=$id2"
+ ;;
+ esac
+
+ #$host $GIT_SSH_REPO $ref $link
+ add_message $(pink push) $link $(gray "($receive_mode)")
+
+ ${optionalString verbose ''
+ add_message "$(
+ git log \
+ --format="$(orange %h) %s $(gray '(%ar)')" \
+ --reverse \
+ $id2..$id
+
+ git diff --stat $id2..$id \
+ | sed '$!s/\(+*\)\(-*\)$/'$(green '\1')$(red '\2')'/'
+ )"
+ ''}
+
+ done
+
+ if test -n "''${message-}"; then
+ exec ${irc-announce-script} \
+ "$server" \
+ "$port" \
+ "$nick" \
+ "$channel" \
+ "$message"
+ fi
+ '';
+
+ irc-announce-script = pkgs.writeScript "irc-announce-script" ''
+ #! /bin/sh
+ set -euf
+
+ export PATH=${makeSearchPath "bin" (with pkgs; [
+ coreutils
+ gawk
+ gnused
+ netcat
+ nettools
+ ])}
+
+ IRC_SERVER=$1
+ IRC_PORT=$2
+ IRC_NICK=$3$$
+ IRC_CHANNEL=$4
+ message=$5
+
+ export IRC_CHANNEL # for privmsg_cat
+
+ # echo2 and cat2 are used output to both, stdout and stderr
+ # This is used to see what we send to the irc server. (debug output)
+ echo2() { echo "$*"; echo "$*" >&2; }
+ cat2() { tee /dev/stderr; }
+
+ # privmsg_cat transforms stdin to a privmsg
+ privmsg_cat() { awk '{ print "PRIVMSG "ENVIRON["IRC_CHANNEL"]" :"$0 }'; }
+
+ # ircin is used to feed the output of netcat back to the "irc client"
+ # so we can implement expect-like behavior with sed^_^
+ # XXX mkselfdestructingtmpfifo would be nice instead of this cruft
+ tmpdir="$(mktemp -d irc-announce_XXXXXXXX)"
+ cd "$tmpdir"
+ mkfifo ircin
+ trap "
+ rm ircin
+ cd '$OLDPWD'
+ rmdir '$tmpdir'
+ trap - EXIT INT QUIT
+ " EXIT INT QUIT
+
+ {
+ echo2 "USER $LOGNAME 0 * :$LOGNAME@$(hostname)"
+ echo2 "NICK $IRC_NICK"
+
+ # wait for MODE message
+ sed -n '/^:[^ ]* MODE /q'
+
+ echo2 "JOIN $IRC_CHANNEL"
+
+ printf '%s' "$message" \
+ | privmsg_cat \
+ | cat2
+
+ echo2 "PART $IRC_CHANNEL"
+
+ # wait for PART confirmation
+ sed -n '/:'"$IRC_NICK"'![^ ]* PART /q'
+
+ echo2 'QUIT :Gone to have lunch'
+ } < ircin \
+ | nc "$IRC_SERVER" "$IRC_PORT" | tee -a ircin
+ '';
+
+in out
diff --git a/krebs/5pkgs/haskell-overrides/xmonad-stockholm.nix b/krebs/5pkgs/haskell-overrides/xmonad-stockholm.nix
new file mode 100644
index 000000000..5c6f068e7
--- /dev/null
+++ b/krebs/5pkgs/haskell-overrides/xmonad-stockholm.nix
@@ -0,0 +1,16 @@
+{ mkDerivation, base, containers, fetchgit, stdenv, X11, X11-xshape
+, xmonad, xmonad-contrib
+}:
+mkDerivation {
+ pname = "xmonad-stockholm";
+ version = "1.0.0";
+ src = fetchgit {
+ url = "http://cgit.cd/xmonad-stockholm";
+ sha256 = "35dda5d16acc90af94ae2fae10ab5cc2d5b450c3f1ff2e7f515ac53877269abf";
+ rev = "2dbefe42fc5cfe9093465bf3e22ba8f82feeef6e";
+ };
+ libraryHaskellDepends = [
+ base containers X11 X11-xshape xmonad xmonad-contrib
+ ];
+ license = stdenv.lib.licenses.mit;
+}
diff --git a/tv/1systems/mkdir.nix b/tv/1systems/mkdir.nix
index 6ae4f80e8..9d8a0bcfa 100644
--- a/tv/1systems/mkdir.nix
+++ b/tv/1systems/mkdir.nix
@@ -17,7 +17,6 @@ in
{
krebs.build.host = config.krebs.hosts.mkdir;
-
krebs.build.target = "root@${primary-addr4}";
imports = [
diff --git a/tv/1systems/xu.nix b/tv/1systems/xu.nix
index 1a9dddb55..94656ab61 100644
--- a/tv/1systems/xu.nix
+++ b/tv/1systems/xu.nix
@@ -212,7 +212,6 @@ with lib;
security.setuidPrograms = [
"sendmail" # for cron
- #"slock"
];
services.printing.enable = true;
diff --git a/tv/2configs/default.nix b/tv/2configs/default.nix
index 6ed1c65f9..3400c13b6 100644
--- a/tv/2configs/default.nix
+++ b/tv/2configs/default.nix
@@ -88,6 +88,12 @@ with lib;
ls = "ls -h --color=auto --group-directories-first";
dmesg = "dmesg -L --reltime";
view = "vim -R";
+
+ reload = "systemctl reload";
+ restart = "systemctl restart";
+ start = "systemctl start";
+ status = "systemctl status";
+ stop = "systemctl stop";
};
environment.variables = {
@@ -167,5 +173,13 @@ with lib;
"sendmail" # for sudo
];
}
+ {
+ systemd.tmpfiles.rules = let
+ forUsers = flip map users;
+ isUser = { group, ... }: hasSuffix "users" group;
+ users = filter isUser (mapAttrsToList (_: id) config.users.users);
+ in forUsers (u: "d /run/xdg/${u.name} 0700 ${u.name} ${u.group} -");
+ environment.variables.XDG_RUNTIME_DIR = "/run/xdg/$LOGNAME";
+ }
];
}
diff --git a/tv/2configs/git.nix b/tv/2configs/git.nix
index 2520da173..4387be36a 100644
--- a/tv/2configs/git.nix
+++ b/tv/2configs/git.nix
@@ -1,6 +1,7 @@
{ config, lib, pkgs, ... }:
-with import ../4lib { inherit lib pkgs; };
+with lib;
+
let
out = {
@@ -20,26 +21,22 @@ let
rules = concatMap make-rules (attrValues repos);
public-repos = mapAttrs make-public-repo ({
+ } // mapAttrValues (setAttr "section" "1. Miscellaneous") {
cac = {
desc = "CloudAtCost command line interface";
};
- cgserver = {};
- crude-mail-setup = {};
- dot-xmonad = {};
get = {};
hack = {};
load-env = {};
make-snapshot = {};
much = {};
- nixos-infest = {};
nixpkgs = {};
- painload = {};
push = {};
regfish = {};
stockholm = {
desc = "take all the computers hostage, they'll love you!";
};
- } // mapAttrs (_: repo: repo // { section = "Haskell libraries"; }) {
+ } // mapAttrValues (setAttr "section" "2. Haskell libraries") {
blessings = {};
mime = {};
quipper = {};
@@ -47,6 +44,13 @@ let
wai-middleware-time = {};
web-routes-wai-custom = {};
xintmap = {};
+ xmonad-stockholm = {};
+ } // mapAttrValues (setAttr "section" "3. Museum") {
+ cgserver = {};
+ crude-mail-setup = {};
+ dot-xmonad = {};
+ nixos-infest = {};
+ painload = {};
});
restricted-repos = mapAttrs make-restricted-repo (
@@ -63,7 +67,7 @@ let
inherit name desc section;
public = true;
hooks = {
- post-receive = git.irc-announce {
+ post-receive = pkgs.git-hooks.irc-announce {
# TODO make nick = config.krebs.build.host.name the default
nick = config.krebs.build.host.name;
channel = "#retiolum";
@@ -82,7 +86,7 @@ let
with git // config.krebs.users;
repo:
singleton {
- user = tv;
+ user = [ tv tv_xu ];
repo = [ repo ];
perm = push "refs/*" [ non-fast-forward create delete merge ];
} ++
diff --git a/tv/2configs/vim.nix b/tv/2configs/vim.nix
index 04b1480c1..0822fb5bf 100644
--- a/tv/2configs/vim.nix
+++ b/tv/2configs/vim.nix
@@ -64,6 +64,10 @@ let
\ | hi TrailingSpace ctermbg=88
\ | hi Normal ctermfg=White
+ au BufRead,BufNewFile *.hs so ${pkgs.writeText "hs.vim" ''
+ syn region String start=+\[[^|]*|+ end=+|]+
+ ''}
+
au BufRead,BufNewFile *.nix so ${pkgs.writeText "nix.vim" ''
setf nix
set isk=@,48-57,_,192-255,-,'
diff --git a/tv/4lib/default.nix b/tv/4lib/default.nix
deleted file mode 100644
index c099eb733..000000000
--- a/tv/4lib/default.nix
+++ /dev/null
@@ -1,11 +0,0 @@
-{ lib, pkgs, ... }:
-
-lib // rec {
-
- git = import ./git.nix {
- inherit lib pkgs;
- };
-
- # TODO deprecate shell-escape for lass
- shell-escape = lib.shell.escape;
-}
diff --git a/tv/4lib/git.nix b/tv/4lib/git.nix
deleted file mode 100644
index d8827115a..000000000
--- a/tv/4lib/git.nix
+++ /dev/null
@@ -1,202 +0,0 @@
-{ lib, pkgs, ... }:
-
-let
- inherit (lib) addNames escapeShellArg makeSearchPath optionalString;
-
- commands = addNames {
- git-receive-pack = {};
- git-upload-pack = {};
- };
-
- receive-modes = addNames {
- fast-forward = {};
- non-fast-forward = {};
- create = {};
- delete = {};
- merge = {}; # TODO implement in git.nix
- };
-
- permissions = {
- fetch = {
- allow-commands = [
- commands.git-upload-pack
- ];
- };
-
- push = ref: extra-modes: {
- allow-commands = [
- commands.git-receive-pack
- commands.git-upload-pack
- ];
- allow-receive-ref = ref;
- allow-receive-modes = [ receive-modes.fast-forward ] ++ extra-modes;
- };
- };
-
- refs = {
- master = "refs/heads/master";
- all-heads = "refs/heads/*";
- };
-
- irc-announce-script = pkgs.writeScript "irc-announce-script" ''
- #! /bin/sh
- set -euf
-
- export PATH=${makeSearchPath "bin" (with pkgs; [
- coreutils
- gawk
- gnused
- netcat
- nettools
- ])}
-
- IRC_SERVER=$1
- IRC_PORT=$2
- IRC_NICK=$3$$
- IRC_CHANNEL=$4
- message=$5
-
- export IRC_CHANNEL # for privmsg_cat
-
- # echo2 and cat2 are used output to both, stdout and stderr
- # This is used to see what we send to the irc server. (debug output)
- echo2() { echo "$*"; echo "$*" >&2; }
- cat2() { tee /dev/stderr; }
-
- # privmsg_cat transforms stdin to a privmsg
- privmsg_cat() { awk '{ print "PRIVMSG "ENVIRON["IRC_CHANNEL"]" :"$0 }'; }
-
- # ircin is used to feed the output of netcat back to the "irc client"
- # so we can implement expect-like behavior with sed^_^
- # XXX mkselfdestructingtmpfifo would be nice instead of this cruft
- tmpdir="$(mktemp -d irc-announce_XXXXXXXX)"
- cd "$tmpdir"
- mkfifo ircin
- trap "
- rm ircin
- cd '$OLDPWD'
- rmdir '$tmpdir'
- trap - EXIT INT QUIT
- " EXIT INT QUIT
-
- {
- echo2 "USER $LOGNAME 0 * :$LOGNAME@$(hostname)"
- echo2 "NICK $IRC_NICK"
-
- # wait for MODE message
- sed -n '/^:[^ ]* MODE /q'
-
- echo2 "JOIN $IRC_CHANNEL"
-
- printf '%s' "$message" \
- | privmsg_cat \
- | cat2
-
- echo2 "PART $IRC_CHANNEL"
-
- # wait for PART confirmation
- sed -n '/:'"$IRC_NICK"'![^ ]* PART /q'
-
- echo2 'QUIT :Gone to have lunch'
- } < ircin \
- | nc "$IRC_SERVER" "$IRC_PORT" | tee -a ircin
- '';
-
- hooks = {
- # TODO make this a package?
- irc-announce = { nick, channel, server, port ? 6667, verbose ? false }: ''
- #! /bin/sh
- set -euf
-
- export PATH=${makeSearchPath "bin" (with pkgs; [
- coreutils
- git
- gnused
- ])}
-
- green() { printf '\x0303,99%s\x0F' "$1"; }
- red() { printf '\x0304,99%s\x0F' "$1"; }
- orange() { printf '\x0307,99%s\x0F' "$1"; }
- pink() { printf '\x0313,99%s\x0F' "$1"; }
- gray() { printf '\x0314,99%s\x0F' "$1"; }
-
- unset message
- add_message() {
- message="''${message+$message
- }$*"
- }
-
- nick=${escapeShellArg nick}
- channel=${escapeShellArg channel}
- server=${escapeShellArg server}
- port=${toString port}
-
- host=$nick
- cgit_endpoint=http://cgit.$host
-
- empty=0000000000000000000000000000000000000000
-
- while read oldrev newrev ref; do
-
- if [ $oldrev = $empty ]; then
- receive_mode=create
- elif [ $newrev = $empty ]; then
- receive_mode=delete
- elif [ "$(git merge-base $oldrev $newrev)" = $oldrev ]; then
- receive_mode=fast-forward
- else
- receive_mode=non-fast-forward
- fi
-
- h=$(echo $ref | sed 's:^refs/heads/::')
-
- # empty_tree=$(git hash-object -t tree /dev/null)
- empty_tree=4b825dc6
-
- id=$(echo $newrev | cut -b-7)
- id2=$(echo $oldrev | cut -b-7)
- if [ $newrev = $empty ]; then id=$empty_tree; fi
- if [ $oldrev = $empty ]; then id2=$empty_tree; fi
-
- case $receive_mode in
- create)
- link="$cgit_endpoint/$GIT_SSH_REPO/?h=$h"
- ;;
- delete)
- link="$cgit_endpoint/$GIT_SSH_REPO/ ($h)"
- ;;
- fast-forward|non-fast-forward)
- link="$cgit_endpoint/$GIT_SSH_REPO/diff/?h=$h&id=$id&id2=$id2"
- ;;
- esac
-
- #$host $GIT_SSH_REPO $ref $link
- add_message $(pink push) $link $(gray "($receive_mode)")
-
- ${optionalString verbose ''
- add_message "$(
- git log \
- --format="$(orange %h) %s $(gray '(%ar)')" \
- --reverse \
- $id2..$id
-
- git diff --stat $id2..$id \
- | sed '$!s/\(+*\)\(-*\)$/'$(green '\1')$(red '\2')'/'
- )"
- ''}
-
- done
-
- if test -n "''${message-}"; then
- exec ${irc-announce-script} \
- "$server" \
- "$port" \
- "$nick" \
- "$channel" \
- "$message"
- fi
- '';
- };
-
-in
-commands // receive-modes // permissions // refs // hooks
diff --git a/tv/4lib/modules.nix b/tv/4lib/modules.nix
deleted file mode 100644
index 248e638ea..000000000
--- a/tv/4lib/modules.nix
+++ /dev/null
@@ -1,21 +0,0 @@
-let
- pkgs = import <nixpkgs> {};
- inherit (pkgs.lib) concatMap hasAttr;
-in rec {
-
- no-touch-args = {
- config = throw "no-touch-args: can't touch config!";
- lib = throw "no-touch-args: can't touch lib!";
- pkgs = throw "no-touch-args: can't touch pkgs!";
- };
-
- # list-imports : path -> [path]
- # Return a module's transitive list of imports.
- # XXX duplicates won't get eliminated from the result.
- list-imports = path:
- let module = import path no-touch-args;
- imports = if hasAttr "imports" module
- then concatMap list-imports module.imports
- else [];
- in [path] ++ imports;
-}
diff --git a/tv/5pkgs/xmonad-tv/Main.hs b/tv/5pkgs/xmonad-tv/Main.hs
index 2cc48efa3..2258b34a6 100644
--- a/tv/5pkgs/xmonad-tv/Main.hs
+++ b/tv/5pkgs/xmonad-tv/Main.hs
@@ -35,9 +35,9 @@ import XMonad.Layout.PerWorkspace (onWorkspace)
--import XMonad.Layout.BinarySpacePartition
--import XMonad.Actions.Submap
-import Util.Pager
-import Util.Rhombus
-import Util.Shutdown
+import XMonad.Stockholm.Pager
+import XMonad.Stockholm.Rhombus
+import XMonad.Stockholm.Shutdown
myTerm :: String
diff --git a/tv/5pkgs/xmonad-tv/Util/Font.hs b/tv/5pkgs/xmonad-tv/Util/Font.hs
deleted file mode 100644
index 5352cf5ad..000000000
--- a/tv/5pkgs/xmonad-tv/Util/Font.hs
+++ /dev/null
@@ -1,123 +0,0 @@
-{-# LANGUAGE CPP #-}
-module Util.Font
- ( printStringCentered
- , printStringXMF'
- ) where
-
-import XMonad
-import XMonad.Util.Font
-
-
-printStringCentered :: (Functor m, MonadIO m)
- => Display -> Drawable -> XMonadFont
- -> GC -> Rectangle -> String
- -> m ()
-printStringCentered d p xmf gc r s = do
- let x = rect_x r
- y = rect_y r
- w = rect_width r
- h = rect_height r
-
- text_w <- textWidthXMF d xmf s
- (text_ascent, _) <- textExtentsXMF xmf s
-
- let text_x = x + round ((fi w - fi text_w) / 2)
- text_y = y + round ((fi h + fi text_h) / 2)
- text_h = text_ascent
-
- printStringXMF' d p xmf gc "" "" text_x text_y s
-
-
--- from xmonad-contrib's XMonad.Util.Font, (c) 2007 Andrea Rossato and Spencer Janssen
-printStringXMF' :: (Functor m, MonadIO m) => Display -> Drawable -> XMonadFont -> GC -> String -> String
- -> Position -> Position -> String -> m ()
-printStringXMF' d p (Core fs) gc fc bc x y s = io $ do
- setFont d gc $ fontFromFontStruct fs
- --tv [fc',bc'] <- mapM (stringToPixel d) [fc,bc]
- --tv setForeground d gc fc'
- --tv setBackground d gc bc'
- drawImageString d p gc x y s
-printStringXMF' d p (Utf8 fs) gc fc bc x y s = io $ do
- --tv [fc',bc'] <- mapM (stringToPixel d) [fc,bc]
- --tv setForeground d gc fc'
- --tv setBackground d gc bc'
- io $ wcDrawImageString d p fs gc x y s
-#ifdef XFT
-printStringXMF' dpy drw fs@(Xft font) gc fc bc x y s = do
- let screen = defaultScreenOfDisplay dpy
- colormap = defaultColormapOfScreen screen
- visual = defaultVisualOfScreen screen
- --tv bcolor <- stringToPixel dpy bc
- (a,d) <- textExtentsXMF fs s
- gi <- io $ xftTextExtents dpy font s
- --tv io $ setForeground dpy gc bcolor
- io $ fillRectangle dpy drw gc (x - fi (xglyphinfo_x gi))
- (y - fi a)
- (fi $ xglyphinfo_xOff gi)
- (fi $ a + d)
- io $ withXftDraw dpy drw visual colormap $
- \draw -> withXftColorName dpy visual colormap fc $
- \color -> xftDrawString draw color font x y s
-#endif
-
-
-
-
-
--- --my_printStringXMF :: (Functor m, MonadIO m) => Display -> Drawable -> XMonadFont -> GC -> String -> String
--- -- -> Position -> Position -> String -> m ()
--- my_printStringXMF (Core fs) d p gc x y s = do
--- setFont d gc $ fontFromFontStruct fs
--- -- [fc',bc'] <- mapM (stringToPixel d) [fc,bc]
--- -- setForeground d gc fc'
--- -- setBackground d gc bc'
--- drawImageString d p gc x y s
--- my_printStringXMF (Utf8 fs) d p gc x y s = do
--- -- [fc',bc'] <- mapM (stringToPixel d) [fc,bc]
--- -- setForeground d gc fc'
--- -- setBackground d gc bc'
--- wcDrawImageString d p fs gc x y s
--- #ifdef XFT
--- my_printStringXMF dpy drw fs@(Xft font) gc fc bc x y s = do
--- let screen = defaultScreenOfDisplay dpy
--- colormap = defaultColormapOfScreen screen
--- visual = defaultVisualOfScreen screen
--- bcolor <- stringToPixel dpy bc
--- (a,d) <- textExtentsXMF fs s
--- gi <- io $ xftTextExtents dpy font s
--- io $ setForeground dpy gc bcolor
--- io $ fillRectangle dpy drw gc (x - fromIntegral (xglyphinfo_x gi))
--- (y - fromIntegral a)
--- (fromIntegral $ xglyphinfo_xOff gi)
--- (fromIntegral $ a + d)
--- io $ withXftDraw dpy drw visual colormap $
--- \draw -> withXftColorName dpy visual colormap fc $
--- \color -> xftDrawString draw color font x y s
--- #endif
-
-
-
--- --textWidthXMF :: MonadIO m => Display -> XMonadFont -> String -> m Int
--- my_textWidthXMF _ (Utf8 fs) s = return $ fromIntegral $ wcTextEscapement fs s
--- my_textWidthXMF _ (Core fs) s = return $ fromIntegral $ textWidth fs s
--- #ifdef XFT
--- my_TextWidthXMF dpy (Xft xftdraw) s = liftIO $ do
--- gi <- xftTextExtents dpy xftdraw s
--- return $ xglyphinfo_xOff gi
--- #endif
---
--- my_textExtentsXMF :: MonadIO m => XMonadFont -> String -> m (Int32,Int32)
--- my_textExtentsXMF (Utf8 fs) s = do
--- let (_,rl) = wcTextExtents fs s
--- ascent = fromIntegral $ - (rect_y rl)
--- descent = fromIntegral $ rect_height rl + (fromIntegral $ rect_y rl)
--- return (ascent, descent)
--- my_textExtentsXMF (Core fs) s = do
--- let (_,a,d,_) = textExtents fs s
--- return (a,d)
--- #ifdef XFT
--- my_textExtentsXMF (Xft xftfont) _ = io $ do
--- ascent <- fromIntegral `fmap` xftfont_ascent xftfont
--- descent <- fromIntegral `fmap` xftfont_descent xftfont
--- return (ascent, descent)
--- #endif
diff --git a/tv/5pkgs/xmonad-tv/Util/Pager.hs b/tv/5pkgs/xmonad-tv/Util/Pager.hs
deleted file mode 100644
index b8168b5b0..000000000
--- a/tv/5pkgs/xmonad-tv/Util/Pager.hs
+++ /dev/null
@@ -1,172 +0,0 @@
-module Util.Pager
- ( defaultPagerConfig
- , defaultWindowColors
- , defaultWorkspaceColors
- , MatchMethod(..)
- , pager
- , PagerConfig(..)
- ) where
-
-import Data.List ( find )
-import Data.Maybe ( catMaybes )
-import Graphics.X11
-import Util.Rhombus
-import XMonad
-import qualified XMonad.StackSet as W
-import XMonad.Hooks.UrgencyHook
-import XMonad.Util.Font ( fi, stringToPixel )
-
-
-data PagerConfig = PagerConfig
- { pc_font :: String
- , pc_cellwidth :: Dimension
- , pc_margin :: Dimension
- , pc_matchmethod :: MatchMethod
- , pc_wrap :: Bool
- , pc_workspaceColors :: Bool -> Bool -> Bool -> (String, String, String)
- , pc_windowColors :: Bool -> Bool -> Bool -> Bool -> Bool -> (String, String)
- }
-
-
-defaultPagerConfig :: PagerConfig
-defaultPagerConfig = PagerConfig "xft:Sans-8" 100 0 MatchInfix True defaultWorkspaceColors defaultWindowColors
-
-
-pager :: PagerConfig -> (String -> X ()) -> [String] -> X ()
-pager pc = rhombus defaultRhombusConfig
- { rc_font = pc_font pc
- , rc_cellwidth = pc_cellwidth pc
- , rc_margin = pc_margin pc
- , rc_matchmethod = pc_matchmethod pc
- , rc_wrap = pc_wrap pc
- , rc_colors = pc_workspaceColors pc
- , rc_paint = pagerPaint pc
- }
-
-
-defaultWorkspaceColors :: Bool -- workspace has focus
- -> Bool -- workspace name matches incremental search
- -> Bool -- workspace is the current one
- -> (String, String, String) -- workspace border, background color, and foreground color
-defaultWorkspaceColors False False False = ("#101010","#050505","#202020")
-defaultWorkspaceColors False False True = ("#101010","#050505","#202020")
-defaultWorkspaceColors False True False = ("#404040","#202020","#b0b0b0")
-defaultWorkspaceColors False True True = ("#101010","#050505","#505050")
-defaultWorkspaceColors True _ False = ("#808020","#404010","#f0f0b0")
-defaultWorkspaceColors True _ True = ("#404010","#202005","#909050")
-
-
-defaultWindowColors :: Bool -- window's workspace has focus
- -> Bool -- window's workspace name matches incremental search
- -> Bool -- window's workspace the current one
- -> Bool -- window is urgent
- -> Bool -- window has focus
- -> (String, String) -- window border and background color
-
-defaultWindowColors wsf m c u True = ("#802020", snd $ defaultWindowColors wsf m c u False)
-
-defaultWindowColors False False False False _ = ("#111111","#060606")
-defaultWindowColors False False False True _ = ("#802020","#401010")
-defaultWindowColors False False True False _ = ("#101010","#050505")
-defaultWindowColors False False True True _ = ("#401010","#200505")
-defaultWindowColors False True False False _ = ("#202080","#101040")
-defaultWindowColors False True False True _ = ("#802080","#401040")
-defaultWindowColors False True True False _ = ("#101040","#100520")
-defaultWindowColors False True True True _ = ("#401040","#200520")
-
-defaultWindowColors True False False False _ = ("#208020","#104010")
-defaultWindowColors True False False True _ = ("#808020","#404010")
-defaultWindowColors True False True False _ = ("#104010","#052005")
-defaultWindowColors True False True True _ = ("#404010","#202005")
-defaultWindowColors True True False False _ = ("#208080","#104040")
-defaultWindowColors True True False True _ = ("#808080","#404040")
-defaultWindowColors True True True False _ = ("#104040","#102020")
-defaultWindowColors True True True True _ = ("#404040","#202020")
-
-
-pagerPaint ::
- PagerConfig
- -> RhombusConfig
- -> Display
- -> Drawable
- -> GC
- -> WorkspaceId
- -> Rectangle
- -> Bool
- -> Bool
- -> Bool
- -> X ()
-pagerPaint pc rc d p gc t r focus match current = do
- ss <- gets windowset
-
- let x = rect_x r
- y = rect_y r
-
- urgents <- readUrgents
- let foci = map W.focus $ catMaybes $ map W.stack $ W.workspaces ss
-
- let color = pc_windowColors pc focus match current -- :: Bool -> (String, String)
- (_, _, _fg_color) = pc_workspaceColors pc focus match current
-
- fg_color <- stringToPixel d _fg_color
-
- let r = screenRect $ W.screenDetail $ W.current ss
- let a = fi (rect_width r) / fi (rect_height r)
- let scale = fi (rc_cellwidth rc) / fi (rect_width r)
-
- -- TODO whenNothing print error
- whenJust (findWorkspace t ss) $ \ ws -> do
- whenJust (W.stack ws) $ \ s ->
- withDisplay $ \ d -> io $ do
-
- let color' w = color (w `elem` urgents) (w `elem` foci)
-
- -- TODO painting of floating windows is broken
- mapM_ (drawMiniWindow d p gc x y color' scale) (W.down s)
- drawMiniWindow d p gc x y color' scale (W.focus s)
- mapM_ (drawMiniWindow d p gc x y color' scale) (W.up s)
-
-drawMiniWindow
- :: RealFrac a
- => Display
- -> Drawable
- -> GC
- -> Position
- -> Position
- -> (Window -> (String, String))
- -> a
- -> Window
- -> IO ()
-drawMiniWindow d p gc ox oy color s win = do
- let scale x = round $ fi x * s
-
- wa <- getWindowAttributes d win
-
- let x = ox + (scale $ wa_x wa)
- y = oy + (scale $ wa_y wa)
- w = (scale $ wa_width wa)
- h = (scale $ wa_height wa)
-
- let (fg, bg) = color win
-
- fg' <- stringToPixel d fg
- bg' <- stringToPixel d bg
-
- setForeground d gc bg'
- fillRectangle d p gc (x + 1) (y + 1) (w - 2) (h - 2)
-
- setForeground d gc fg'
- drawLines d p gc
- [ Point x y
- , Point (fi w - 1) 0
- , Point 0 (fi h - 2)
- , Point (- fi w + 1) 0
- , Point 0 (- fi h + 2)
- ]
- coordModePrevious
-
-
-
--- TODO externalize findWorkspace
-findWorkspace :: (Eq i) => i -> W.StackSet i l a sid sd -> Maybe (W.Workspace i l a)
-findWorkspace t ss = find ((==)t . W.tag) (W.workspaces ss)
diff --git a/tv/5pkgs/xmonad-tv/Util/Rhombus.hs b/tv/5pkgs/xmonad-tv/Util/Rhombus.hs
deleted file mode 100644
index 9d46e4127..000000000
--- a/tv/5pkgs/xmonad-tv/Util/Rhombus.hs
+++ /dev/null
@@ -1,369 +0,0 @@
-module Util.Rhombus
- ( defaultRhombusConfig
- , MatchMethod(..)
- , rhombus
- , RhombusConfig(..)
- , RhombusState(..)
- ) where
-
-import Control.Monad ( forM_, zipWithM_ )
-import Data.Char
-import Data.List
-import Data.Ord
-import Data.Map ( fromList )
-import Data.Maybe ( isJust, fromJust )
-import XMonad
-import XMonad.StackSet hiding ( filter )
-import XMonad.Util.Font
-import XMonad.Util.Image ( drawIcon )
-import XMonad.Util.XUtils
-
-import Util.Submap
-import Util.XUtils
-import Util.Font
-
-
-data MatchMethod = MatchInfix | MatchPrefix
-
-data RhombusConfig = RhombusConfig
- { rc_font :: String
- , rc_cellwidth :: Dimension
- , rc_margin :: Dimension
- , rc_matchmethod :: MatchMethod
- , rc_wrap :: Bool
- , rc_colors :: Bool -> Bool -> Bool -> (String, String, String)
- , rc_paint :: RhombusConfig -> Display -> Pixmap -> GC -> String -> Rectangle -> Bool -> Bool -> Bool -> X ()
- }
-
-
--- TODO currently xft is broken
-defaultRhombusConfig = RhombusConfig "xft:Sans-8" 100 0 MatchInfix True stupidColors noPaint
- where
- stupidColors _ _ _ = ("red", "magenta", "yellow")
- noPaint _ _ _ _ _ _ _ _ _ = return ()
-
-
-data RhombusState = RhombusState
- { rs_window :: Window
- , rs_search :: String
- , rs_font :: XMonadFont
- , rs_focus :: (Position, Position)
- , rs_strings :: [String]
- }
-
-
-reachableCoords :: RhombusState -> [(Position, Position)]
-reachableCoords RhombusState{rs_strings=xs} = take (length xs) wave
-
-
-matchingReachableCoords :: RhombusConfig -> RhombusState -> [(Position, Position)]
-matchingReachableCoords rc rs =
- snd $ unzip
- $ filter (isXOf (rc_matchmethod rc) (rs_search rs) . fst)
- $ zip (rs_strings rs) (reachableCoords rs)
-
-
-match :: MatchMethod -> String -> [String] -> Maybe String
-match m s ws = do
- let cands = filter (isXOf m s) ws
- if length cands == 1
- then Just $ head cands
- else Nothing
-
-rhombus :: RhombusConfig -> (String -> X ()) -> [String] -> X ()
-rhombus rc viewFunc as = withGrabbedKeyboard $ do
- rs <- newRhombus rc as
- --redraw rc rs
- showWindow (rs_window rs)
- rhombusMode viewFunc rc rs
-
-
-rhombusMode :: (String -> X ()) -> RhombusConfig -> RhombusState -> X ()
-rhombusMode viewFunc rc rs =
- case match (rc_matchmethod rc) (rs_search rs) (init $ rs_strings rs) of
- Nothing -> redraw rc rs >> submapString def keys
- Just i -> removeRhombus rs >> viewFunc i
- where
- def (ch:[]) | isPrint ch =
- incSearchPushChar ch rs >>= rhombusMode viewFunc rc
-
- def _ =
- failbeep >> rhombusMode viewFunc rc rs
-
- keys = fromList $
- [ ((0 , xK_BackSpace ), incSearchPopChar rs >>= rhombusMode viewFunc rc)
- , ((0 , xK_Escape ), removeRhombus rs)
- , ((0 , xK_Menu ), removeRhombus rs)
- , ((0 , xK_Left ), goto rc (-1, 0) rs >>= rhombusMode viewFunc rc)
- , ((0 , xK_Right ), goto rc ( 1, 0) rs >>= rhombusMode viewFunc rc)
- , ((0 , xK_Up ), goto rc ( 0,-1) rs >>= rhombusMode viewFunc rc)
- , ((0 , xK_Down ), goto rc ( 0, 1) rs >>= rhombusMode viewFunc rc)
- , ((0 , xK_Tab ), gotoNextMatch rc rs >>= rhombusMode viewFunc rc)
- , ((_S , xK_Tab ), gotoPrevMatch rc rs >>= rhombusMode viewFunc rc)
- , ((0 , xK_Return ), removeRhombus rs >> return (selectFocused rs) >>= viewFunc)
- ]
-
- _S = shiftMask
-
-
--- TODO make failbeep configurable
-failbeep = spawn "beep -l 100 -f 500"
-
-
-goto :: RhombusConfig -> (Position, Position) -> RhombusState -> X RhombusState
-goto RhombusConfig{rc_wrap=True} xy rs = maybe (failbeep >> return rs) return $ wrapFocus xy rs
-goto RhombusConfig{rc_wrap=False} xy rs = maybe (failbeep >> return rs) return $ moveFocus xy rs
-
-
-moveFocus :: (Position, Position) -> RhombusState -> Maybe RhombusState
-moveFocus (dx, dy) rs@RhombusState{rs_focus=(x,y)} = do
- let focus' = (x + dx, y + dy)
- if elem focus' (reachableCoords rs)
- then Just rs { rs_focus = focus' }
- else Nothing
-
-
-wrapFocus :: (Position, Position) -> RhombusState -> Maybe RhombusState
-
-wrapFocus (0, dy) rs@RhombusState{rs_focus=focus} = do
- let column = sortBy (comparing snd) $ filter ((==) (fst focus) . fst) (reachableCoords rs)
- i <- elemIndex focus column
- return rs { rs_focus = column `modIndex` (i + fromIntegral dy) }
-
-wrapFocus (dx, 0) rs@RhombusState{rs_focus=focus} = do
- let column = sortBy (comparing fst) $ filter ((==) (snd focus) . snd) (reachableCoords rs)
- i <- elemIndex focus column
- return rs { rs_focus = column `modIndex` (i + fromIntegral dx) }
-
-wrapFocus _ _ = Nothing
-
-
-gotoPrevMatch :: RhombusConfig -> RhombusState -> X RhombusState
-gotoPrevMatch rc rs@RhombusState{rs_focus=focus} = do
- case reverse (matchingReachableCoords rc rs) of
- [] -> failbeep >> return rs
- xs -> return rs
- { rs_focus = maybe (head xs)
- (modIndex xs . (+1))
- (focus `elemIndex` xs)
- }
-
-
-gotoNextMatch :: RhombusConfig -> RhombusState -> X RhombusState
-gotoNextMatch rc rs@RhombusState{rs_focus=focus} = do
- case matchingReachableCoords rc rs of
- [] -> failbeep >> return rs
- xs -> return rs
- { rs_focus = maybe (head xs)
- (modIndex xs . (+1))
- (focus `elemIndex` xs)
- }
-
-
-selectFocused :: RhombusState -> String
-selectFocused rs =
- -- TODO the rhombus must never "focus" something inexistent
- fromJust $ lookup (rs_focus rs) $ zip wave (rs_strings rs)
-
-
-incSearchPushChar :: Char -> RhombusState -> X RhombusState
-incSearchPushChar c rs = return rs { rs_search = rs_search rs ++ [c] }
-
-
-incSearchPopChar :: RhombusState -> X RhombusState
-
--- only rubout if we have at least one char
-incSearchPopChar rs@RhombusState{rs_search=xs@(_:_)} =
- return rs { rs_search = init xs }
-
-incSearchPopChar rs = return rs
-
-
-redraw :: RhombusConfig -> RhombusState -> X ()
-redraw rc rs = do
- ss <- gets windowset
-
- let Screen _ _ (SD (Rectangle _ _ s_width s_height)) = current ss
-
- -- TODO this let is duplicated in newRhombus
- let scale x = x * cell_w `div` s_width -- TODO use bw
- cell_w = rc_cellwidth rc
- cell_h = scale s_height
-
- -- txy is the top-left corner of the first (center) cell
- -- XXX div and (-) are not distributive
- -- we could round $ (s_* - cell_*) / 2, though...
- tx = fi $ s_width `div` 2 - cell_w `div` 2
- ty = fi $ s_height `div` 2 - cell_h `div` 2
-
- margin = rc_margin rc
-
- -- dxy are the outer cell dimensions (i.e. including the border)
- dx = fi $ cell_w + 2 + margin
- dy = fi $ cell_h + 2 + margin
-
- paint = rc_paint rc
- xmf = rs_font rs
- tags = rs_strings rs
- --currentTag = last tags
-
- withDisplay $ \ d -> do
- -- XXX we cannot use withPixmapAndGC because rc_paint is an X monad
- p <- io $ createPixmap d (rs_window rs) s_width s_height (defaultDepthOfScreen $ defaultScreenOfDisplay d)
- g <- io $ createGC d p
-
- -- TODO fixme
- color_black <- stringToPixel d "black"
-
- forZipWithM_ tags (reachableCoords rs) $ \ tag oxy@(ox, oy) -> do
-
- let focus = oxy == rs_focus rs
- match = isXOf (rc_matchmethod rc) (rs_search rs) tag
- current = tag == last tags
- (_b_color, _bg_color, _fg_color) = rc_colors rc focus match current
- --cell_x = (ox * dx) + x - fi (cell_w `div` 2)
- --cell_y = (oy * dy) + y - fi (cell_h `div` 2)
- cell_x = (ox * dx) + tx + 1
- cell_y = (oy * dy) + ty + 1
-
- b_color <- stringToPixel d _b_color
- bg_color <- stringToPixel d _bg_color
- fg_color <- stringToPixel d _fg_color
-
- -- draw background
- io $ setForeground d g bg_color
- io $ fillRectangle d p g cell_x cell_y cell_w cell_h
-
- -- draw border
- io $ setForeground d g b_color
- io $ drawLines d p g
- [ Point (cell_x - 1) (cell_y - 1)
- , Point (fi cell_w + 1) 0
- , Point 0 (fi cell_h + 1)
- , Point (-(fi cell_w + 1)) 0
- , Point 0 (-(fi cell_h + 1))
- ]
- coordModePrevious
-
- -- custom draw
- paint rc d p g tag (Rectangle cell_x cell_y cell_w cell_h) focus match current
-
- -- paint text
- -- TODO custom paint text?
- -- TODO withCopyArea
- io $ withPixmapAndGC d p s_width s_height (defaultDepthOfScreen $ defaultScreenOfDisplay d) $ \ f_pm f_gc -> do
- withPixmapAndGC d f_pm s_width s_height 1 $ \ clip_mask clip_gc -> do
- setForeground d clip_gc 0
- setBackground d clip_gc 0
- fillRectangle d clip_mask clip_gc 0 0 s_width s_height
- setForeground d clip_gc 1
-
- let r = Rectangle cell_x cell_y cell_w cell_h
-
- printStringCentered d clip_mask xmf clip_gc r tag
-
- setForeground d f_gc fg_color
- setBackground d f_gc color_black -- TODO
-
- printStringCentered d f_pm xmf f_gc r tag
-
- setClipMask d f_gc clip_mask
-
- copyArea d f_pm p f_gc 0 0 s_width s_height 0 0
-
- io $ copyArea d p (rs_window rs) g 0 0 s_width s_height 0 0
- io $ freePixmap d p
- io $ freeGC d g
-
-
-newRhombus :: RhombusConfig -> [String] -> X RhombusState
-newRhombus rc tags = do
- ss <- gets windowset
-
- let Screen _ _ (SD (Rectangle _ _ s_width s_height)) = current ss
- (_, def_win_bg, _) = rc_colors rc False True False
-
- -- TODO this let is duplicated in redraw
- let scale x = x * cell_w `div` s_width -- TODO use bw
- cell_w = rc_cellwidth rc
- cell_h = scale s_height
-
- -- TODO don't delete this let but use it instead of s_{width,height}
- -- (xcoords, ycoords) = unzip $ take (length tags) wave -- this is reachableCoords
- -- win_width = (maximum xcoords - minimum xcoords) * dx
- -- win_height = (maximum ycoords - minimum ycoords) * dy
-
- -- txy is the top-left corner of the first (center) cell
- -- XXX div and (-) are not distributive
- -- we could round $ (s_* - cell_*) / 2, though...
- tx = fi $ s_width `div` 2 - cell_w `div` 2
- ty = fi $ s_height `div` 2 - cell_h `div` 2
-
- margin = rc_margin rc
-
- -- dxy are the outer cell dimensions (i.e. including the border)
- dx = fi $ cell_w + 2 + margin
- dy = fi $ cell_h + 2 + margin
-
- fn <- initXMF (rc_font rc)
- win <- createNewWindow (Rectangle 0 0 s_width s_height) Nothing def_win_bg True
-
- withDisplay $ \ d ->
- io $ shapeWindow d win $ \ p g ->
- forZipWithM_ tags wave $ \ _ (ox, oy) ->
- fillRectangle d p g (tx + ox * dx) (ty + oy * dy) (fi cell_w + 2) (fi cell_h + 2)
-
- return $ RhombusState win "" fn (0,0) tags
-
-
-removeRhombus :: RhombusState -> X ()
-removeRhombus (RhombusState w _ fn _ _) = do
- deleteWindow w
- releaseXMF fn
-
-wave :: [(Position, Position)]
-wave = zip (0:(concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i,-i+1..(-1)]) [1..])) (concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i+1,-i+2..(-1)]) [1..])
- where
- wave1 = 0:(concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i,-i+1..(-1)]) [1..])
- wave2 = concat $ map (\i -> [0..i]++[i-1,i-2..1] ++ [0,-1..(-i)]++[-i+1,-i+2..(-1)]) [1..]
-
-commonPrefix (x:xs) (y:ys) | x == y = x:commonPrefix xs ys
-commonPrefix _ _ = []
-
-
-isXOf :: MatchMethod -> String -> String -> Bool
-isXOf MatchInfix = isInfixOf
-isXOf MatchPrefix = isPrefixOf
-
-
-findXIndex :: (Eq a) => MatchMethod -> [a] -> [a] -> Maybe Int
-findXIndex MatchInfix = findInfixIndex
-findXIndex MatchPrefix = findPrefixIndex
-
-
-findInfixIndex :: (Eq a) => [a] -> [a] -> Maybe Int
-findInfixIndex needle haystack
- = (\x -> if null x then Nothing else Just (fst $ head x))
- . dropWhile (\(_,x) -> not $ isPrefixOf needle x)
- $ zip [0..] (tails haystack)
-
-
-findPrefixIndex :: (Eq a) => [a] -> [a] -> Maybe Int
-findPrefixIndex needle haystack =
- if isPrefixOf needle haystack
- then Just 0
- else Nothing
-
-
-modIndex :: Integral i => [a] -> i -> a
-modIndex xs i = xs `genericIndex` (i `mod` genericLength xs)
-
-
-forZipWithM_ a b f = zipWithM_ f a b
-
-
-withGrabbedKeyboard f = do
- XConf { theRoot = root, display = d } <- ask
- catchX (io (grabKeyboard d root False grabModeAsync grabModeAsync currentTime) >> f)
- (return ())
- io $ ungrabKeyboard d currentTime
diff --git a/tv/5pkgs/xmonad-tv/Util/Shutdown.hs b/tv/5pkgs/xmonad-tv/Util/Shutdown.hs
deleted file mode 100644
index 89e22b4e7..000000000
--- a/tv/5pkgs/xmonad-tv/Util/Shutdown.hs
+++ /dev/null
@@ -1,53 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-module Util.Shutdown
- ( sendShutdownEvent
- , handleShutdownEvent
- , shutdown
- )
- where
-
-import Control.Monad
-import Data.Monoid
-import Data.Maybe (catMaybes)
-import qualified Data.Map as Map
-import System.Environment (getEnv)
-import System.Exit (exitSuccess)
-import XMonad
-import qualified XMonad.StackSet as W
-
-sendShutdownEvent :: IO ()
-sendShutdownEvent = do
- dpy <- openDisplay ""
- rw <- rootWindow dpy $ defaultScreen dpy
- a <- internAtom dpy "XMONAD_SHUTDOWN" False
- allocaXEvent $ \e -> do
- setEventType e clientMessage
- setClientMessageEvent e rw a 32 0 currentTime
- sendEvent dpy rw False structureNotifyMask e
- sync dpy False
-
-handleShutdownEvent :: Event -> X All
-handleShutdownEvent = \case
- ClientMessageEvent { ev_message_type = mt } -> do
- c <- (mt ==) <$> getAtom "XMONAD_SHUTDOWN"
- when c shutdown
- return (All c)
- _ ->
- return (All True)
-
-shutdown :: X ()
-shutdown = do
- broadcastMessage ReleaseResources
- io . flush =<< asks display
- let wsData = show . W.mapLayout show . windowset
- maybeShow (t, Right (PersistentExtension ext)) = Just (t, show ext)
- maybeShow (t, Left str) = Just (t, str)
- maybeShow _ = Nothing
- extState =
- return . show . catMaybes . map maybeShow . Map.toList . extensibleState
- s <- gets (\s -> (wsData s : extState s))
- _ <- io $ do
- path <- getEnv "XMONAD_STATE"
- writeFile path (unlines s)
- exitSuccess
- return ()
diff --git a/tv/5pkgs/xmonad-tv/Util/Submap.hs b/tv/5pkgs/xmonad-tv/Util/Submap.hs
deleted file mode 100644
index b09b97cc2..000000000
--- a/tv/5pkgs/xmonad-tv/Util/Submap.hs
+++ /dev/null
@@ -1,31 +0,0 @@
--- This module is based on Jason Creighton's XMonad.Actions.Submap
-
-module Util.Submap
- ( submapString
- ) where
-
-import Data.Bits
-import XMonad hiding (keys)
-import qualified Data.Map as M
-import Control.Monad.Fix (fix)
-
-
--- | Like 'XMonad.Actions.Submap.submapDefault', but provides the looked up string to the default action.
-submapString :: (String -> X ()) -> M.Map (KeyMask, KeySym) (X ()) -> X ()
-submapString def keys = do
- XConf { theRoot = root, display = d } <- ask
-
- (m, s, str) <- io $ allocaXEvent $ \p -> fix $ \nextkey -> do
- maskEvent d keyPressMask p
- KeyEvent { ev_keycode = code, ev_state = m } <- getEvent p
- keysym <- keycodeToKeysym d code 0
- if isModifierKey keysym
- then nextkey
- else do
- (mbKeysym, str) <- lookupString (asKeyEvent p)
- return (m, keysym, str)
-
- -- Remove num lock mask and Xkb group state bits
- m' <- cleanMask $ m .&. ((1 `shiftL` 12) - 1)
-
- maybe (def str) id (M.lookup (m', s) keys)
diff --git a/tv/5pkgs/xmonad-tv/Util/XUtils.hs b/tv/5pkgs/xmonad-tv/Util/XUtils.hs
deleted file mode 100644
index de1d8247c..000000000
--- a/tv/5pkgs/xmonad-tv/Util/XUtils.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-module Util.XUtils
- ( shapeWindow
- , withGC
- , withPixmap
- , withPixmapAndGC
- ) where
-
-import Control.Exception ( bracket )
-import Foreign.C.Types ( CInt )
-import Graphics.X11.Xlib
-import Graphics.X11.Xlib.Extras
-import Graphics.X11.Xshape
-
-
-shapeWindow :: Display -> Window -> (Pixmap -> GC -> IO ()) -> IO ()
-shapeWindow d w f = do
- wa <- getWindowAttributes d w
-
- let width = fromIntegral $ wa_width wa
- height = fromIntegral $ wa_height wa
-
- withPixmapAndGC d w width height 1 $ \ p g -> do
-
- setForeground d g 0
- fillRectangle d p g 0 0 width height
-
- setForeground d g 1
-
- f p g
-
- xshapeCombineMask d w shapeBounding 0 0 p shapeSet
-
-
-withGC :: Display -> Drawable -> (GC -> IO ()) -> IO ()
-withGC d p =
- bracket (createGC d p) (freeGC d)
-
-
-withPixmap :: Display -> Drawable -> Dimension -> Dimension -> CInt -> (Pixmap -> IO ()) -> IO ()
-withPixmap d p w h depth =
- bracket (createPixmap d p w h depth) (freePixmap d)
-
-
-withPixmapAndGC :: Display -> Drawable -> Dimension -> Dimension -> CInt -> (Pixmap -> GC -> IO ()) -> IO ()
-withPixmapAndGC d w width height depth f =
- withPixmap d w width height depth $ \ p ->
- withGC d p $ \ g -> f p g
diff --git a/tv/5pkgs/xmonad-tv/xmonad.cabal b/tv/5pkgs/xmonad-tv/xmonad.cabal
index cc72d3953..2246524fc 100644
--- a/tv/5pkgs/xmonad-tv/xmonad.cabal
+++ b/tv/5pkgs/xmonad-tv/xmonad.cabal
@@ -9,11 +9,9 @@ Executable xmonad
Build-Depends:
base,
containers,
- filepath,
unix,
- X11,
- X11-xshape,
xmonad,
- xmonad-contrib
+ xmonad-contrib,
+ xmonad-stockholm
GHC-Options: -Wall -O3 -threaded -rtsopts
Main-Is: Main.hs
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-23 20:07:15 +0000
[cgit] Unable to lock slot /tmp/cgit/4d300000.lock: No such file or directory (2)