boom

14 files changed, 1175 insertions, 6 deletions

diff --git a/src/Data/List/Extra.hs b/src/Data/List/Extra.hs
new file mode 100644
index 0000000..d18bc76
--- /dev/null
+++ b/src/Data/List/Extra.hs
@@ -0,0 +1,8 @@
+module Data.List.Extra where
+
+import Data.Maybe (listToMaybe)
+
+
+(!!?) :: [a] -> Int -> Maybe a
+x !!? i | i >= 0 = listToMaybe (drop i x)
+_ !!? _ = Nothing
diff --git a/src/Data/Monoid/Extra.hs b/src/Data/Monoid/Extra.hs
new file mode 100644
index 0000000..e484cf0
--- /dev/null
+++ b/src/Data/Monoid/Extra.hs
@@ -0,0 +1,6 @@
+module Data.Monoid.Extra where
+
+
+mintercalate :: Monoid b => b -> [b] -> b
+mintercalate c (h:t) = foldl (\acc x -> acc <> c <> x) h t
+mintercalate _ [] = mempty
diff --git a/src/Data/Text/Encoding/Extra.hs b/src/Data/Text/Encoding/Extra.hs
new file mode 100644
index 0000000..a8e6234
--- /dev/null
+++ b/src/Data/Text/Encoding/Extra.hs
@@ -0,0 +1,11 @@
+module Data.Text.Encoding.Extra where
+
+import Data.ByteString (ByteString)
+import Data.Text (Text)
+import qualified Data.Text.Encoding as Text
+import qualified Data.Text.Encoding.Error as Text
+
+
+decodeUtf8Lenient :: ByteString -> Text
+decodeUtf8Lenient =
+  Text.decodeUtf8With Text.lenientDecode
diff --git a/src/Data/Text/Extra.hs b/src/Data/Text/Extra.hs
new file mode 100644
index 0000000..07dd45c
--- /dev/null
+++ b/src/Data/Text/Extra.hs
@@ -0,0 +1,8 @@
+module Data.Text.Extra where
+
+import Data.Text (Text)
+import qualified Data.Text as Text
+
+
+show :: Show a => a -> Text
+show = Text.pack . Prelude.show
diff --git a/src/Foreign/C/String/Extra.hs b/src/Foreign/C/String/Extra.hs
new file mode 100644
index 0000000..a7b6dfe
--- /dev/null
+++ b/src/Foreign/C/String/Extra.hs
@@ -0,0 +1,10 @@
+module Foreign.C.String.Extra where
+
+import Data.Word (Word8)
+import Foreign.C.String (castCCharToChar)
+import Foreign.C.Types (CChar)
+import qualified Data.Char as Char
+
+
+castCCharToWord8 :: CChar -> Word8
+castCCharToWord8 = fromIntegral . Char.ord . castCCharToChar
diff --git a/src/Graphics/X11/Extra.hs b/src/Graphics/X11/Extra.hs
new file mode 100644
index 0000000..bed1ba3
--- /dev/null
+++ b/src/Graphics/X11/Extra.hs
@@ -0,0 +1,24 @@
+module Graphics.X11.Extra where
+
+import Control.Exception (bracket)
+import System.Environment (getEnv)
+import System.IO.Unsafe (unsafePerformIO)
+import qualified Graphics.X11 as X11
+
+
+unsafeInternAtom :: String -> Bool -> X11.Atom
+unsafeInternAtom atomName onlyIfExists =
+  unsafePerformIO $ withDefaultDisplay $ \display ->
+    X11.internAtom display atomName onlyIfExists
+
+defaultDisplayName :: String
+defaultDisplayName =
+  unsafePerformIO (getEnv "DISPLAY")
+
+withDisplay :: String -> (X11.Display -> IO a) -> IO a
+withDisplay display =
+  bracket (X11.openDisplay display) X11.closeDisplay
+
+withDefaultDisplay :: (X11.Display -> IO a) -> IO a
+withDefaultDisplay =
+  withDisplay defaultDisplayName
diff --git a/src/Graphics/X11/Xlib/Extras/Extra.hs b/src/Graphics/X11/Xlib/Extras/Extra.hs
new file mode 100644
index 0000000..d88bf9d
--- /dev/null
+++ b/src/Graphics/X11/Xlib/Extras/Extra.hs
@@ -0,0 +1,14 @@
+module Graphics.X11.Xlib.Extras.Extra where
+
+import Data.Text (Text)
+import Foreign.C.String.Extra (castCCharToWord8)
+import qualified Data.ByteString as ByteString
+import qualified Data.Text.Encoding.Extra as Text
+import qualified Graphics.X11 as X11
+import qualified Graphics.X11.Xlib.Extras as X11
+
+
+getWindowPropertyText :: X11.Display -> X11.Atom -> X11.Window -> IO (Maybe Text)
+getWindowPropertyText d a w =
+  fmap (Text.decodeUtf8Lenient . ByteString.pack . map castCCharToWord8) <$>
+    X11.getWindowProperty8 d a w
diff --git a/src/Hack/Buffer/Extra.hs b/src/Hack/Buffer/Extra.hs
new file mode 100644
index 0000000..999703c
--- /dev/null
+++ b/src/Hack/Buffer/Extra.hs
@@ -0,0 +1,10 @@
+module Hack.Buffer.Extra where
+
+import Hack.Buffer (Buffer)
+
+
+length :: Buffer -> Int
+length (ls, rs) = Prelude.length ls + Prelude.length rs
+
+insertChar :: Char -> Buffer -> Buffer
+insertChar c (ls, rs) = (ls <> [c], rs)
diff --git a/src/Much/Screen.hs b/src/Much/Screen.hs
new file mode 100644
index 0000000..b93847f
--- /dev/null
+++ b/src/Much/Screen.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE RecordWildCards #-}
+module Much.Screen (Screen(..), setScreen, withScreen) where
+
+import Control.Exception
+import Data.List
+import System.IO
+
+
+data Screen = Screen
+    { inputEcho :: Bool
+    , inputBufferMode :: BufferMode
+    , outputBufferMode :: BufferMode
+    , decsetPm :: [Int]
+    , decrstPm :: [Int]
+    }
+
+setScreen :: Handle -> Handle -> Screen -> IO Screen
+setScreen i o Screen{..} = get <* set where
+  get = Screen <$> hGetEcho i
+               <*> hGetBuffering i
+               <*> hGetBuffering o
+               <*> pure decrstPm
+               <*> pure decsetPm
+  set = do
+      hSetEcho i inputEcho
+      hSetBuffering i inputBufferMode
+      hSetBuffering o outputBufferMode
+      hPutStr o $ "\ESC[?" ++ intercalate ";" (map show decsetPm) ++ "h"
+      hPutStr o $ "\ESC[?" ++ intercalate ";" (map show decrstPm) ++ "l"
+      hFlush o
+
+withScreen :: Handle -> Handle -> Screen -> (Screen -> IO a) -> IO a
+withScreen i o s = bracket (setScreen i o s) (setScreen i o)
diff --git a/src/Pager/Sixelerator.hs b/src/Pager/Sixelerator.hs
new file mode 100644
index 0000000..c518484
--- /dev/null
+++ b/src/Pager/Sixelerator.hs
@@ -0,0 +1,105 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+module Pager.Sixelerator where
+
+import Data.ByteString (ByteString)
+import Data.Maybe (catMaybes)
+import Pager.Types
+import Sixel (PaletteColor)
+import State (State(..))
+import qualified Sixel
+
+
+data WindowFeature
+    = WindowBackground
+    | WindowBorder
+    | FocusBackground
+    | FocusBorder
+    | UrgentBackground
+    | UrgentBorder
+
+
+renderWorkspacePreview :: Geometry -> State -> Workspace -> ByteString
+renderWorkspacePreview previewGeometry State{screenHeight,screenWidth} Workspace{..} =
+    Sixel.render previewGeometry rgbColors canvas
+  where
+    workspaceHeight = fromIntegral $ geometry_height previewGeometry :: Int
+    workspaceWidth = fromIntegral $ geometry_width previewGeometry :: Int
+
+    scaleX = fromIntegral workspaceWidth / fromIntegral screenWidth :: Double
+    scaleY = fromIntegral workspaceHeight / fromIntegral screenHeight :: Double
+
+    -- XXX color indexes must start at 0 and be continuous (to compute sixeldata)
+    workspaceBackgroundColor = 0
+    windowBackgroundColor = 1
+    windowBorderColor = 2
+    focusBackgroundColor = 3
+    focusBorderColor = 4
+    urgentBackgroundColor = 5
+    urgentBorderColor = 6
+
+    rgbColors =
+      [ (0,0,0)       -- workspace background
+      , (29,113,29)   -- window background color
+      , (0,255,0)     -- window border color
+      , (113,29,113)  -- focus background color
+      , (255,0,255)   -- focus border color
+      , (113,29,29)   -- urgent background color
+      , (255,0,0)     -- urgent border color
+      ]
+
+    canvas = rasterize f (fromIntegral workspaceWidth) (fromIntegral workspaceHeight)
+              <> blankLine
+      where
+        f x y = case catMaybes (map (getWindowFeatureAt x y) workspace_windows) of
+                  UrgentBackground:_ -> urgentBackgroundColor
+                  UrgentBorder:_ -> urgentBorderColor
+                  FocusBackground:_ -> focusBackgroundColor
+                  FocusBorder:_ -> focusBorderColor
+                  WindowBackground:_ -> windowBackgroundColor
+                  WindowBorder:_ -> windowBorderColor
+                  _ -> workspaceBackgroundColor
+
+        -- XXX blank line is used in conjunction with ex_offsetY to "clean up" when moving up
+        -- remove this together with ex_offsetY.
+        blankLine = replicate workspaceWidth 0
+
+    getWindowFeatureAt x y Window{..} =
+        if isBorder then
+          if window_urgent then
+            Just UrgentBorder
+          else if window_focused then
+            Just FocusBorder
+          else
+            Just WindowBorder
+        else if isBackground then
+          if window_urgent then
+            Just UrgentBackground
+          else if window_focused then
+            Just FocusBackground
+          else
+            Just WindowBackground
+        else
+          Nothing
+      where
+        w_x = round (scaleX * fromIntegral (geometry_x window_geometry))
+        w_y = round (scaleY * fromIntegral (geometry_y window_geometry))
+        w_width = round (scaleX * fromIntegral (geometry_width window_geometry))
+        w_height = round (scaleY * fromIntegral (geometry_height window_geometry))
+        isBackground =
+          (w_x <= x && x < w_x + w_width) &&
+          (w_y <= y && y < w_y + w_height)
+        isBorder =
+          (w_x <= x && x < w_x + w_width) &&
+          (w_y <= y && y < w_y + w_height) &&
+          (x == w_x || x == w_x + w_width - 1 || y == w_y || y == w_y + w_height - 1)
+
+
+rasterize :: (Int -> Int -> PaletteColor) -> Int -> Int -> [PaletteColor]
+rasterize f width height =
+    map f' ([0..width * height - 1] :: [Int])
+  where
+    f' index = f x y
+      where
+        x = fromIntegral $ index `mod` width
+        y = floor $ fromIntegral index / (fromIntegral width :: Double)
diff --git a/src/Pager/Types.hs b/src/Pager/Types.hs
index 95dd837..a2ea5aa 100644
--- a/src/Pager/Types.hs
+++ b/src/Pager/Types.hs
@@ -1,10 +1,24 @@
 {-# LANGUAGE TemplateHaskell #-}
 module Pager.Types where
 
-import Data.Aeson.TH (Options(fieldLabelModifier), deriveJSON, defaultOptions)
 import Data.Text (Text)
+import Scanner (Scan)
 
 
+data Action
+  = None
+  | FocusWorkspace Text
+
+data Command =
+  ViewWorkspace |
+  ShiftWindowToWorkspace Int |
+  ShiftWindowToAndViewWorkspace Int
+
+data Event =
+    EResize Int Int |
+    EScan Scan |
+    EShutdown
+
 data Geometry = Geometry
   { geometry_x :: Int
   , geometry_y :: Int
@@ -24,9 +38,5 @@ data Workspace = Workspace
   { workspace_geometry :: Geometry
   , workspace_focused :: Bool
   , workspace_name :: Text
-  , workspace_windows :: [Window]
+  , workspace_windows :: [Window] -- sorted by z-order, earlier windows overlap later ones
   }
-
-$(deriveJSON defaultOptions { fieldLabelModifier = tail . dropWhile (/='_') } ''Geometry)
-$(deriveJSON defaultOptions { fieldLabelModifier = tail . dropWhile (/='_') } ''Window)
-$(deriveJSON defaultOptions { fieldLabelModifier = tail . dropWhile (/='_') } ''Workspace)
diff --git a/src/Sixel.hs b/src/Sixel.hs
new file mode 100644
index 0000000..dc49d91
--- /dev/null
+++ b/src/Sixel.hs
@@ -0,0 +1,166 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Sixel
+    ( PaletteColor
+    , RGBColor
+    , render
+    ) where
+
+import Data.Bits (shiftL)
+import Data.Bool (bool)
+import Data.ByteString (ByteString)
+import Data.Word (Word8)
+import Pager.Types (Geometry(..))
+import qualified Data.ByteString as ByteString
+import qualified Data.ByteString.Char8 as ByteString.Char8
+import qualified Data.Char as Char
+import qualified Data.List as List
+import qualified Data.List.Split as List (chunksOf)
+import qualified Foreign.C.Types
+import qualified Numeric.Probability.Trace as List (zipListWith)
+import qualified Test.Speculate.Utils as Tuple (uncurry6)
+
+
+showByteString :: Show a => a -> ByteString
+showByteString =
+    ByteString.Char8.pack . show
+
+
+type Bit = Foreign.C.Types.CBool
+
+type Sixel = (Bit, Bit, Bit, Bit, Bit, Bit)
+
+type PaletteColor = Word8
+
+type RGBColor = (Word8, Word8, Word8)
+
+
+render :: Geometry -> [RGBColor] -> [PaletteColor] -> ByteString
+render (Geometry x y width _) rgbColors canvas =
+    "\ESCP0;0;q" <> colors <> sixeldata <> "\ESC\\"
+  where
+    bandsToSkip = floor (fromIntegral y / (6 :: Double))
+
+    paddedCanvas =
+      if y < 0 then
+        drop (-(fromIntegral y) * fromIntegral width) canvas
+      else
+        let
+          paddingTop = replicate (fromIntegral offsetY * fromIntegral width) 0
+          offsetY = y - bandsToSkip * 6
+        in
+        paddingTop <> canvas
+
+    palette = map fromIntegral [0..length rgbColors - 1]
+    colors = mconcat $ map (uncurry setColorMapRegister) (zip palette rgbColors)
+    channels = splitChannels palette paddedCanvas
+    bitmaps = map (toScanlines width) channels
+    images = map (map (runLengthEncode . toByteString) . toSixels) bitmaps
+    sixeldata = skipBands (fromIntegral bandsToSkip) <> overstrikeBands (map (map (shiftX x)) images)
+
+
+skipBands :: Int -> ByteString
+skipBands n =
+    ByteString.replicate n newline
+  where
+    newline = fromIntegral (Char.ord '-')
+
+
+shiftX :: Int -> ByteString -> ByteString
+shiftX x s =
+    "!" <> showByteString x <> "?" <> s
+
+
+setColorMapRegister :: PaletteColor -> RGBColor -> ByteString
+setColorMapRegister i _rgbColor256@(r256,g256,b256) =
+    "#" <> mconcat (List.intersperse ";" (map showByteString [i, 2, r100, g100, b100]))
+  where
+    (r100,g100,b100) = (to100 r256, to100 g256, to100 b256)
+    to100 = round . (*(100/256 :: Double)) . fromIntegral
+
+
+useColorMapRegister :: PaletteColor -> ByteString -> ByteString
+useColorMapRegister color s =
+    "#" <> showByteString color <> s
+
+
+splitChannels :: [PaletteColor] -> [PaletteColor] -> [[Bit]]
+splitChannels channels canvas =
+    map (flip getChannel canvas) channels
+  where
+    getChannel :: PaletteColor -> [PaletteColor] -> [Bit]
+    getChannel color = map (bool 0 1 . (==color))
+
+
+toScanlines :: Int -> [Bit] -> [[Bit]]
+toScanlines width =
+    List.chunksOf (fromIntegral width)
+
+
+-- Turn scanlines into sixelbands.
+-- Empty lines will be added as necessary to construct the final band.
+toSixels :: [[Bit]] -> [[Sixel]]
+toSixels =
+    map (Tuple.uncurry6 List.zip6) . rec
+  where
+    rec :: [[Bit]] -> [([Bit],[Bit],[Bit],[Bit],[Bit],[Bit])]
+    rec (a:b:c:d:e:f:rest) = (a,b,c,d,e,f) : rec rest
+    rec (a:b:c:d:e:[])     = (a,b,c,d,e,z) : []
+    rec (a:b:c:d:[])       = (a,b,c,d,z,z) : []
+    rec (a:b:c:[])         = (a,b,c,z,z,z) : []
+    rec (a:b:[])           = (a,b,z,z,z,z) : []
+    rec (a:[])             = (a,z,z,z,z,z) : []
+    rec ([])               = []
+    z = repeat 0
+
+
+toByteString :: [Sixel] -> ByteString
+toByteString =
+    ByteString.pack . map ((+63) . toWord8)
+
+
+toWord8 :: Sixel -> Word8
+toWord8 (a, b, c, d, e, f) =
+  shiftL (fromIntegral a) 0 +
+  shiftL (fromIntegral b) 1 +
+  shiftL (fromIntegral c) 2 +
+  shiftL (fromIntegral d) 3 +
+  shiftL (fromIntegral e) 4 +
+  shiftL (fromIntegral f) 5
+
+
+runLengthEncode :: ByteString -> ByteString
+runLengthEncode input =
+    case ByteString.uncons input of
+      Just (c, input') ->
+        let
+          (c_last, n_last, out) = ByteString.foldl f (c, 1, "") input'
+        in
+        encode c_last n_last out
+
+      Nothing ->
+        input
+  where
+    f :: (Word8, Int, ByteString) -> Word8 -> (Word8, Int, ByteString)
+    f (c, n, out) c_in =
+      if c_in == c then
+        (c, n + 1, out)
+      else
+        (c_in, 1, encode c n out)
+
+    encode :: Word8 -> Int -> ByteString -> ByteString
+    encode c n output =
+        if n > 3 then
+          output <> "!" <> showByteString n <> ByteString.singleton c
+        else
+          output <> ByteString.replicate n c
+
+
+overstrikeBands :: [[ByteString]] -> ByteString
+overstrikeBands =
+    mconcat . List.intersperse "-" . List.zipListWith overstrikeBand
+
+
+overstrikeBand :: [ByteString] -> ByteString
+overstrikeBand =
+    mconcat . List.intersperse "$" . map (uncurry useColorMapRegister) . zip [0..]
diff --git a/src/State.hs b/src/State.hs
new file mode 100644
index 0000000..2cb1575
--- /dev/null
+++ b/src/State.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE OverloadedStrings #-}
+module State where
+
+import Blessings.Text (Blessings)
+import Data.Default (Default,def)
+import Data.Map (Map)
+import Data.Text (Text)
+import Hack.Buffer (Buffer)
+import Pager.Types
+import qualified Data.Map as Map
+import qualified Hack.Buffer as Buffer
+
+
+data State = State
+    { buffer :: Buffer
+    , command :: Command
+    , count :: Int
+    , flashMessage :: Blessings Text
+    , termWidth :: Int
+    , termHeight :: Int
+    , charHeight :: Int
+    , charWidth :: Int
+    , screenWidth :: Int
+    , screenHeight :: Int
+    , termHeightPixels :: Int
+    , termWidthPixels :: Int
+    , termBorder :: Int
+    , workspaceViewportHeight :: Int
+    , workspaceViewportOffset :: Int
+    , foundWorkspaces :: [Text]
+    , workspaces :: Map Text Workspace
+    , workspaceCursor :: Int
+    , ex_offsetY :: Int
+    }
+
+
+instance Default State where
+  def = State
+      { buffer = Buffer.emptyBuffer
+      , command = ViewWorkspace
+      , count = 1
+      , flashMessage = "Welcome to pager; quit with ^C"
+      , termWidth = 0
+      , termHeight = 0
+      , screenHeight = 0
+      , screenWidth = 0
+      , charWidth = 0
+      , charHeight = 0
+      , termWidthPixels = 0
+      , termHeightPixels = 0
+      , termBorder = 0
+      , workspaceViewportHeight = 0
+      , workspaceViewportOffset = 0
+      , foundWorkspaces = []
+      , workspaces = Map.empty
+      , workspaceCursor = 0
+      , ex_offsetY = 0
+      }
diff --git a/src/main.hs b/src/main.hs
new file mode 100644
index 0000000..816aa7c
--- /dev/null
+++ b/src/main.hs
@@ -0,0 +1,706 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
+module Main (main) where
+
+import Blessings.Text (Blessings(Plain,SGR),pp)
+import Control.Applicative ((<|>))
+import Control.Concurrent
+import Control.Monad (forM)
+import Control.Monad (forever)
+import Data.Bits ((.|.),testBit)
+import Data.Default (def)
+import Data.Function ((&))
+import Data.List.Extra ((!!?))
+import Data.Maybe (catMaybes,fromMaybe)
+import Data.Monoid.Extra (mintercalate)
+import Data.Set (Set)
+import Data.Text (Text)
+import Foreign.C.Types (CLong)
+import Much.Screen (Screen(Screen), withScreen)
+import Pager.Types
+import Scanner
+import State (State(..))
+import System.Environment (getArgs)
+import System.IO
+import System.Posix.Signals (Handler(Catch), Signal, installHandler, sigINT)
+import qualified Blessings.Internal as Blessings
+import qualified Data.Char as Char
+import qualified Data.List as List
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import qualified Data.Text.Extra as Text
+import qualified Data.Text.IO as Text
+import qualified Data.Text.Read as Text
+import qualified Graphics.X11 as X11
+import qualified Graphics.X11.Extra as X11
+import qualified Graphics.X11.Xlib.Extras as X11
+import qualified Graphics.X11.Xlib.Extras.Extra as X11
+import qualified Hack.Buffer as Buffer
+import qualified Hack.Buffer.Extra as Buffer
+import qualified Pager.Sixelerator as Pager
+import qualified System.Console.Terminal.Size as Term
+
+
+atom_NET_ACTIVE_WINDOW :: X11.Atom
+atom_NET_ACTIVE_WINDOW = X11.unsafeInternAtom "_NET_ACTIVE_WINDOW" True
+
+atom_NET_CLIENT_LIST :: X11.Atom
+atom_NET_CLIENT_LIST = X11.unsafeInternAtom "_NET_CLIENT_LIST" True
+
+atom_NET_CURRENT_DESKTOP :: X11.Atom
+atom_NET_CURRENT_DESKTOP = X11.unsafeInternAtom "_NET_CURRENT_DESKTOP" True
+
+atom_NET_DESKTOP_NAMES :: X11.Atom
+atom_NET_DESKTOP_NAMES = X11.unsafeInternAtom "_NET_DESKTOP_NAMES" True
+
+atom_NET_WM_DESKTOP :: X11.Atom
+atom_NET_WM_DESKTOP = X11.unsafeInternAtom "_NET_WM_DESKTOP" True
+
+atom_NET_WM_NAME :: X11.Atom
+atom_NET_WM_NAME = X11.unsafeInternAtom "_NET_WM_NAME" True
+
+atom_WIN_WORKSPACE :: X11.Atom
+atom_WIN_WORKSPACE = X11.unsafeInternAtom "_WIN_WORKSPACE" True
+
+atom_WIN_WORKSPACE_NAMES :: X11.Atom
+atom_WIN_WORKSPACE_NAMES = X11.unsafeInternAtom "_WIN_WORKSPACE_NAMES" True
+
+atom_WM_NAME :: X11.Atom
+atom_WM_NAME = X11.unsafeInternAtom "WM_NAME" True
+
+
+getActiveWindow :: X11.Display -> IO (Maybe X11.Window)
+getActiveWindow d =
+  (fmap (fromIntegral . head) <$>) $
+      X11.getWindowProperty32 d atom_NET_ACTIVE_WINDOW w
+  where w = X11.defaultRootWindow d
+
+getCurrentDesktop :: X11.Display -> IO (Maybe CLong)
+getCurrentDesktop d =
+  (fmap head <$>) $
+      X11.getWindowProperty32 d atom_NET_CURRENT_DESKTOP w <|>
+      X11.getWindowProperty32 d atom_WIN_WORKSPACE w
+  where w = X11.defaultRootWindow d
+
+getDesktopNames :: X11.Display -> IO (Maybe [Text])
+getDesktopNames d = do
+  (fmap (init . Text.split (=='\NUL')) <$>) $
+      X11.getWindowPropertyText d atom_NET_DESKTOP_NAMES w <|>
+      X11.getWindowPropertyText d atom_WIN_WORKSPACE_NAMES w
+  where w = X11.defaultRootWindow d
+
+getGeometry :: X11.Display -> X11.Window -> IO Geometry
+getGeometry d w = do
+  (_, x, y, width, height, _, _) <- X11.getGeometry d w
+  return Geometry
+    { geometry_x = fromIntegral x
+    , geometry_y = fromIntegral y
+    , geometry_width = fromIntegral width
+    , geometry_height = fromIntegral height
+    }
+
+getWindowDesktop :: X11.Display -> X11.Window -> IO (Maybe CLong)
+getWindowDesktop d w =
+  (fmap head <$>) $
+    X11.getWindowProperty32 d atom_NET_WM_DESKTOP w <|>
+    X11.getWindowProperty32 d atom_WIN_WORKSPACE w
+
+getWindowTitle :: X11.Display -> X11.Window -> IO (Maybe Text)
+getWindowTitle d w =
+    X11.getWindowPropertyText d atom_NET_WM_NAME w <|>
+    X11.getWindowPropertyText d atom_WM_NAME w
+
+getWorkspaces :: X11.Display -> Geometry -> Set X11.Window -> IO [Workspace]
+getWorkspaces display screenGeometry focusWindows = do
+    let rootWindow = X11.defaultRootWindow display
+
+    currentDesktop <- fromMaybe 0 <$> getCurrentDesktop display
+
+    workspaces <- do
+      names <- zip [0..] . fromMaybe [] <$> getDesktopNames display
+      ws <-
+        forM names $ \(index, name) -> do
+          return Workspace
+              { workspace_geometry = screenGeometry
+              , workspace_focused = currentDesktop == index
+              , workspace_name = name
+              , workspace_windows = []
+              }
+      return $ Map.fromList $ zip [0..] ws
+
+    clientList <-
+      maybe [] (map fromIntegral) <$>
+        X11.getWindowProperty32 display atom_NET_CLIENT_LIST rootWindow
+
+    let
+        f w = do
+            title <- getWindowTitle display w
+            desktop <- fromMaybe 0 <$> getWindowDesktop display w
+            geometry <- getGeometry display w
+
+            wm_hints <- X11.getWMHints display w
+            let urgent = testBit (X11.wmh_flags wm_hints) X11.urgencyHintBit
+
+            let
+              window =
+                Window
+                  { window_id = fromIntegral w
+                  , window_title = fromMaybe "" title
+                  , window_geometry = geometry
+                  , window_focused = Set.member w focusWindows
+                  , window_urgent = urgent
+                  }
+
+            return ( window, desktop )
+
+    clientList' <- mapM f clientList
+
+    return
+      $ map (\ws -> ws { workspace_windows =
+                            uncurry (<>) $
+                            List.partition window_focused (workspace_windows ws)
+                      })
+      $ Map.elems
+      $ foldr
+        (\(w, i) ->
+          Map.adjust (\ws -> ws { workspace_windows = w : workspace_windows ws })
+            i
+        )
+        workspaces
+        clientList'
+
+
+main :: IO ()
+main = do
+    args <- getArgs
+    let
+      ( commandFromArgs, focusWindows ) =
+        let readInt s =
+              case Text.decimal (Text.pack s) of
+                Right (i, "") ->
+                  i
+                _ ->
+                  (-1)
+        in
+        case args of
+          "shift" : focusWindows_ ->
+            ( ShiftWindowToWorkspace undefined, map readInt focusWindows_ )
+
+          "shiftview" : focusWindows_ ->
+            ( ShiftWindowToAndViewWorkspace undefined, map readInt focusWindows_ )
+
+          "view" : focusWindows_ ->
+            ( ViewWorkspace, map readInt focusWindows_ )
+
+          _ ->
+            error $ "bad arguments: " <> show args
+
+
+    Just activeWindow <- X11.withDefaultDisplay getActiveWindow
+
+    screenGeometry <-
+      X11.withDefaultDisplay $ \display -> do
+        let rootWindow = X11.defaultRootWindow display
+        getGeometry display rootWindow
+
+    workspaces <-
+      X11.withDefaultDisplay $ \display -> do
+        getWorkspaces display screenGeometry (Set.fromList focusWindows)
+
+    let screen0 = Screen False NoBuffering (BlockBuffering $ Just 4096)
+                [ 1000 -- X & Y on button press and release
+                , 1005 -- UTF-8 mouse mode
+                , 1047 -- use alternate screen buffer
+                ,   80 -- enable sixel scrolling 
+                ]
+                [   25 -- hide cursor
+                ]
+    result <- do
+      withFile "/dev/tty" ReadWriteMode $ \i ->
+        withFile "/dev/tty" WriteMode $ \o ->
+          withScreen i o screen0 $ \_ -> do
+            (putEvent, getEvent) <- do
+                v <- newEmptyMVar
+                return (putMVar v, takeMVar v)
+
+            let q1 =
+                  updateFoundWorkspaces $ def
+                    { command = commandFromArgs
+                    , screenHeight = geometry_height screenGeometry
+                    , screenWidth = geometry_width screenGeometry
+                    , termBorder = 2
+                    , workspaces =
+                        let
+                          f workspace@Workspace{workspace_name} = ( workspace_name, workspace )
+                        in
+                        Map.fromList (map f workspaces)
+                    }
+                signalHandlers =
+                    [ (sigINT, putEvent EShutdown)
+                    , (28, winchHandler i putEvent)
+                    ]
+
+            installHandlers signalHandlers
+
+            threadIds <- mapM forkIO
+                [
+                  forever $
+                    scan i >>= putEvent . EScan
+                ]
+
+            winchHandler i putEvent
+
+            result <- run o getEvent q1
+
+            mapM_ killThread threadIds
+
+            return result
+
+
+    case snd result of
+      FocusWorkspace name -> do
+          case command (fst result) of
+            ViewWorkspace -> do
+              X11.withDefaultDisplay $ \d -> do
+                let Just s = name `List.elemIndex` map workspace_name workspaces
+                switchDesktop d (fromIntegral s)
+
+            ShiftWindowToWorkspace _ -> do
+              X11.withDefaultDisplay $ \d ->
+                let
+                  Just s = name `List.elemIndex` map workspace_name workspaces
+                in
+                windowToDesktop d activeWindow (fromIntegral s)
+
+            ShiftWindowToAndViewWorkspace _ -> do
+              X11.withDefaultDisplay $ \d -> do
+                let Just s = name `List.elemIndex` map workspace_name workspaces
+                windowToDesktop d activeWindow (fromIntegral s)
+                switchDesktop d (fromIntegral s)
+
+      _ ->
+        return ()
+
+
+switchDesktop :: X11.Display -> CLong -> IO ()
+switchDesktop d s =
+  X11.allocaXEvent $ \e -> do
+    X11.setEventType e X11.clientMessage
+    X11.setClientMessageEvent' e w atom_NET_CURRENT_DESKTOP 32 [fromIntegral s,0,0,0,0]
+    X11.sendEvent d w False mask e
+  where
+    w = X11.defaultRootWindow d
+    mask = X11.structureNotifyMask
+
+
+windowToDesktop :: X11.Display -> X11.Window -> CLong -> IO ()
+windowToDesktop d w s =
+  X11.allocaXEvent $ \e -> do
+    X11.setEventType e X11.clientMessage
+    X11.setClientMessageEvent' e (fromIntegral w) atom_NET_WM_DESKTOP 32 [fromIntegral s,0,0,0,0]
+    X11.sendEvent d (fromIntegral w) True mask e
+  where
+    mask = X11.substructureRedirectMask .|. X11.substructureNotifyMask
+
+
+run :: Handle -> IO Event -> State -> IO (State, Action)
+run o getEvent = rec . Right where
+    rec = \case
+        Right q ->
+            redraw o q >> getEvent >>= processEvent q >>= rec
+        Left q ->
+            return q
+
+
+installHandlers :: [(Signal, IO ())] -> IO ()
+installHandlers =
+    mapM_ (\(s, h) -> installHandler s (Catch h) Nothing)
+
+
+processEvent :: State -> Event -> IO (Either (State, Action) State)
+processEvent q = \case
+    EScan (ScanKey s) -> do
+        let
+            key = Text.pack s
+            (q', action) = keymap key q
+
+            realizeAction = \case
+              None ->
+                return $ Right q'
+
+              FocusWorkspace name -> do
+                return $ Left (q', FocusWorkspace name)
+
+        realizeAction action
+
+    EScan mouseInfo@ScanMouse{} ->
+        Right <$> mousemap mouseInfo q
+    EShutdown ->
+        return $ Left (q,None)
+    EResize w h ->
+        return $ Right q
+            { termWidth = w, termHeight = h
+            , flashMessage = Plain $ "resize " <> Text.show (w,h)
+
+            , workspaceViewportHeight = newWorkspaceViewportHeight
+            , workspaceViewportOffset = newWorkspaceViewportOffset
+            }
+      where
+        newWorkspaceViewportHeight = h - 2 {- input line + status line -}
+
+        newWorkspaceViewportOffset =
+          if newWorkspaceViewportHeight > workspaceViewportHeight q then
+            max 0 $ workspaceViewportOffset q + (workspaceViewportHeight q - newWorkspaceViewportHeight)
+
+          else if newWorkspaceViewportHeight <= workspaceCursor q - workspaceViewportOffset q then
+            workspaceViewportOffset q + (workspaceViewportHeight q - newWorkspaceViewportHeight)
+
+          else
+            workspaceViewportOffset q
+
+
+moveWorkspaceCursor :: Int -> State -> State
+moveWorkspaceCursor i q@State{..} =
+    q
+      { workspaceCursor = newWorkspaceCursor
+      , workspaceViewportOffset = newWorkspaceViewportOffset
+      }
+  where
+    newWorkspaceCursor = max 0 $ min (workspaceCursor + i) $ length foundWorkspaces - 1
+
+    newWorkspaceViewportOffset =
+      if newWorkspaceCursor < workspaceViewportOffset then
+        newWorkspaceCursor
+
+      else if newWorkspaceCursor >= workspaceViewportOffset + workspaceViewportHeight then
+        newWorkspaceCursor - workspaceViewportHeight + 1
+
+      else
+        workspaceViewportOffset
+
+
+setCount :: Int -> State -> State
+setCount i q = q { count = i }
+
+keymap :: Text -> State -> ( State, Action )
+
+keymap s
+      | [ "\ESC[4"
+        , Text.decimal -> Right (termHeightPixels, "")
+        , Text.unsnoc -> Just (Text.decimal -> Right (termWidthPixels, "") , 't')
+        ] <- Text.split (==';') s
+      = \q ->
+    ( q { termHeightPixels, termWidthPixels }
+    , None
+    )
+
+keymap s
+      | [ "\ESC[6"
+        , Text.decimal -> Right (charHeight, "")
+        , Text.unsnoc