Merge remote-tracking branch 'cd/master'
This commit is contained in:
lassulus
commit
6295f79357
36
default.nix
36
default.nix
@ -13,40 +13,36 @@ let stockholm = {
|
|||||||
|
|
||||||
krebs = import ./krebs (args // { inherit lib stockholm; });
|
krebs = import ./krebs (args // { inherit lib stockholm; });
|
||||||
|
|
||||||
lib =
|
lib = let
|
||||||
let
|
nlib = import <nixpkgs/lib>;
|
||||||
lib = import <nixpkgs/lib>;
|
klib = import (slib.kpath "4lib") { lib = nlib; };
|
||||||
klib = import ./krebs/4lib { inherit lib; };
|
slib = rec {
|
||||||
#ulib = import (./. + "/${current-user-name}/4lib") { lib = lib // klib; };
|
|
||||||
ulib = {}; # TODO
|
|
||||||
in
|
|
||||||
builtins // lib // klib // ulib // rec {
|
|
||||||
# TODO move this stuff
|
|
||||||
stockholm-path = ./.;
|
stockholm-path = ./.;
|
||||||
nspath = ns: p: stockholm-path + "/${ns}/${p}";
|
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;
|
inherit (eval {}) pkgs;
|
||||||
|
|
||||||
kpath = lib.nspath "krebs";
|
|
||||||
upath = lib.nspath current-user-name;
|
|
||||||
|
|
||||||
base-module = { config, ... }: {
|
base-module = { config, ... }: {
|
||||||
imports = builtins.filter lib.dir.has-default-nix (lib.concatLists [
|
imports = builtins.filter lib.dir.has-default-nix (lib.concatLists [
|
||||||
(map (f: f "2configs") [ upath ])
|
(map (f: f "2configs") [ lib.upath ])
|
||||||
(map (f: f "3modules") [ kpath upath ])
|
(map (f: f "3modules") [ lib.kpath lib.upath ])
|
||||||
]);
|
]);
|
||||||
|
|
||||||
krebs.current.enable = true;
|
krebs.current.enable = true;
|
||||||
krebs.current.host = config.krebs.hosts.${current-host-name};
|
krebs.current.host = config.krebs.hosts.${current-host-name};
|
||||||
krebs.current.user = config.krebs.users.${current-user-name};
|
krebs.current.user = config.krebs.users.${current-user-name};
|
||||||
|
|
||||||
nixpkgs.config.packageOverrides = pkgs:
|
nixpkgs.config.packageOverrides = pkgs: let
|
||||||
let
|
kpkgs = import (lib.kpath "5pkgs") { inherit lib pkgs; };
|
||||||
kpkgs = import (kpath "5pkgs") { inherit lib pkgs; };
|
upkgs = import (lib.upath "5pkgs") { inherit lib; pkgs = pkgs // kpkgs; };
|
||||||
upkgs = import (upath "5pkgs") { inherit lib; pkgs = pkgs // kpkgs; };
|
in kpkgs // upkgs;
|
||||||
in
|
|
||||||
kpkgs // upkgs;
|
|
||||||
};
|
};
|
||||||
|
|
||||||
eval = config: import <nixpkgs/nixos/lib/eval-config.nix> {
|
eval = config: import <nixpkgs/nixos/lib/eval-config.nix> {
|
||||||
|
|||||||
@ -3,7 +3,7 @@
|
|||||||
with builtins;
|
with builtins;
|
||||||
with lib;
|
with lib;
|
||||||
|
|
||||||
rec {
|
let out = rec {
|
||||||
|
|
||||||
eq = x: y: x == y;
|
eq = x: y: x == y;
|
||||||
|
|
||||||
@ -17,6 +17,7 @@ rec {
|
|||||||
dir.has-default-nix = path: pathExists (path + "/default.nix");
|
dir.has-default-nix = path: pathExists (path + "/default.nix");
|
||||||
|
|
||||||
dns = import ./dns.nix { inherit lib; };
|
dns = import ./dns.nix { inherit lib; };
|
||||||
|
git = import ./git.nix { lib = lib // out; };
|
||||||
listset = import ./listset.nix { inherit lib; };
|
listset = import ./listset.nix { inherit lib; };
|
||||||
shell = import ./shell.nix { inherit lib; };
|
shell = import ./shell.nix { inherit lib; };
|
||||||
tree = import ./tree.nix { inherit lib; };
|
tree = import ./tree.nix { inherit lib; };
|
||||||
@ -30,4 +31,8 @@ rec {
|
|||||||
subdirsOf = path:
|
subdirsOf = path:
|
||||||
mapAttrs (name: _: path + "/${name}")
|
mapAttrs (name: _: path + "/${name}")
|
||||||
(filterAttrs (_: eq "directory") (readDir path));
|
(filterAttrs (_: eq "directory") (readDir path));
|
||||||
}
|
|
||||||
|
mapAttrValues = f: mapAttrs (_: f);
|
||||||
|
setAttr = name: value: set: set // { ${name} = value; };
|
||||||
|
|
||||||
|
}; in out
|
||||||
|
|||||||
42
krebs/4lib/git.nix
Normal file
42
krebs/4lib/git.nix
Normal file
@ -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
|
||||||
168
krebs/5pkgs/git-hooks/default.nix
Normal file
168
krebs/5pkgs/git-hooks/default.nix
Normal file
@ -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
|
||||||
16
krebs/5pkgs/haskell-overrides/xmonad-stockholm.nix
Normal file
16
krebs/5pkgs/haskell-overrides/xmonad-stockholm.nix
Normal file
@ -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;
|
||||||
|
}
|
||||||
@ -17,7 +17,6 @@ in
|
|||||||
|
|
||||||
{
|
{
|
||||||
krebs.build.host = config.krebs.hosts.mkdir;
|
krebs.build.host = config.krebs.hosts.mkdir;
|
||||||
|
|
||||||
krebs.build.target = "root@${primary-addr4}";
|
krebs.build.target = "root@${primary-addr4}";
|
||||||
|
|
||||||
imports = [
|
imports = [
|
||||||
|
|||||||
@ -212,7 +212,6 @@ with lib;
|
|||||||
|
|
||||||
security.setuidPrograms = [
|
security.setuidPrograms = [
|
||||||
"sendmail" # for cron
|
"sendmail" # for cron
|
||||||
#"slock"
|
|
||||||
];
|
];
|
||||||
|
|
||||||
services.printing.enable = true;
|
services.printing.enable = true;
|
||||||
|
|||||||
@ -88,6 +88,12 @@ with lib;
|
|||||||
ls = "ls -h --color=auto --group-directories-first";
|
ls = "ls -h --color=auto --group-directories-first";
|
||||||
dmesg = "dmesg -L --reltime";
|
dmesg = "dmesg -L --reltime";
|
||||||
view = "vim -R";
|
view = "vim -R";
|
||||||
|
|
||||||
|
reload = "systemctl reload";
|
||||||
|
restart = "systemctl restart";
|
||||||
|
start = "systemctl start";
|
||||||
|
status = "systemctl status";
|
||||||
|
stop = "systemctl stop";
|
||||||
};
|
};
|
||||||
|
|
||||||
environment.variables = {
|
environment.variables = {
|
||||||
@ -167,5 +173,13 @@ with lib;
|
|||||||
"sendmail" # for sudo
|
"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";
|
||||||
|
}
|
||||||
];
|
];
|
||||||
}
|
}
|
||||||
|
|||||||
@ -1,6 +1,7 @@
|
|||||||
{ config, lib, pkgs, ... }:
|
{ config, lib, pkgs, ... }:
|
||||||
|
|
||||||
with import ../4lib { inherit lib pkgs; };
|
with lib;
|
||||||
|
|
||||||
let
|
let
|
||||||
|
|
||||||
out = {
|
out = {
|
||||||
@ -20,26 +21,22 @@ let
|
|||||||
rules = concatMap make-rules (attrValues repos);
|
rules = concatMap make-rules (attrValues repos);
|
||||||
|
|
||||||
public-repos = mapAttrs make-public-repo ({
|
public-repos = mapAttrs make-public-repo ({
|
||||||
|
} // mapAttrValues (setAttr "section" "1. Miscellaneous") {
|
||||||
cac = {
|
cac = {
|
||||||
desc = "CloudAtCost command line interface";
|
desc = "CloudAtCost command line interface";
|
||||||
};
|
};
|
||||||
cgserver = {};
|
|
||||||
crude-mail-setup = {};
|
|
||||||
dot-xmonad = {};
|
|
||||||
get = {};
|
get = {};
|
||||||
hack = {};
|
hack = {};
|
||||||
load-env = {};
|
load-env = {};
|
||||||
make-snapshot = {};
|
make-snapshot = {};
|
||||||
much = {};
|
much = {};
|
||||||
nixos-infest = {};
|
|
||||||
nixpkgs = {};
|
nixpkgs = {};
|
||||||
painload = {};
|
|
||||||
push = {};
|
push = {};
|
||||||
regfish = {};
|
regfish = {};
|
||||||
stockholm = {
|
stockholm = {
|
||||||
desc = "take all the computers hostage, they'll love you!";
|
desc = "take all the computers hostage, they'll love you!";
|
||||||
};
|
};
|
||||||
} // mapAttrs (_: repo: repo // { section = "Haskell libraries"; }) {
|
} // mapAttrValues (setAttr "section" "2. Haskell libraries") {
|
||||||
blessings = {};
|
blessings = {};
|
||||||
mime = {};
|
mime = {};
|
||||||
quipper = {};
|
quipper = {};
|
||||||
@ -47,6 +44,13 @@ let
|
|||||||
wai-middleware-time = {};
|
wai-middleware-time = {};
|
||||||
web-routes-wai-custom = {};
|
web-routes-wai-custom = {};
|
||||||
xintmap = {};
|
xintmap = {};
|
||||||
|
xmonad-stockholm = {};
|
||||||
|
} // mapAttrValues (setAttr "section" "3. Museum") {
|
||||||
|
cgserver = {};
|
||||||
|
crude-mail-setup = {};
|
||||||
|
dot-xmonad = {};
|
||||||
|
nixos-infest = {};
|
||||||
|
painload = {};
|
||||||
});
|
});
|
||||||
|
|
||||||
restricted-repos = mapAttrs make-restricted-repo (
|
restricted-repos = mapAttrs make-restricted-repo (
|
||||||
@ -63,7 +67,7 @@ let
|
|||||||
inherit name desc section;
|
inherit name desc section;
|
||||||
public = true;
|
public = true;
|
||||||
hooks = {
|
hooks = {
|
||||||
post-receive = git.irc-announce {
|
post-receive = pkgs.git-hooks.irc-announce {
|
||||||
# TODO make nick = config.krebs.build.host.name the default
|
# TODO make nick = config.krebs.build.host.name the default
|
||||||
nick = config.krebs.build.host.name;
|
nick = config.krebs.build.host.name;
|
||||||
channel = "#retiolum";
|
channel = "#retiolum";
|
||||||
@ -82,7 +86,7 @@ let
|
|||||||
with git // config.krebs.users;
|
with git // config.krebs.users;
|
||||||
repo:
|
repo:
|
||||||
singleton {
|
singleton {
|
||||||
user = tv;
|
user = [ tv tv_xu ];
|
||||||
repo = [ repo ];
|
repo = [ repo ];
|
||||||
perm = push "refs/*" [ non-fast-forward create delete merge ];
|
perm = push "refs/*" [ non-fast-forward create delete merge ];
|
||||||
} ++
|
} ++
|
||||||
|
|||||||
@ -64,6 +64,10 @@ let
|
|||||||
\ | hi TrailingSpace ctermbg=88
|
\ | hi TrailingSpace ctermbg=88
|
||||||
\ | hi Normal ctermfg=White
|
\ | 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" ''
|
au BufRead,BufNewFile *.nix so ${pkgs.writeText "nix.vim" ''
|
||||||
setf nix
|
setf nix
|
||||||
set isk=@,48-57,_,192-255,-,'
|
set isk=@,48-57,_,192-255,-,'
|
||||||
|
|||||||
@ -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;
|
|
||||||
}
|
|
||||||
202
tv/4lib/git.nix
202
tv/4lib/git.nix
@ -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
|
|
||||||
@ -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;
|
|
||||||
}
|
|
||||||
@ -35,9 +35,9 @@ import XMonad.Layout.PerWorkspace (onWorkspace)
|
|||||||
--import XMonad.Layout.BinarySpacePartition
|
--import XMonad.Layout.BinarySpacePartition
|
||||||
|
|
||||||
--import XMonad.Actions.Submap
|
--import XMonad.Actions.Submap
|
||||||
import Util.Pager
|
import XMonad.Stockholm.Pager
|
||||||
import Util.Rhombus
|
import XMonad.Stockholm.Rhombus
|
||||||
import Util.Shutdown
|
import XMonad.Stockholm.Shutdown
|
||||||
|
|
||||||
|
|
||||||
myTerm :: String
|
myTerm :: String
|
||||||
|
|||||||
@ -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
|
|
||||||
@ -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)
|
|
||||||
@ -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
|
|
||||||
@ -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 ()
|
|
||||||
@ -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)
|
|
||||||
@ -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
|
|
||||||
@ -9,11 +9,9 @@ Executable xmonad
|
|||||||
Build-Depends:
|
Build-Depends:
|
||||||
base,
|
base,
|
||||||
containers,
|
containers,
|
||||||
filepath,
|
|
||||||
unix,
|
unix,
|
||||||
X11,
|
|
||||||
X11-xshape,
|
|
||||||
xmonad,
|
xmonad,
|
||||||
xmonad-contrib
|
xmonad-contrib,
|
||||||
|
xmonad-stockholm
|
||||||
GHC-Options: -Wall -O3 -threaded -rtsopts
|
GHC-Options: -Wall -O3 -threaded -rtsopts
|
||||||
Main-Is: Main.hs
|
Main-Is: Main.hs
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user