init
This commit is contained in:
commit
4f1f1b3a7f
|
|
@ -0,0 +1,4 @@
|
||||||
|
.stack-work/
|
||||||
|
stack.yaml.lock
|
||||||
|
TAGS
|
||||||
|
*~
|
||||||
|
|
@ -0,0 +1,30 @@
|
||||||
|
Copyright Nathan Dwarshuis (c) 2020
|
||||||
|
|
||||||
|
All rights reserved.
|
||||||
|
|
||||||
|
Redistribution and use in source and binary forms, with or without
|
||||||
|
modification, are permitted provided that the following conditions are met:
|
||||||
|
|
||||||
|
* Redistributions of source code must retain the above copyright
|
||||||
|
notice, this list of conditions and the following disclaimer.
|
||||||
|
|
||||||
|
* Redistributions in binary form must reproduce the above
|
||||||
|
copyright notice, this list of conditions and the following
|
||||||
|
disclaimer in the documentation and/or other materials provided
|
||||||
|
with the distribution.
|
||||||
|
|
||||||
|
* Neither the name of Nathan Dwarshuis nor the names of other
|
||||||
|
contributors may be used to endorse or promote products derived
|
||||||
|
from this software without specific prior written permission.
|
||||||
|
|
||||||
|
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||||
|
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||||
|
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||||
|
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||||
|
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||||
|
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||||
|
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||||
|
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||||
|
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||||
|
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||||
|
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||||
|
|
@ -0,0 +1,178 @@
|
||||||
|
{-# LANGUAGE DeriveFunctor #-}
|
||||||
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
|
||||||
|
module Main where
|
||||||
|
|
||||||
|
import Control.Monad (forM_, forever, void, when)
|
||||||
|
import Control.Monad.Reader
|
||||||
|
import Control.Monad.State
|
||||||
|
|
||||||
|
import Data.List (any)
|
||||||
|
import Data.Maybe (isJust)
|
||||||
|
|
||||||
|
import Foreign.C.String (castCCharToChar)
|
||||||
|
import Foreign.C.Types (CLong)
|
||||||
|
|
||||||
|
import Graphics.X11.Types
|
||||||
|
import Graphics.X11.Xlib.Atom
|
||||||
|
import Graphics.X11.Xlib.Display
|
||||||
|
import Graphics.X11.Xlib.Event
|
||||||
|
import Graphics.X11.Xlib.Extras
|
||||||
|
import Graphics.X11.Xlib.Misc
|
||||||
|
import Graphics.X11.Xlib.Types
|
||||||
|
|
||||||
|
import Text.Regex.TDFA
|
||||||
|
|
||||||
|
import System.Environment
|
||||||
|
import System.Posix.IO
|
||||||
|
import System.Posix.Signals
|
||||||
|
import System.Process
|
||||||
|
|
||||||
|
type WindowTitle = String
|
||||||
|
|
||||||
|
-- I wonder where this idea came from...
|
||||||
|
newtype XMan a = XMan (ReaderT XMConf (StateT XMState IO) a) deriving
|
||||||
|
(Functor, Monad, MonadIO, MonadState XMState, MonadReader XMConf)
|
||||||
|
|
||||||
|
instance Applicative XMan where
|
||||||
|
pure = return
|
||||||
|
(<*>) = ap
|
||||||
|
|
||||||
|
data XMState = XMState
|
||||||
|
{ currentTitle :: Maybe WindowTitle
|
||||||
|
, xcapeProcess :: Maybe ProcessHandle
|
||||||
|
}
|
||||||
|
|
||||||
|
data XMConf = XMConf
|
||||||
|
{ display :: Display
|
||||||
|
, theRoot :: Window
|
||||||
|
, netActiveWindow :: Atom
|
||||||
|
, netWMName :: Atom
|
||||||
|
, regexps :: [String]
|
||||||
|
, xcapeKeys :: String
|
||||||
|
}
|
||||||
|
|
||||||
|
io :: MonadIO m => IO a -> m a
|
||||||
|
io = liftIO
|
||||||
|
|
||||||
|
runXMan :: XMConf -> XMState -> XMan a -> IO (a, XMState)
|
||||||
|
runXMan c s (XMan a) = runStateT (runReaderT a c) s
|
||||||
|
|
||||||
|
parse :: [String] -> IO ()
|
||||||
|
parse [_] = usage
|
||||||
|
parse (x:rs) = initXMan x rs
|
||||||
|
parse _ = usage
|
||||||
|
|
||||||
|
usage :: IO ()
|
||||||
|
usage = putStrLn "xman XCAPE_KEYS REGEXP [[REGEXP]...]"
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = getArgs >>= parse
|
||||||
|
|
||||||
|
initXMan :: String -> [String] -> IO ()
|
||||||
|
initXMan x r = do
|
||||||
|
void $ installHandler sigCHLD Ignore Nothing
|
||||||
|
dpy <- openDisplay ""
|
||||||
|
root <- rootWindow dpy $ defaultScreen dpy
|
||||||
|
naw <- internAtom dpy "_NET_ACTIVE_WINDOW" False
|
||||||
|
nwn <- internAtom dpy "_NET_WM_NAME" False
|
||||||
|
let cf = XMConf
|
||||||
|
{ display = dpy
|
||||||
|
, theRoot = root
|
||||||
|
, netActiveWindow = naw
|
||||||
|
, netWMName = nwn
|
||||||
|
, regexps = r
|
||||||
|
, xcapeKeys = x
|
||||||
|
}
|
||||||
|
st = XMState { currentTitle = Nothing, xcapeProcess = Nothing }
|
||||||
|
allocaSetWindowAttributes $ \a -> do
|
||||||
|
set_event_mask a propertyChangeMask
|
||||||
|
changeWindowAttributes dpy root cWEventMask a
|
||||||
|
void $ allocaXEvent $ \e ->
|
||||||
|
runXMan cf st $ do
|
||||||
|
updateXCape
|
||||||
|
forever $ handle =<< io (nextEvent dpy e >> getEvent e)
|
||||||
|
|
||||||
|
updateXCape :: XMan ()
|
||||||
|
updateXCape = do
|
||||||
|
dpy <- asks display
|
||||||
|
atom <- asks netActiveWindow
|
||||||
|
root <- asks theRoot
|
||||||
|
prop <- io $ getWindowProperty32 dpy atom root
|
||||||
|
case prop of
|
||||||
|
Just [aw] -> getTitle aw >>= updateTitle >> startOrKillXCape
|
||||||
|
_ -> return ()
|
||||||
|
|
||||||
|
handle :: Event -> XMan ()
|
||||||
|
handle PropertyEvent { ev_atom = a } = do
|
||||||
|
atom <- asks netActiveWindow
|
||||||
|
when (a == atom) updateXCape
|
||||||
|
handle _ = return ()
|
||||||
|
|
||||||
|
getTitle :: CLong -> XMan (Maybe WindowTitle)
|
||||||
|
getTitle winID = do
|
||||||
|
nwn <- asks netWMName
|
||||||
|
-- try getting _NET_WM_NAME first before trying legacy WM_NAME
|
||||||
|
doMaybe [nwn, wM_NAME] $ getTitle' winID
|
||||||
|
where
|
||||||
|
doMaybe (x:xs) f = f x >>= (\r -> if isJust r then return r else doMaybe xs f)
|
||||||
|
doMaybe [] _ = return Nothing
|
||||||
|
|
||||||
|
getTitle' :: CLong -> Atom -> XMan (Maybe WindowTitle)
|
||||||
|
getTitle' winID atom = do
|
||||||
|
dpy <- asks display
|
||||||
|
title' <- io $ permitBadWindow $ getWindowProperty8 dpy atom
|
||||||
|
$ fromIntegral winID
|
||||||
|
return $ fmap (fmap castCCharToChar) title'
|
||||||
|
|
||||||
|
permitBadWindow :: IO a -> IO a
|
||||||
|
permitBadWindow action = do
|
||||||
|
handler <- mkXErrorHandler $ \_ e ->
|
||||||
|
getErrorEvent e >>= handleError >> return 0
|
||||||
|
original <- _xSetErrorHandler handler
|
||||||
|
res <- action
|
||||||
|
void $ _xSetErrorHandler original
|
||||||
|
return res
|
||||||
|
where
|
||||||
|
-- totally ignore BadWindow errors
|
||||||
|
-- TODO also ignore badvalue errors?
|
||||||
|
handleError ErrorEvent { ev_error_code = t }
|
||||||
|
| fromIntegral t == badWindow = return ()
|
||||||
|
-- anything not a BadWindow is an unexpected error
|
||||||
|
handleError _ = print "actual error"
|
||||||
|
|
||||||
|
updateTitle :: Maybe WindowTitle -> XMan ()
|
||||||
|
updateTitle newTitle = modify (\s -> s { currentTitle = newTitle } )
|
||||||
|
|
||||||
|
startOrKillXCape :: XMan ()
|
||||||
|
startOrKillXCape = do
|
||||||
|
title <- gets currentTitle
|
||||||
|
case title of
|
||||||
|
Just t -> asks regexps >>= \r ->
|
||||||
|
if any (t =~) r then stopXCape else startXCape
|
||||||
|
Nothing -> startXCape
|
||||||
|
|
||||||
|
startXCape :: XMan ()
|
||||||
|
startXCape = do
|
||||||
|
pID <- gets xcapeProcess
|
||||||
|
unless (isJust pID) $ do
|
||||||
|
x <- asks xcapeKeys
|
||||||
|
h <- io $ runXcape x
|
||||||
|
modify $ \s -> s { xcapeProcess = Just h }
|
||||||
|
io $ print "started xcape"
|
||||||
|
|
||||||
|
stopXCape :: XMan ()
|
||||||
|
stopXCape = do
|
||||||
|
pID <- gets xcapeProcess
|
||||||
|
forM_ pID $ \p -> do
|
||||||
|
io $ terminateProcess p
|
||||||
|
modify $ \s -> s { xcapeProcess = Nothing }
|
||||||
|
io $ print "stopped xcape"
|
||||||
|
|
||||||
|
runXcape :: String -> IO ProcessHandle
|
||||||
|
runXcape keys = do
|
||||||
|
dn <- fmap UseHandle $ fdToHandle
|
||||||
|
=<< openFd "/dev/null" ReadOnly Nothing defaultFileFlags
|
||||||
|
let cp = proc "xcape" $ ["-d", "-t", "500", "-e"] ++ [keys]
|
||||||
|
(_, _, _, h) <- createProcess $ cp { std_err = dn, std_out = dn }
|
||||||
|
return h
|
||||||
|
|
@ -0,0 +1,66 @@
|
||||||
|
# This file was automatically generated by 'stack init'
|
||||||
|
#
|
||||||
|
# Some commonly used options have been documented as comments in this file.
|
||||||
|
# For advanced use and comprehensive documentation of the format, please see:
|
||||||
|
# https://docs.haskellstack.org/en/stable/yaml_configuration/
|
||||||
|
|
||||||
|
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
|
||||||
|
# A snapshot resolver dictates the compiler version and the set of packages
|
||||||
|
# to be used for project dependencies. For example:
|
||||||
|
#
|
||||||
|
# resolver: lts-3.5
|
||||||
|
# resolver: nightly-2015-09-21
|
||||||
|
# resolver: ghc-7.10.2
|
||||||
|
#
|
||||||
|
# The location of a snapshot can be provided as a file or url. Stack assumes
|
||||||
|
# a snapshot provided as a file might change, whereas a url resource does not.
|
||||||
|
#
|
||||||
|
# resolver: ./custom-snapshot.yaml
|
||||||
|
# resolver: https://example.com/snapshots/2018-01-01.yaml
|
||||||
|
resolver: lts-14.12
|
||||||
|
|
||||||
|
# User packages to be built.
|
||||||
|
# Various formats can be used as shown in the example below.
|
||||||
|
#
|
||||||
|
# packages:
|
||||||
|
# - some-directory
|
||||||
|
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
|
||||||
|
# subdirs:
|
||||||
|
# - auto-update
|
||||||
|
# - wai
|
||||||
|
packages:
|
||||||
|
- .
|
||||||
|
# Dependency packages to be pulled from upstream that are not in the resolver.
|
||||||
|
# These entries can reference officially published versions as well as
|
||||||
|
# forks / in-progress versions pinned to a git hash. For example:
|
||||||
|
#
|
||||||
|
# extra-deps:
|
||||||
|
# - acme-missiles-0.3
|
||||||
|
# - git: https://github.com/commercialhaskell/stack.git
|
||||||
|
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
|
||||||
|
#
|
||||||
|
# extra-deps: []
|
||||||
|
|
||||||
|
# Override default flag values for local packages and extra-deps
|
||||||
|
# flags: {}
|
||||||
|
|
||||||
|
# Extra package databases containing global packages
|
||||||
|
# extra-package-dbs: []
|
||||||
|
|
||||||
|
# Control whether we use the GHC we find on the path
|
||||||
|
# system-ghc: true
|
||||||
|
#
|
||||||
|
# Require a specific version of stack, using version ranges
|
||||||
|
# require-stack-version: -any # Default
|
||||||
|
# require-stack-version: ">=2.1"
|
||||||
|
#
|
||||||
|
# Override the architecture used by stack, especially useful on Windows
|
||||||
|
# arch: i386
|
||||||
|
# arch: x86_64
|
||||||
|
#
|
||||||
|
# Extra directories used by stack for building
|
||||||
|
# extra-include-dirs: [/path/to/dir]
|
||||||
|
# extra-lib-dirs: [/path/to/dir]
|
||||||
|
#
|
||||||
|
# Allow a newer minor version of GHC than the snapshot specifies
|
||||||
|
# compiler-check: newer-minor
|
||||||
|
|
@ -0,0 +1,37 @@
|
||||||
|
cabal-version: 1.12
|
||||||
|
|
||||||
|
-- This file has been generated from package.yaml by hpack version 0.31.2.
|
||||||
|
--
|
||||||
|
-- see: https://github.com/sol/hpack
|
||||||
|
--
|
||||||
|
-- hash: 32a585abcde8be89acd003c83fd878360a2fa7ed9a02418cbcbf6539cfd85401
|
||||||
|
|
||||||
|
name: xman-hs
|
||||||
|
version: 0.1.0.0
|
||||||
|
description: Please see the README on GitHub at <https://github.com/ndwarshuis/xman-hs#readme>
|
||||||
|
homepage: https://github.com/ndwarshuis/xman-hs#readme
|
||||||
|
bug-reports: https://github.com/ndwarshuis/xman-hs/issues
|
||||||
|
author: Nathan Dwarshuis
|
||||||
|
maintainer: ndwar@yavin4.ch
|
||||||
|
copyright: 2020 Nathan Dwarshuis
|
||||||
|
license: BSD3
|
||||||
|
license-file: LICENSE
|
||||||
|
build-type: Simple
|
||||||
|
|
||||||
|
extra-source-files:
|
||||||
|
README.md
|
||||||
|
|
||||||
|
executable xman-hs
|
||||||
|
main-is: Main.hs
|
||||||
|
hs-source-dirs:
|
||||||
|
app
|
||||||
|
ghc-options: -Wall -Werror -fno-warn-missing-signatures -threaded -rtsopts -with-rtsopts=-N
|
||||||
|
build-depends:
|
||||||
|
base >=4.7 && <5
|
||||||
|
, X11
|
||||||
|
, mtl >= 2.2.2
|
||||||
|
, unix >= 2.7.2.2
|
||||||
|
, regex-tdfa >= 1.2.3.2
|
||||||
|
, process >= 1.6.5.0
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
Loading…
Reference in New Issue