├── .gitignore ├── LICENSE ├── Setup.hs ├── reactand.cabal ├── src ├── Helpers.hs ├── Host.hs ├── Layout.hs ├── LayoutType.hs ├── Main.hs ├── Reactand.hs ├── StackSet.hs ├── Tree.hs ├── Types.hs └── WLCHandlers.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | cabal.sandbox.config 2 | /.cabal-sandbox/ 3 | 4 | /dist/ 5 | *~ 6 | /TAGS 7 | /.stack-work/ 8 | /dist-stack/ 9 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Moritz Kiefer 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. 4 | 5 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 6 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /reactand.cabal: -------------------------------------------------------------------------------- 1 | -- Initial reactand.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | -- The name of the package. 5 | name: reactand 6 | 7 | -- The package version. See the Haskell package versioning policy (PVP) 8 | -- for standards guiding when and how versions should be incremented. 9 | -- http://www.haskell.org/haskellwiki/Package_versioning_policy 10 | -- PVP summary: +-+------- breaking API changes 11 | -- | | +----- non-breaking API additions 12 | -- | | | +--- code changes with no API change 13 | version: 0.1.0.0 14 | 15 | -- A short (one-line) description of the package. 16 | -- synopsis: 17 | 18 | -- A longer description of the package. 19 | -- description: 20 | 21 | -- The license under which the package is released. 22 | -- license: 23 | 24 | -- The file containing the license text. 25 | license-file: LICENSE 26 | 27 | -- The package author(s). 28 | author: Moritz Kiefer 29 | 30 | -- An email address to which users can send suggestions, bug reports, and 31 | -- patches. 32 | maintainer: moritz.kiefer@purelyfunctional.org 33 | 34 | -- A copyright notice. 35 | -- copyright: 36 | 37 | category: Graphics 38 | 39 | build-type: Simple 40 | 41 | -- Extra files to be distributed with the package, such as examples or a 42 | -- README. 43 | -- extra-source-files: 44 | 45 | -- Constraint on the version of Cabal needed to build this package. 46 | cabal-version: >=1.10 47 | 48 | 49 | executable reactand 50 | -- .hs or .lhs file containing the Main module. 51 | main-is: Main.hs 52 | 53 | -- Modules included in this executable, other than Main. 54 | other-modules: Tree 55 | 56 | -- LANGUAGE extensions used by modules in this package. 57 | other-extensions: TemplateHaskell 58 | 59 | -- Other library packages from which modules are imported. 60 | build-depends: async >= 2.0 && < 2.1 61 | , base >=4.8 && < 4.9 62 | , containers >= 0.5 && < 0.6 63 | , data-default >= 0.5 && < 0.6 64 | , dependent-map >= 0.1 && < 0.2 65 | , dependent-sum >= 0.2 && < 0.3 66 | , dependent-sum-template >= 0.0 && < 0.1 67 | , lens >= 4.9 && < 4.12 68 | , pretty >= 1.1 && < 1.2 69 | , process >= 1.2 && < 1.3 70 | , reflex >= 0.2 && < 0.3 71 | , stm >= 2.4 && < 2.5 72 | , transformers >= 0.4 && < 0.5 73 | , wlc-hs >= 0.1 && < 0.2 74 | , xkbcommon >= 0.0 && < 0.1 75 | , emacs-keys >= 0.0.2 && < 0.1 76 | 77 | -- Directories containing source files. 78 | hs-source-dirs: src 79 | 80 | -- Base language which the package is written in. 81 | default-language: Haskell2010 82 | ghc-options: -Wall -threaded 83 | -------------------------------------------------------------------------------- /src/Helpers.hs: -------------------------------------------------------------------------------- 1 | module Helpers 2 | ( getSym 3 | , getKeyState 4 | , getModifiers 5 | , emptyStackSet 6 | , singleton' 7 | , modToWLCMod 8 | ) where 9 | 10 | import Data.Bits 11 | import qualified Data.Dependent.Map as DMap 12 | import Data.Dependent.Sum 13 | import Data.GADT.Compare 14 | import Data.Set hiding (filter) 15 | import EmacsKeys 16 | import Foreign.C.Types 17 | import Text.XkbCommon 18 | import WLC 19 | 20 | import LayoutType 21 | import StackSet 22 | import Tree 23 | 24 | getSym :: CUInt -> Keysym 25 | getSym sym = Keysym (fromIntegral sym) 26 | 27 | getKeyState :: WLCKeyStateBit -> WLCKeyState 28 | getKeyState b = toEnum (fromIntegral b) 29 | 30 | getModifiers :: WLCModifiers -> Set WLCModifier 31 | getModifiers (WLCModifiers _ mods) = 32 | fromList (filter (\modifier -> 33 | mods .&. 34 | fromIntegral (fromEnum modifier) /= 35 | 0) 36 | (enumFrom WlcBitModShift)) 37 | 38 | emptyStackSet :: StackSet String a sid 39 | emptyStackSet = 40 | StackSet Nothing 41 | [] 42 | (fmap (\i -> 43 | (Workspace (show i) 44 | (2 ^ i) 45 | (TreeZipper (Tree horizontalLayout Nothing) 46 | []))) 47 | [0 :: Int .. 1]) 48 | 49 | -- | generate singleton map from dsum. 50 | singleton' :: GCompare k => DSum k -> DMap.DMap k 51 | singleton' = DMap.fromList . (:[]) 52 | 53 | modToWLCMod :: Modifier -> WLCModifier 54 | modToWLCMod Shift = WlcBitModShift 55 | modToWLCMod Meta = WlcBitModAlt 56 | modToWLCMod Ctrl = WlcBitModCtrl 57 | -------------------------------------------------------------------------------- /src/Host.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | module Host 4 | ( host 5 | ) where 6 | 7 | import Control.Concurrent.Chan 8 | import Control.Concurrent.MVar 9 | import Control.Monad 10 | import Control.Monad.IO.Class 11 | import Data.Dependent.Sum 12 | import Data.IORef 13 | import Reflex.Host.Class 14 | import Reflex.Spider 15 | 16 | import Types 17 | 18 | -- | reflex host for the window manager 19 | host :: Chan (DSum Tag) -> MVar (IO ()) -> (forall t m. WindowManager t m) -> IO () 20 | host messages action wm = 21 | runSpiderHost $ 22 | do (e,eTriggerRef) <- newEventWithTriggerRef 23 | b <- runHostFrame $ wm e 24 | handle <- subscribeEvent b -- bennofs said that I should do this 25 | forever $ 26 | do message <- liftIO $ readChan messages 27 | mETrigger <- liftIO $ readIORef eTriggerRef 28 | case mETrigger of 29 | Nothing -> return () -- nobody cares about our input 30 | Just eTrigger -> 31 | (liftIO =<<) $ 32 | fireEventsAndRead [eTrigger :=> message] $ -- pass input 33 | do r <- readEvent handle -- read the output 34 | case r of 35 | Nothing -> 36 | -- fill tmvar for callbacks 37 | return $ putMVar action (return ()) 38 | Just act -> 39 | -- put the action inside a tmvar for execution by callback 40 | do (putMVar action <$> act) 41 | -------------------------------------------------------------------------------- /src/Layout.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | module Layout (relayout, cycleLayout, insertViewInOutput) where 6 | 7 | import Control.Lens 8 | import StackSet 9 | import WLC hiding (size) 10 | import Tree 11 | import LayoutType 12 | 13 | relayout :: StackSet i WLCViewPtr WLCOutputPtr -> IO () 14 | relayout s = 15 | do forOf_ (current . _Just) s layoutScreen 16 | forOf_ (visible . each) s layoutScreen 17 | forOf_ (current . _Just . workspace . tree . focusT . treeElements . _Just . 18 | focusL . 19 | _Left) 20 | s 21 | (\v -> wlcViewFocus v >> wlcViewBringToFront v) 22 | forOf_ (current . _Just . screen) s wlcOutputFocus 23 | 24 | layoutScreen :: Screen i WLCViewPtr WLCOutputPtr -> IO () 25 | layoutScreen (Screen w sid res) = do 26 | wlcOutputSetMask sid (w ^. mask) 27 | layoutWorkspace res w 28 | 29 | -- | Resize all views on the workspace according to the current layout 30 | layoutWorkspace :: WLCSize -> Workspace i WLCViewPtr -> IO () 31 | layoutWorkspace size ws = 32 | layoutTree size 33 | (integrateTree (ws ^. tree)) 34 | 35 | layoutTree :: WLCSize -> Tree Layout WLCViewPtr -> IO () 36 | layoutTree screenSize mainTree = 37 | go (WLCGeometry (WLCOrigin 0 0) 38 | screenSize) 39 | mainTree 40 | where go _ (Tree _ Nothing) = return () 41 | go (WLCGeometry (WLCOrigin x y) size) (Tree l (Just z)) = 42 | let arrangement = 43 | getLayout l size z & 44 | each . 45 | _2 %~ 46 | (\(WLCGeometry (WLCOrigin x' y') size') -> 47 | WLCGeometry 48 | (WLCOrigin (x + x') 49 | (y + y')) 50 | size') 51 | in mapM_ recurse arrangement 52 | recurse ((Left v),geometry) = 53 | wlcViewSetGeometry v geometry >> 54 | wlcViewSetState v WlcBitMaximized True 55 | recurse ((Right t),geometry) = 56 | go geometry t 57 | 58 | 59 | -- | insert the view into workspace that is focused on the output 60 | insertViewInOutput :: Layout 61 | -> WLCViewPtr 62 | -> WLCOutputPtr 63 | -> StackSet i WLCViewPtr WLCOutputPtr 64 | -> StackSet i WLCViewPtr WLCOutputPtr 65 | insertViewInOutput l v output s = 66 | modifyWithOutput (insertUp l v) 67 | output 68 | s 69 | 70 | cycleLayout :: Layout -> Layout 71 | cycleLayout (Layout _ "Tabbed") = horizontalLayout 72 | cycleLayout (Layout _ "Horizontal") = verticalLayout 73 | cycleLayout (Layout _ "Vertical") = tallLayout 74 | cycleLayout (Layout _ "Tall") = wideLayout 75 | cycleLayout (Layout _ "Wide") = tabbedLayout 76 | cycleLayout _ = horizontalLayout 77 | -------------------------------------------------------------------------------- /src/LayoutType.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | module LayoutType 3 | (Layout(..) 4 | ,tabbedLayout 5 | ,horizontalLayout 6 | ,verticalLayout 7 | ,tallLayout 8 | ,wideLayout) 9 | where 10 | 11 | import Text.PrettyPrint.HughesPJClass 12 | import Foreign.C.Types 13 | import Tree 14 | import WLC 15 | 16 | data Layout = 17 | Layout {getLayout :: forall a. WLCSize -> ListZipper a -> [(a,WLCGeometry)] 18 | ,name :: String} 19 | 20 | instance Eq Layout where 21 | (Layout _ s) == (Layout _ s') = s == s' 22 | 23 | instance Show Layout where 24 | show (Layout _ s) = "Layout " ++ s 25 | 26 | instance Pretty Layout where 27 | pPrint (Layout _ s) = text "Layout " <+> text s 28 | 29 | tabbedLayout :: Layout 30 | tabbedLayout = 31 | Layout (\size' stack -> 32 | let stackList = integrate stack 33 | in zip stackList (repeat (WLCGeometry (WLCOrigin 0 0) size'))) 34 | "Tabbed" 35 | 36 | horizontalLayout :: Layout 37 | horizontalLayout = simpleLayout horizontalSplit "Horizontal" 38 | 39 | horizontalSplit :: CInt -> CInt -> WLCSize -> WLCGeometry 40 | horizontalSplit total i (WLCSize w h) 41 | | total == 0 = error "No windows found" 42 | | otherwise = WLCGeometry (WLCOrigin (i * fromIntegral deltaX) 0) (WLCSize deltaX h) 43 | where deltaX = w `div` fromIntegral total 44 | 45 | verticalLayout :: Layout 46 | verticalLayout = simpleLayout verticalSplit "Vertical" 47 | 48 | verticalSplit :: CInt -> CInt -> WLCSize -> WLCGeometry 49 | verticalSplit total i (WLCSize w h) 50 | | total == 0 = error "No windows found" 51 | | otherwise = WLCGeometry (WLCOrigin 0 (i * fromIntegral deltaY)) (WLCSize w deltaY) 52 | where deltaY = h `div` fromIntegral total 53 | 54 | tallLayout :: Layout 55 | tallLayout = simpleLayout tallSplit "Tall" 56 | 57 | tallSplit :: CInt -> CInt -> WLCSize -> WLCGeometry 58 | tallSplit total i (WLCSize w h) 59 | | total == 0 = error "No windows found" 60 | | i == 0 = 61 | WLCGeometry (WLCOrigin 0 0) 62 | (WLCSize (w `div` (if total == 1 then 1 else 2)) h) 63 | | otherwise = 64 | WLCGeometry 65 | (WLCOrigin w' 66 | ((i - 1) * 67 | fromIntegral deltaY)) 68 | (WLCSize (fromIntegral w') deltaY) 69 | where deltaY = 70 | h `div` 71 | (fromIntegral total - 1) 72 | w' = fromIntegral w `div` 2 73 | 74 | wideLayout :: Layout 75 | wideLayout = simpleLayout wideSplit "Wide" 76 | 77 | wideSplit :: CInt -> CInt -> WLCSize -> WLCGeometry 78 | wideSplit total i (WLCSize w h) 79 | | total == 0 = error "No windows found" 80 | | i == 0 = WLCGeometry (WLCOrigin 0 0) (WLCSize w (h `div` (if total == 1 then 1 else 2))) 81 | | otherwise = WLCGeometry (WLCOrigin ((i-1) * fromIntegral deltaX) h') (WLCSize deltaX (fromIntegral h')) 82 | where deltaX = w `div` (fromIntegral total -1) 83 | h' = fromIntegral h `div` 2 84 | 85 | simpleLayout :: (CInt -> CInt -> WLCSize -> WLCGeometry) -> String -> Layout 86 | simpleLayout f s = Layout (\size' stack -> 87 | let stackList = integrate stack 88 | in zip stackList 89 | (map (\i -> 90 | f (fromIntegral $ length stackList) i size') 91 | [0 ..])) 92 | s 93 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | 7 | module Main where 8 | 9 | import Control.Concurrent.Async 10 | import Control.Concurrent.Chan 11 | import Control.Concurrent.MVar 12 | 13 | import Host 14 | import Reactand 15 | import WLCHandlers 16 | 17 | main :: IO () 18 | main = 19 | do messages <- newChan 20 | action <- newEmptyMVar 21 | aWLC <- async (runWLC messages action) 22 | aReflex <- async (host messages action reactand) 23 | (_,_) <- 24 | waitAnyCatchCancel [aWLC,aReflex] 25 | return () 26 | -------------------------------------------------------------------------------- /src/Reactand.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | module Reactand where 7 | 8 | import Control.Lens hiding (view) 9 | import Control.Monad 10 | import Control.Monad.Fix 11 | import Data.Bifunctor 12 | import Data.Set hiding (map,filter,foldr,split) 13 | import EmacsKeys 14 | import Reflex 15 | import qualified System.Process as P 16 | import Text.PrettyPrint.HughesPJClass hiding (first) 17 | import Text.XkbCommon 18 | import WLC 19 | 20 | import Helpers 21 | import Layout 22 | import LayoutType 23 | import qualified StackSet as S 24 | import qualified Tree as T 25 | import Types 26 | 27 | -- | reactive window manager 28 | reactand :: forall t m. WindowManager t m 29 | reactand e = 30 | do let selector = fan (singleton' <$> e) 31 | keyEv <- 32 | key keyHandlers (select selector TKey) 33 | viewCreatedEv <- 34 | viewCreated (select selector TViewCreated) 35 | viewDestroyedEv <- 36 | viewDestroyed (select selector TViewDestroyed) 37 | outputCreatedEv <- 38 | outputCreated (select selector TOutputCreated) 39 | outputDestroyedEv <- 40 | outputDestroyed (select selector TOutputDestroyed) 41 | outputResolutionEv <- 42 | outputResolution (select selector TOutputResolution) 43 | let actions = 44 | mergeWith (>>) $ 45 | [keyEv 46 | ,viewCreatedEv 47 | ,viewDestroyedEv 48 | ,outputCreatedEv 49 | ,outputDestroyedEv 50 | ,outputResolutionEv] 51 | stackSetDyn <- 52 | nubDyn <$> foldDyn interpretActions emptyStackSet actions 53 | stacksetChanges' <- 54 | -- apply accumulated changes to stackset 55 | mapDyn 56 | ((\stackSet -> 57 | putStrLn (prettyShow stackSet) >> 58 | relayout stackSet)) 59 | stackSetDyn 60 | return $ 61 | mergeWith (>>) (updated stacksetChanges' : [interpretIOActions <$> (attach (current stackSetDyn) actions)]) 62 | 63 | interpretActions :: Actions 64 | -> (S.StackSet String WLCViewPtr WLCOutputPtr) 65 | -> (S.StackSet String WLCViewPtr WLCOutputPtr) 66 | interpretActions acts stackset = 67 | foldr (\x acc -> update x . acc) id acts $ 68 | stackset 69 | where update :: Action 70 | -> S.StackSet String WLCViewPtr WLCOutputPtr 71 | -> S.StackSet String WLCViewPtr WLCOutputPtr 72 | update (CreateOutput output res) = 73 | S.createOutput output res 74 | update (InsertView view output) = 75 | insertViewInOutput horizontalLayout view output 76 | update (ChangeResolution output new) = 77 | S.changeResolution output new 78 | update (DestroyView v) = S.deleteFromStackSet v 79 | update (DestroyOutput o) = S.removeOutput o 80 | update (Focus Up) = S.focusUp 81 | update (Focus Down) = S.focusDown 82 | update (Swap Down) = S.swapDown 83 | update (Swap Up) = S.swapUp 84 | update (Output Up) = S.nextOutput 85 | update (Output Down) = S.prevOutput 86 | update Split = S.current . _Just . S.workspace . S.tree %~ T.split 87 | update (Move Down) = S.current . _Just . S.workspace . S.tree %~ 88 | T.moveDown 89 | update (Move Up) = S.current . _Just . S.workspace . S.tree %~ T.moveUp 90 | update (ViewWorkspace ws) = S.viewWorkspace ws 91 | update Cycle = S.current . _Just . S.workspace . S.tree . T.focusT . 92 | T.layout %~ cycleLayout 93 | update (MoveViewUp) = S.current . _Just . S.workspace . S.tree %~ 94 | T.moveViewUp 95 | update _ = id 96 | 97 | interpretIOActions :: (S.StackSet String WLCViewPtr WLCOutputPtr, Actions) -> IO () 98 | interpretIOActions (s,acts) = mapM_ run acts 99 | where run :: Action -> IO () 100 | run (SpawnCommand c) = void $ P.spawnCommand c 101 | run (FocusView v) = wlcViewFocus v 102 | run Close = mapM_ wlcViewClose 103 | (s ^? S.current . _Just . S.workspace . S.tree . T.focusT . 104 | T.treeElements . _Just . T.focusL . _Left) 105 | run _ = return () 106 | 107 | -- | react to key events 108 | key :: (Reflex t,MonadHold t m,MonadFix m) 109 | => [((Set WLCModifier,Keysym),Actions)] 110 | -> Event t Key 111 | -> m (Event t Actions) 112 | key handlers = 113 | return . 114 | fmapMaybe (\case 115 | Key WlcKeyStatePressed sym mods -> 116 | foldr f Nothing $ 117 | map snd $ 118 | filter (\((mods',sym'),_) -> mods == mods' && sym == sym') handlers 119 | Key _ _ _ -> Nothing) 120 | where f act Nothing = Just act 121 | f act (Just act') = Just (act >> act') 122 | 123 | keyHandlers :: [((Set WLCModifier,Keysym),Actions)] 124 | keyHandlers = fmap (first (bimap (fromList . fmap modToWLCMod) head)) $ 125 | [($(mkEmacsKeys "M-Return"),return $ SpawnCommand "weston-terminal") 126 | ,($(mkEmacsKeys "M-n"),return (Focus Down)) 127 | ,($(mkEmacsKeys "M-r"),return (Focus Up)) 128 | ,($(mkEmacsKeys "M-S-n"),return (Swap Down)) 129 | ,($(mkEmacsKeys "M-S-r"),return (Swap Up)) 130 | ,($(mkEmacsKeys "M-e"),return $ (Output Up)) 131 | ,($(mkEmacsKeys "M-a"),return $ (Output Down)) 132 | ,($(mkEmacsKeys "M-0"),return $ ViewWorkspace "0") 133 | ,($(mkEmacsKeys "M-1"),return $ ViewWorkspace "1") 134 | ,($(mkEmacsKeys "M-2"),return $ ViewWorkspace "2") 135 | ,($(mkEmacsKeys "M-3"),return $ ViewWorkspace "3") 136 | ,($(mkEmacsKeys "M-4"),return $ ViewWorkspace "4") 137 | ,($(mkEmacsKeys "M-5"),return $ ViewWorkspace "5") 138 | ,($(mkEmacsKeys "M-6"),return $ ViewWorkspace "6") 139 | ,($(mkEmacsKeys "M-7"),return $ ViewWorkspace "7") 140 | ,($(mkEmacsKeys "M-8"),return $ ViewWorkspace "8") 141 | ,($(mkEmacsKeys "M-9"),return $ ViewWorkspace "9") 142 | ,($(mkEmacsKeys "M-s"),return Split) 143 | ,($(mkEmacsKeys "M-d"),return (Move Down)) 144 | ,($(mkEmacsKeys "M-u"),return (Move Up)) 145 | ,($(mkEmacsKeys "M-space"),return $ Cycle) 146 | ,($(mkEmacsKeys "M-i"),return $ MoveViewUp) 147 | ,($(mkEmacsKeys "M-S-x"),return $ Close)] 148 | 149 | -- | react to a new view 150 | viewCreated :: (Reflex t,MonadHold t m,MonadFix m) 151 | => Event t ViewCreated 152 | -> m (Event t Actions) 153 | viewCreated = 154 | return . 155 | fmap (\(ViewCreated view output) -> 156 | [InsertView view output, 157 | FocusView view]) 158 | 159 | -- | react to destroyed view 160 | viewDestroyed :: (Reflex t,MonadHold t m,MonadFix m) 161 | => Event t ViewDestroyed 162 | -> m (Event t Actions) 163 | viewDestroyed = 164 | return . 165 | fmap (\(ViewDestroyed view) -> 166 | return $ DestroyView view) 167 | 168 | -- | react to new output 169 | outputCreated :: (Reflex t,MonadHold t m,MonadFix m) 170 | => Event t OutputCreated 171 | -> m (Event t Actions) 172 | outputCreated = 173 | return . 174 | fmap (\(OutputCreated output res) -> 175 | return $ CreateOutput output res) 176 | 177 | -- | react to destroyed output 178 | outputDestroyed :: (Reflex t,MonadHold t m,MonadFix m) 179 | => Event t OutputDestroyed -> m (Event t Actions) 180 | outputDestroyed = 181 | return . 182 | fmap (\(OutputDestroyed output) -> return $ DestroyOutput output) 183 | 184 | outputResolution :: (Reflex t,MonadHold t m,MonadFix m) 185 | => Event t OutputResolution 186 | -> m (Event t Actions) 187 | outputResolution = 188 | return . 189 | fmap (\(OutputResolution output _ new) -> 190 | return $ ChangeResolution output new) 191 | -------------------------------------------------------------------------------- /src/StackSet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE DeriveFunctor #-} 6 | {-# LANGUAGE DeriveFoldable #-} 7 | 8 | module StackSet 9 | ( TreeZipper(..) 10 | , StackSet(..) 11 | , Workspace(..) 12 | , Screen(..) 13 | , deleteFromStackSet 14 | , viewWorkspace 15 | , focusUp 16 | , focusDown 17 | , changeResolution 18 | , swapUp 19 | , swapDown 20 | , modify 21 | , modifyWithOutput 22 | , createOutput 23 | , removeOutput 24 | , nextOutput 25 | , prevOutput 26 | , delete' 27 | , workspace 28 | , resolution 29 | , current 30 | , visible 31 | , hidden 32 | , screen 33 | , tag 34 | , mask 35 | , tree 36 | ) where 37 | 38 | import LayoutType 39 | import Control.Lens 40 | import Data.Function 41 | import Data.List 42 | import Data.Maybe 43 | import Foreign.C.Types 44 | import Text.PrettyPrint.HughesPJClass 45 | import Tree 46 | import WLC 47 | 48 | delete' :: Eq a => a -> [a] -> ([a],Bool) 49 | delete' a xs = 50 | case break (== a) xs of 51 | (_,[]) -> (xs,False) 52 | (us,_:vs) -> (us ++ vs,True) 53 | 54 | data StackSet i a sid = 55 | StackSet {_current :: !(Maybe (Screen i a sid)) 56 | ,_visible :: ![Screen i a sid] 57 | ,_hidden :: ![Workspace i a]} 58 | deriving (Show,Eq) 59 | 60 | instance (Pretty (Screen i a sid),Pretty (Workspace i a)) => Pretty (StackSet i a sid) where 61 | pPrint (StackSet c v h) = 62 | text "StackSet" $$ 63 | nest 2 64 | (text "current =" <+> 65 | pPrint c $$ 66 | text "visible =" <+> 67 | pPrint v $$ 68 | text "hidden =" <+> 69 | pPrint h) 70 | 71 | data Workspace i a = 72 | Workspace {_tag :: !i 73 | ,_mask :: !CUInt 74 | ,_tree :: !(TreeZipper Layout a)} 75 | deriving (Show,Eq) 76 | 77 | instance (Pretty i,Pretty (TreeZipper Layout a)) => Pretty (Workspace i a) where 78 | pPrint (Workspace i m t) = 79 | text "Workspace" $$ 80 | nest 2 81 | (text "tag =" <+> 82 | pPrint i $$ 83 | text "mask =" <+> 84 | pPrintShow m $$ 85 | text "tree = " <+> 86 | pPrint t) 87 | 88 | pPrintShow :: Show a => a -> Doc 89 | pPrintShow = text . show 90 | 91 | data Screen i a sid = 92 | Screen {_workspace :: !(Workspace i a) 93 | ,_screen :: !sid 94 | ,_resolution :: !WLCSize} 95 | deriving (Show,Eq) 96 | 97 | instance (Pretty (Workspace i a),Pretty sid) => Pretty (Screen i a sid) where 98 | pPrint (Screen w sid size) = 99 | text "Screen" $$ 100 | nest 2 (pPrint w $$ pPrint sid $$ pPrintShow size) 101 | 102 | makeLenses ''StackSet 103 | makeLenses ''Workspace 104 | makeLenses ''Screen 105 | 106 | deleteEmpty :: Eq a => TreeZipper l a -> TreeZipper l a 107 | deleteEmpty (TreeZipper t []) = (TreeZipper t []) 108 | deleteEmpty tz@(TreeZipper (Tree _ (Just _)) _) = tz 109 | deleteEmpty (TreeZipper _ (([],l,[]):p)) = TreeZipper (Tree l Nothing) p 110 | deleteEmpty (TreeZipper _ ((x:xs,l,rs):p)) = TreeZipper (Tree l (Just (ListZipper x xs rs))) p 111 | deleteEmpty (TreeZipper _ (([],l,x:xs):p)) = TreeZipper (Tree l (Just (ListZipper x [] xs))) p 112 | 113 | deleteFromStackSet :: Eq a => a -> StackSet i a sid -> StackSet i a sid 114 | deleteFromStackSet v s = s & current . _Just . workspace %~ deleteFromWorkspace v 115 | & visible . mapped . workspace %~ deleteFromWorkspace v 116 | & hidden . mapped %~ deleteFromWorkspace v 117 | 118 | deleteFromWorkspace :: Eq a => a -> Workspace i a -> Workspace i a 119 | deleteFromWorkspace v ws = ws & tree %~ deleteFromTreeZipper v 120 | 121 | deleteFromTreeZipper :: Eq a => a -> TreeZipper l a -> TreeZipper l a 122 | deleteFromTreeZipper v tz = deleteEmpty $ tz & focusT %~ deleteFromTree v 123 | & parentsT . mapped . _1_3 . mapped . _Right %~ deleteFromTree v 124 | 125 | _1_3 :: Traversal (a,c,a) (b,c,b) a b 126 | _1_3 f (a,b,c) = (\x y -> (x,b,y)) <$> f a <*> f c 127 | 128 | deleteFromTree :: Eq a => a -> Tree l a -> Tree l a 129 | deleteFromTree v t = t & treeElements %~ (deleteFromListZipper v =<<) 130 | 131 | deleteFromListZipper :: Eq a => a -> ListZipper (Either a (Tree l a)) -> Maybe (ListZipper (Either a (Tree l a))) 132 | deleteFromListZipper v (ListZipper (Left v') [] []) 133 | | v == v' = Nothing 134 | | otherwise = return (ListZipper (Left v') [] []) 135 | deleteFromListZipper v (ListZipper (Left v') (l:ls) []) 136 | | v == v' = return (ListZipper l ls []) 137 | | otherwise = return (ListZipper (Left v') (deleteFromList v ls) []) 138 | deleteFromListZipper v (ListZipper (Left v') ls (r:rs)) 139 | | v == v' = return (ListZipper r ls rs) 140 | | otherwise = return (ListZipper (Left v') (deleteFromList v ls) (deleteFromList v rs)) 141 | deleteFromListZipper v (ListZipper (Right t) ls rs) = 142 | return (ListZipper (Right (deleteFromTree v t)) 143 | (deleteFromList v ls) 144 | (deleteFromList v rs)) 145 | 146 | deleteFromList :: Eq a => a -> [Either a (Tree l a)] -> [Either a (Tree l a)] 147 | deleteFromList v = mapMaybe f 148 | where 149 | f (Left v') 150 | | v' == v = Nothing 151 | | otherwise = return (Left v') 152 | f (Right t) = return (Right (deleteFromTree v t)) 153 | 154 | 155 | viewWorkspace :: (Eq i,Eq sid) 156 | => i -> StackSet i a sid -> StackSet i a sid 157 | viewWorkspace _ s@(StackSet Nothing _ _) = s 158 | viewWorkspace i s@(StackSet (Just currentScreen) visible' _) 159 | | i == currentScreen ^. workspace . tag = s 160 | | Just x <- 161 | find (\x -> i == x ^. workspace . tag) 162 | (s ^. visible) = 163 | s & current .~ Just x 164 | & visible .~ (currentScreen : 165 | deleteBy (equating (view screen)) x visible') 166 | | Just x <- 167 | find (\x -> i == x ^. tag) 168 | (s ^. hidden) = 169 | s & current .~ Just (currentScreen & workspace .~ x) 170 | & hidden .~ (currentScreen ^. workspace : 171 | deleteBy (equating (view tag)) 172 | x 173 | (s ^. hidden)) 174 | | otherwise = s 175 | 176 | equating :: (Eq b) => (a -> b) -> a -> a -> Bool 177 | equating = on (==) 178 | 179 | createOutput :: sid -> WLCSize -> StackSet i a sid -> StackSet i a sid 180 | createOutput _ _ (StackSet _ _ []) = error "No more workspaces available" 181 | createOutput sid res s@(StackSet Nothing _ (x:xs)) = 182 | s & current .~ Just (Screen x sid res) 183 | & hidden .~ xs 184 | createOutput sid res s@(StackSet _ visible' (x:xs)) = 185 | s & visible .~ (Screen x sid res) : visible' 186 | & hidden .~ xs 187 | 188 | removeOutput :: Eq sid => sid -> StackSet i a sid -> StackSet i a sid 189 | removeOutput sid s = 190 | StackSet current' visible' (hidden'' ++ hidden' ++ (s ^. hidden)) 191 | where (visible',hidden') = 192 | deleteBySid sid (s ^. visible) 193 | (current',hidden'') = 194 | case (s ^. current) of 195 | Nothing -> (Nothing,[]) 196 | Just screen' 197 | | screen' ^. screen == sid -> 198 | (Nothing,return $ screen' ^. workspace) 199 | | otherwise -> (Just screen',[]) 200 | 201 | deleteBySid :: Eq sid => sid -> [Screen i a sid] -> ([Screen i a sid],[Workspace i a]) 202 | deleteBySid sid screens = 203 | break ((== sid) . 204 | (view screen)) 205 | screens & 206 | _2 . traverse %~ 207 | (view workspace) 208 | 209 | withOutput :: (TreeZipper Layout a -> b) -> Screen i a sid -> b 210 | withOutput f s = f $ s ^. workspace . tree 211 | 212 | modify :: (TreeZipper Layout a -> TreeZipper Layout a) 213 | -> StackSet i a sid 214 | -> StackSet i a sid 215 | modify f s = s & current . _Just . workspace . tree %~ f 216 | 217 | modifyWithOutput :: Eq sid 218 | => (TreeZipper Layout a -> TreeZipper Layout a) 219 | -> sid 220 | -> StackSet i a sid 221 | -> StackSet i a sid 222 | modifyWithOutput f sid s = 223 | s & current . _Just %~ 224 | (\cur -> modifyOutput f 225 | sid 226 | cur) 227 | & visible %~map (modifyOutput f sid) 228 | 229 | modifyOutput :: Eq sid 230 | => (TreeZipper Layout a -> TreeZipper Layout a) 231 | -> sid 232 | -> Screen i a sid 233 | -> Screen i a sid 234 | modifyOutput f sid s 235 | | sid == s ^. screen = 236 | s & workspace . tree .~ 237 | withOutput f s 238 | | otherwise = s 239 | 240 | modify' :: (ListZipper (Either a (Tree Layout a)) -> ListZipper (Either a (Tree Layout a))) 241 | -> StackSet i a sid 242 | -> StackSet i a sid 243 | modify' f = modify (\tz -> tz & focusT . treeElements . _Just %~ f) 244 | 245 | focusUp :: StackSet i a sid -> StackSet i a sid 246 | focusUp = modify' focusUp' 247 | 248 | focusDown :: StackSet i a sid -> StackSet i a sid 249 | focusDown = modify' focusDown' 250 | 251 | swapUp :: StackSet i a sid -> StackSet i a sid 252 | swapUp = modify' swapUp' 253 | 254 | swapDown :: StackSet i a sid -> StackSet i a sid 255 | swapDown = modify' (reverseStack . swapUp' . reverseStack) 256 | 257 | swapUp' :: ListZipper a -> ListZipper a 258 | swapUp' (ListZipper t (l:ls) rs) = ListZipper t ls (l:rs) 259 | swapUp' (ListZipper t [] rs) = ListZipper t (reverse rs) [] 260 | 261 | focusUp', focusDown' :: ListZipper a -> ListZipper a 262 | focusUp' (ListZipper t (l:ls) rs) = ListZipper l ls (t:rs) 263 | focusUp' (ListZipper t [] rs) = ListZipper x xs [] where (x:xs) = reverse (t:rs) 264 | focusDown' = reverseStack . focusUp' . reverseStack 265 | 266 | reverseStack :: ListZipper a -> ListZipper a 267 | reverseStack (ListZipper t ls rs) = ListZipper t rs ls 268 | 269 | nextOutput :: StackSet i a sid -> StackSet i a sid 270 | nextOutput (StackSet c [] h) = (StackSet c [] h) 271 | nextOutput (StackSet Nothing (x:xs) h) = (StackSet (Just x) xs h) 272 | nextOutput (StackSet (Just s) (x:xs) h) = (StackSet (Just x) (xs++ [s]) h) 273 | 274 | prevOutput :: StackSet i a sid -> StackSet i a sid 275 | prevOutput (StackSet c [] h) = (StackSet c [] h) 276 | prevOutput (StackSet Nothing xs h) = (StackSet (Just (last xs)) (init xs) h) 277 | prevOutput (StackSet (Just s) xs h) = (StackSet (Just (last xs)) (s: init xs) h) 278 | 279 | changeResolution' :: Eq sid => sid -> WLCSize -> Screen i a sid -> Screen i a sid 280 | changeResolution' sid res s 281 | | sid == s ^. screen = s & resolution .~ res 282 | | otherwise = s 283 | 284 | changeResolution :: Eq sid => sid -> WLCSize -> StackSet i a sid -> StackSet i a sid 285 | changeResolution sid res s = 286 | s & 287 | current . _Just %~ changeResolution' sid res & 288 | visible . mapped %~ changeResolution' sid res 289 | -------------------------------------------------------------------------------- /src/Tree.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | module Tree 6 | (Tree(..) 7 | ,ListZipper(..) 8 | ,TreeZipper(..) 9 | ,integrate 10 | ,integrate' 11 | ,insertUp 12 | ,focusL 13 | ,leftL 14 | ,rightL 15 | ,focusT 16 | ,split 17 | ,moveDown 18 | ,moveUp 19 | ,moveViewUp 20 | ,parentsT 21 | ,layout 22 | ,treeElements 23 | ,integrateTree 24 | ) where 25 | 26 | import Text.PrettyPrint.HughesPJClass 27 | import Control.Lens 28 | 29 | -- | l is an annotation at a branch (usually the layout) 30 | -- | a is the type of a leaf (usually a window) 31 | data Tree l a = 32 | Tree {_layout :: !l 33 | ,_treeElements :: !(Maybe (ListZipper (Either a (Tree l a))))} 34 | deriving (Show,Read,Eq,Ord) 35 | 36 | -- | one focused element and some elements on both sides 37 | data ListZipper a = 38 | ListZipper {_focusL :: !a 39 | ,_leftL :: ![a] 40 | ,_rightL :: ![a]} 41 | deriving (Show,Read,Eq,Ord) 42 | 43 | instance Pretty a => Pretty (ListZipper a) where 44 | pPrint (ListZipper f l r) = 45 | text "ListZipper" $$ 46 | nest 2 47 | (text "focus =" <+> 48 | pPrint f $$ 49 | text "left =" <+> 50 | pPrint l $$ 51 | text "right =" <+> 52 | pPrint r) 53 | 54 | makeLenses ''Tree 55 | makeLenses ''ListZipper 56 | 57 | -- | one focused tree and the parent elements of that tree 58 | data TreeZipper l a = 59 | TreeZipper {_focusT :: !(Tree l a) 60 | ,_parentsT :: ![([Either a (Tree l a)],l,[Either a (Tree l a)])]} 61 | deriving (Show,Read,Eq,Ord) 62 | 63 | instance (Pretty (Tree l a),Pretty a,Pretty l) => Pretty (TreeZipper l a) where 64 | pPrint (TreeZipper f p) = 65 | text "TreeZipper" $$ 66 | nest 2 67 | (text "focus =" <+> 68 | pPrint f $$ 69 | text "parents =" <+> 70 | pPrint p) 71 | 72 | instance (Pretty l,Pretty (ListZipper (Either a (Tree l a)))) => Pretty (Tree l a) where 73 | pPrint (Tree l el) = text "Tree" $$ nest 2 (text "layout =" <+> pPrint l $$ text "elements =" <+> pPrint el) 74 | 75 | makeLenses ''TreeZipper 76 | 77 | -- | insert an element in a list zipper 78 | insertUpList :: a -> Maybe (ListZipper a) -> (ListZipper a) 79 | insertUpList a Nothing = ListZipper a [] [] 80 | insertUpList a (Just (ListZipper f l r)) = ListZipper a l (f:r) 81 | 82 | -- | if a leaf is focused split it up and use the supplied annotation 83 | -- otherwise just move the current focus to the right and insert 84 | insertUp :: l -> a -> TreeZipper l a -> TreeZipper l a 85 | insertUp _ el z = 86 | z & focusT . treeElements %~ 87 | (return . 88 | insertUpList (Left el)) 89 | 90 | integrate :: ListZipper a -> [a] 91 | integrate (ListZipper x l r) = reverse l ++ x : r 92 | 93 | integrate' :: Maybe (ListZipper a) -> [a] 94 | integrate' = maybe [] integrate 95 | 96 | -- | reconstruct the complete tree from a tree zipper 97 | integrateTree :: TreeZipper l a -> Tree l a 98 | integrateTree (TreeZipper f []) = f 99 | integrateTree (TreeZipper f ((ls,l,rs):xs)) = 100 | integrateTree $ 101 | flip TreeZipper xs $ 102 | Tree l 103 | (Just (ListZipper (Right f) 104 | ls 105 | rs)) 106 | 107 | -- | create a new tree containing only the focused element 108 | split :: TreeZipper l a -> TreeZipper l a 109 | split (TreeZipper (Tree l Nothing) p) = TreeZipper (Tree l Nothing) p 110 | split (TreeZipper (Tree l (Just (ListZipper f ls rs))) ps) = 111 | TreeZipper 112 | (Tree l 113 | (Just (ListZipper (Right (Tree l (Just (ListZipper f [] [])))) 114 | ls 115 | rs))) ps 116 | 117 | -- | move down in the tree 118 | moveDown :: TreeZipper l a -> TreeZipper l a 119 | moveDown (TreeZipper (Tree l Nothing) ps) = TreeZipper (Tree l Nothing) ps 120 | moveDown (TreeZipper (Tree l (Just (ListZipper (Left f) ls rs))) ps) = TreeZipper (Tree l (Just (ListZipper (Left f) ls rs))) ps 121 | moveDown (TreeZipper (Tree l (Just (ListZipper (Right t) ls rs))) ps) = TreeZipper t ((ls,l,rs):ps) 122 | 123 | -- | move up in the tree 124 | moveUp :: TreeZipper l a -> TreeZipper l a 125 | moveUp (TreeZipper t []) = TreeZipper t [] 126 | moveUp (TreeZipper t ((ls,l,rs):ps)) = 127 | TreeZipper 128 | (Tree l 129 | (Just (ListZipper (Right t) 130 | ls 131 | rs))) 132 | ps 133 | 134 | -- | move the focused view one level up and remove possibly empty trees 135 | moveViewUp :: TreeZipper l a -> TreeZipper l a 136 | moveViewUp tz@(TreeZipper _ []) = tz 137 | moveViewUp tz@(TreeZipper (Tree _ Nothing) _) = tz 138 | moveViewUp (TreeZipper (Tree l (Just z)) ((ls,lp,rs):p)) = 139 | case removeFocused z of 140 | Just z' -> 141 | TreeZipper 142 | (Tree l (Just z')) 143 | ((z ^. focusL : ls,lp,rs) : 144 | p) 145 | Nothing -> 146 | TreeZipper 147 | (Tree lp 148 | (Just (ListZipper (z ^. focusL) 149 | ls 150 | rs))) 151 | p 152 | 153 | -- | remove the focused element 154 | removeFocused :: ListZipper a -> Maybe (ListZipper a) 155 | removeFocused (ListZipper _ [] []) = Nothing 156 | removeFocused (ListZipper _ (x:xs) rs) = Just $ ListZipper x xs rs 157 | removeFocused (ListZipper _ [] (x:xs)) = Just $ ListZipper x [] xs 158 | -------------------------------------------------------------------------------- /src/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE GADTs #-} 6 | 7 | module Types 8 | ( Tag(..) 9 | , Key(..) 10 | , ViewCreated(..) 11 | , ViewDestroyed(..) 12 | , OutputCreated(..) 13 | , OutputDestroyed(..) 14 | , OutputResolution(..) 15 | , WindowManager 16 | , Actions 17 | , Dir(..) 18 | , Action(..) 19 | ) where 20 | 21 | import Control.Monad.Fix 22 | import Data.Dependent.Map hiding (Key,split) 23 | import Data.GADT.Compare.TH 24 | import Data.Set hiding (split) 25 | import Reflex 26 | import Text.XkbCommon 27 | import WLC 28 | 29 | data Tag a where 30 | TKey :: Tag Key 31 | TViewCreated :: Tag ViewCreated 32 | TViewDestroyed :: Tag ViewDestroyed 33 | TOutputCreated :: Tag OutputCreated 34 | TOutputDestroyed :: Tag OutputDestroyed 35 | TOutputResolution :: Tag OutputResolution 36 | 37 | data Key = 38 | Key WLCKeyState 39 | Keysym 40 | (Set WLCModifier) 41 | deriving (Show,Eq) 42 | 43 | data ViewCreated = 44 | ViewCreated WLCViewPtr WLCOutputPtr 45 | deriving (Show,Eq,Ord) 46 | 47 | data ViewDestroyed = ViewDestroyed WLCViewPtr deriving (Show,Eq,Ord) 48 | 49 | data OutputCreated = OutputCreated WLCOutputPtr WLCSize deriving (Show,Eq,Ord) 50 | 51 | data OutputDestroyed = OutputDestroyed WLCOutputPtr deriving (Show,Eq,Ord) 52 | 53 | data OutputResolution = OutputResolution WLCOutputPtr WLCSize WLCSize deriving (Show,Eq,Ord) 54 | 55 | type WindowManager t m = (Reflex t,MonadHold t m,MonadFix m) => Event t (DSum Tag) -> m (Event t (IO ())) 56 | 57 | deriveGEq ''Tag 58 | deriveGCompare ''Tag 59 | 60 | data Action 61 | = InsertView WLCViewPtr 62 | WLCOutputPtr 63 | | FocusView WLCViewPtr 64 | | DestroyView WLCViewPtr 65 | | CreateOutput WLCOutputPtr WLCSize 66 | | DestroyOutput WLCOutputPtr 67 | | SpawnCommand String 68 | | Focus Dir 69 | | Swap Dir 70 | | Output Dir 71 | | Move Dir 72 | | Split 73 | | ViewWorkspace String 74 | | ChangeResolution WLCOutputPtr WLCSize 75 | | Cycle 76 | | MoveViewUp 77 | | Close 78 | 79 | type Actions = [Action] 80 | 81 | data Dir = Up | Down 82 | -------------------------------------------------------------------------------- /src/WLCHandlers.hs: -------------------------------------------------------------------------------- 1 | module WLCHandlers 2 | ( runWLC 3 | ) where 4 | 5 | import Control.Concurrent.Chan 6 | import Control.Concurrent.MVar 7 | import Control.Lens hiding (view) 8 | import Data.Default 9 | import Data.Dependent.Sum 10 | import Foreign hiding (new) 11 | import Foreign.C.Types 12 | import WLC 13 | import qualified WLC.Lenses as WLC 14 | import WLC.Lenses hiding (view,output) 15 | import WLC.Wrapper 16 | 17 | import Helpers 18 | import Types 19 | 20 | runWLC :: Chan (DSum Tag) -> MVar (IO ()) -> IO () 21 | runWLC messages action = do 22 | keyboardKeyW <- wrapKey (kKey messages action) 23 | viewCreatedW <- wrapCreated (vCreated messages action) 24 | viewFocusW <- wrapFocus vFocus 25 | viewDestroyedW <- wrapDestroyed (vDestroyed messages action) 26 | outputCreatedW <- wrapCreated (oCreated messages action) 27 | outputDestroyedW <- wrapDestroyed (oDestroyed messages action) 28 | outputResolutionW <- wrapResolution (oResolution messages action) 29 | _ <- wlcInit (def & WLC.keyboard . keyboardKey .~ keyboardKeyW 30 | & WLC.view . viewCreated .~ viewCreatedW 31 | & WLC.view . viewFocus .~ viewFocusW 32 | & WLC.view . viewDestroyed .~ viewDestroyedW 33 | & WLC.output . outputCreated .~ outputCreatedW 34 | & WLC.output . outputDestroyed .~ outputDestroyedW 35 | & WLC.output . outputResolution .~ outputResolutionW) [] 36 | wlcRun 37 | wlcTerminate 38 | freeHaskellFunPtr keyboardKeyW 39 | freeHaskellFunPtr viewCreatedW 40 | freeHaskellFunPtr viewFocusW 41 | freeHaskellFunPtr viewDestroyedW 42 | freeHaskellFunPtr outputCreatedW 43 | freeHaskellFunPtr outputDestroyedW 44 | 45 | kKey :: Chan (DSum Tag) 46 | -> MVar (IO ()) 47 | -> WLCHandle 48 | -> CUInt 49 | -> WLCModifiersPtr 50 | -> CUInt 51 | -> CUInt 52 | -> WLCKeyStateBit 53 | -> IO CBool 54 | kKey messages action _view _ modifiersPtr _ symBit keyStateBit = 55 | do mods <- getModifiers <$> modifiers 56 | writeChan messages 57 | (TKey :=> 58 | Key (getKeyState keyStateBit) sym mods) 59 | act <- takeMVar action 60 | act 61 | return 1 62 | where sym = getSym symBit 63 | modifiers = peek modifiersPtr 64 | 65 | vCreated :: Chan (DSum Tag) -> MVar (IO ()) -> WLCHandle -> IO CBool 66 | vCreated messages action view = 67 | do output <- wlcViewGetOutput (WLCViewPtr view) 68 | writeChan messages 69 | (TViewCreated :=> 70 | ViewCreated (WLCViewPtr view) (WLCOutputPtr output)) 71 | act <- takeMVar action 72 | act 73 | return 1 74 | 75 | vFocus :: WLCHandle -> CBool -> IO () 76 | vFocus view focus = 77 | do wlcViewSetState (WLCViewPtr view) 78 | WlcBitActivated 79 | (focus /= 0) 80 | 81 | vDestroyed :: Chan (DSum Tag) -> MVar (IO ()) -> WLCHandle -> IO () 82 | vDestroyed messages action view = 83 | do writeChan messages (TViewDestroyed :=> ViewDestroyed (WLCViewPtr view)) 84 | act <- takeMVar action 85 | act 86 | 87 | oCreated :: Chan (DSum Tag) -> MVar (IO ()) -> WLCHandle -> IO CBool 88 | oCreated messages action output = 89 | do res <- wlcOutputGetResolution (WLCOutputPtr output) 90 | writeChan messages 91 | (TOutputCreated :=> 92 | OutputCreated (WLCOutputPtr output) res) 93 | act <- takeMVar action 94 | act 95 | return 1 96 | 97 | oDestroyed :: Chan (DSum Tag) -> MVar (IO ()) -> WLCHandle -> IO () 98 | oDestroyed messages action output = 99 | do writeChan messages 100 | (TOutputDestroyed :=> 101 | OutputDestroyed (WLCOutputPtr output)) 102 | act <- takeMVar action 103 | act 104 | 105 | oResolution :: Chan (DSum Tag) -> MVar (IO ()) -> WLCHandle -> WLCSizePtr -> WLCSizePtr -> IO () 106 | oResolution messages action output old new = 107 | do old' <- peek old 108 | new' <- peek new 109 | writeChan messages (TOutputResolution :=> OutputResolution (WLCOutputPtr output) old' new') 110 | act <- takeMVar action 111 | act 112 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | packages: 2 | - . 3 | - location: 4 | git: https://github.com/cocreature/wlc-hs 5 | commit: db3186765daa3cb087c13da9160a6e95965cec23 6 | - location: 7 | git: https://github.com/ryantrinkle/reflex 8 | commit: 87605ca92b9a03727f065240cda60f0b6f372b4f 9 | extra-deps: 10 | - dependent-map-0.1.1.3 11 | - dependent-sum-0.2.1.0 12 | - dependent-sum-template-0.0.0.3 13 | - ref-tf-0.4 14 | - these-0.4.1 15 | - xkbcommon-0.0.1 16 | - data-flags-0.0.3.1 17 | - storable-record-0.0.3 18 | - utility-ht-0.0.10 19 | - emacs-keys-0.0.2.0 20 | resolver: nightly-2015-06-28 21 | --------------------------------------------------------------------------------