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