wipwip2

7 files changed, 1317 insertions, 1 deletions

diff --git a/src/Much/Screen.hs b/src/Much/Screen.hs
new file mode 100644
index 0000000..47bb90c
--- /dev/null
+++ b/src/Much/Screen.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE RecordWildCards #-}
+module Much.Screen (Screen(..), setScreen, withScreen) where
+
+import Control.Exception
+import Data.List
+import System.IO
+
+data Screen = Screen
+    { stdinEcho :: Bool
+    , stdinBufferMode :: BufferMode
+    , stdoutBufferMode :: BufferMode
+    , decsetPm :: [Int]
+    , decrstPm :: [Int]
+    }
+
+setScreen :: Screen -> IO Screen
+setScreen Screen{..} = get <* set where
+  get = Screen <$> hGetEcho stdin
+               <*> hGetBuffering stdin
+               <*> hGetBuffering stdout
+               <*> pure decrstPm
+               <*> pure decsetPm
+  set = do
+      hSetEcho stdin stdinEcho
+      hSetBuffering stdin stdinBufferMode
+      hSetBuffering stdout stdoutBufferMode
+      hPutStr stdout $ "\ESC[?" ++ intercalate ";" (map show decsetPm) ++ "h"
+      hPutStr stdout $ "\ESC[?" ++ intercalate ";" (map show decrstPm) ++ "l"
+      hFlush stdout
+
+withScreen :: Screen -> (Screen -> IO a) -> IO a
+withScreen s = bracket (setScreen s) setScreen
diff --git a/src/Pager/Rasterizer.hs b/src/Pager/Rasterizer.hs
new file mode 100644
index 0000000..821e4cc
--- /dev/null
+++ b/src/Pager/Rasterizer.hs
@@ -0,0 +1,131 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+-- TODO rename to Pager.Sixelerator or something
+module Pager.Rasterizer where
+
+import Data.ByteString (ByteString)
+import Data.Maybe (catMaybes)
+--import Graphics.X11.Xlib.Types (Dimension,Position,Rectangle(..))
+import qualified Sixel
+import Sixel (PaletteColor)
+import State (State(..))
+--import qualified XMonad.Web.Types
+import Pager.Types
+
+
+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
+    --workspaceX = fromIntegral $ geometry_x previewGeometry :: Int
+    --workspaceY = fromIntegral $ geometry_y previewGeometry
+
+    -- TODO workspaceFirstBandOffset = workspaceY - floor (fromIntegral workspaceY / 6 :: Double) * 6
+    -- TODO workspaceFirstBandHeight = 6 - workspaceFirstBandOffset
+
+    -- TODO workspaceSkipBandCount = floor $ fromIntegral workspaceHeight / (6 :: Double)
+    -- TODO? workspaceTotalBandCount = ceiling $ fromIntegral (workspaceFirstBandOffset + workspaceHeight) / (6 :: Double) :: Integer
+    -- TODO? workspaceLastBandHeight = workspaceHeight - (workspaceTotalBandCount - 1) * 6 + workspaceFirstBandOffset
+
+    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 -- #ex_offsetY
+      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
+
+    --palette = map fromIntegral [0..length rgbColors - 1]
+
+    --colors = mconcat $ map (uncurry setColorMapRegister) (zip palette rgbColors)
+
+    --channels = splitChannels palette canvas
+    --scanlines = toScanlines (fromIntegral workspaceWidth) channels
+    --bitbands = toBitbands (fromIntegral workspaceWidth) scanlines
+    --bitbands6 = toBitbands6 bitbands
+    --bytebands = toBytebands bitbands6
+    --sixelbands = toSixelbands bytebands
+    --sixelbandsRLE = toSixelbandsRLE sixelbands
+    --sixeldata = toSixeldata (fromIntegral workspaceX) sixelbandsRLE
+
+
+    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..2cec025 100644
--- a/src/Pager/Types.hs
+++ b/src/Pager/Types.hs
@@ -5,6 +5,24 @@ import Data.Aeson.TH (Options(fieldLabelModifier), deriveJSON, defaultOptions)
 import Data.Text (Text)
 
 
+data Action
+  = None
+  -- | FocusWindow Int (Maybe Text)
+  | FocusWorkspace Text
+  -- | MoveWindowToWorkspace Int Text
+  -- | CopyWindowToWorkspace Int Text
+  | Batch Action Action
+
+instance Monoid Action where
+    mempty = None
+
+instance Semigroup Action where
+    x <> None = x
+    None <> x = x
+    Batch x1 x2 <> Batch x3 x4 = x1 <> x2 <> x3 <> x4
+    Batch x1 x2 <> x3 = x1 <> x2 <> x3
+    x1 <> x2 = Batch x1 x2
+
 data Geometry = Geometry
   { geometry_x :: Int
   , geometry_y :: Int
@@ -24,7 +42,7 @@ 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)
diff --git a/src/Sixel.hs b/src/Sixel.hs
new file mode 100644
index 0000000..9bda65a
--- /dev/null
+++ b/src/Sixel.hs
@@ -0,0 +1,172 @@
+{-# 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)
+
+-- TODO rename to RegisteredColor, IndexedColor?
+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
+
+
+-- TODO what's the correct name?
+-- TODO reword: channels :: [BitArray Int]
+-- TODO reword:  XXX channels must be sorted by color index (to compute sixeldata)
+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)
+
+
+-- TODO maybe use BitArray
+-- 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
+
+
+-- #gitginore TODO use Vector.imap instead of map zip [0..]?
+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..9f55743
--- /dev/null
+++ b/src/State.hs
@@ -0,0 +1,92 @@
+{-# LANGUAGE OverloadedStrings #-}
+module State where
+
+import qualified Data.Char
+import Data.Default (Default,def)
+import Data.Text (Text)
+import Data.Maybe (catMaybes)
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
+import qualified Data.Text.Read as Text
+import Control.Monad (forever)
+import Blessings.Text (Blessings(Plain,SGR),pp)
+import qualified Blessings.Internal as Blessings
+import Control.Concurrent
+import Data.Time
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Scanner
+import System.IO
+import qualified System.Console.Terminal.Size as Term
+import System.Posix.Signals (Handler(Catch), Signal, installHandler, sigINT)
+import Much.Screen (Screen(Screen), withScreen)
+import qualified Hack.Buffer as Buffer
+import Hack.Buffer (Buffer)
+--import XMonad.Aeson ()
+--import qualified XMonad.Web.Types ()
+--import qualified XMonad
+--import qualified XMonad.Web.Types
+--import qualified XMonad.StackSet
+import Network.HTTP.Client (Manager)
+import Pager.Types
+
+
+data State = State
+    { buffer :: Buffer
+    , count :: Int
+    , flashMessage :: Blessings Text
+    -- , now :: UTCTime
+    , termWidth :: Int
+    , termHeight :: Int
+    , charHeight :: Int
+    , charWidth :: Int
+    , screenWidth :: Int
+    , screenHeight :: Int
+    , termHeightPixels :: Int
+    , termWidthPixels :: Int
+    , termBorder :: Int
+    , manager :: Manager -- TODO not part of the state
+
+    --Request -> Manager -> IO (Response ByteString)Source
+
+    , workspaceViewportHeight :: Int
+    , workspaceViewportOffset :: Int
+
+    , foundWorkspaces :: [Text]
+    --, workspaces :: [Text]
+    --, workspaces :: Map Text [XMonad.Web.Types.Window]
+    , workspaces :: Map Text Workspace
+    , workspaceCursor :: Int
+    --
+    --, xmonadState :: XMonad.Web.Types.State (XMonad.Web.Types.DummyLayout Text)
+    , ex_offsetY :: Int -- TODO Word
+    }
+
+
+instance Default State where
+  def = State
+      { buffer = Buffer.emptyBuffer
+      , count = 1
+      , flashMessage = "Welcome to pager; quit with ^C"
+      -- , now = UTCTime (fromGregorian 1984 5 23) 49062
+      , termWidth = 0
+      , termHeight = 0
+      , screenHeight = 768 -- TODO
+      , screenWidth = 1366 -- TODO
+      , charWidth = 0
+      , charHeight = 0
+      , termWidthPixels = 0
+      , termHeightPixels = 0
+      , termBorder = 0
+      --
+      , workspaceViewportHeight = 0
+      , workspaceViewportOffset = 0
+      , foundWorkspaces = []
+      , workspaces = Map.empty
+      , workspaceCursor = 0
+      --
+      --, xmonadState = def
+      , ex_offsetY = 0
+      }
+
+
diff --git a/src/krebs.hs b/src/krebs.hs
new file mode 100644
index 0000000..38170dc
--- /dev/null
+++ b/src/krebs.hs
@@ -0,0 +1,24 @@
+
+    --Text.writeFile "/tmp/test" $ pp krebs
+
+    krebs = let size = 16 in
+      Plain
+      $ Text.decodeUtf8With (\_ _ -> Nothing)
+      $ Sixel.render
+        --(Rectangle (fromIntegral $ termWidthPixels - (fromIntegral size) - 2 * termBorder) 60 size size)
+        (Rectangle (fromIntegral $ termWidthPixels - (fromIntegral size) - 2 * termBorder) 38 size size)
+        [(0,0,0),(228,0,43)]
+        [0,1,0,1,0,0,0,0,0,0,0,0,0,1,0,1
+        ,1,1,0,1,0,0,1,1,0,1,1,0,1,1,0,1
+        ,1,1,0,1,0,0,1,1,0,1,1,0,1,1,0,1
+        ,0,1,1,1,0,0,0,1,0,0,1,0,0,1,1,1
+        ,0,1,1,1,0,0,1,1,1,1,1,0,0,1,1,1
+        ,0,0,1,0,0,1,1,1,1,1,1,1,0,0,1,0
+        ,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,0
+        ,0,0,0,0,0,1,1,1,1,1,1,1,0,0,0,0
+        ,0,0,0,1,1,1,1,1,1,1,1,1,1,1,0,0
+        ,0,0,0,1,0,0,0,1,1,1,0,0,0,1,0,0
+        ,0,0,1,0,0,1,0,1,0,1,0,1,0,0,1,0
+        ,0,0,1,0,0,1,0,1,0,1,0,1,0,0,1,0
+        ,0,0,1,0,1,1,0,1,0,1,0,1,1,0,1,0
+        ]
diff --git a/src/main.hs b/src/main.hs
new file mode 100644
index 0000000..0f1abbf
--- /dev/null
+++ b/src/main.hs
@@ -0,0 +1,847 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
+module Main where
+
+import qualified Data.Char as Char
+import qualified Data.Aeson as Aeson
+import Data.Default (def)
+import Data.Function ((&))
+import qualified Data.List as List
+import Data.Text (Text)
+import Data.Maybe (catMaybes,fromMaybe,listToMaybe)
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
+import qualified Data.Text.Read as Text
+import qualified Data.Text.Encoding as Text
+import Control.Monad (forever)
+import Blessings.Text (Blessings(Plain,SGR),pp)
+import qualified Blessings.Internal as Blessings
+import Control.Concurrent
+--import Data.Time
+import qualified Data.Map as Map
+import Pager.Types
+import Scanner
+import System.IO
+import qualified System.Console.Terminal.Size as Term
+import System.Posix.Signals (Handler(Catch), Signal, installHandler, raiseSignal, sigINT)
+import Much.Screen (Screen(Screen), withScreen)
+import qualified Hack.Buffer as Buffer
+import Hack.Buffer (Buffer)
+--import XMonad.Aeson ()
+--import XMonad.Web.Types ()
+----import qualified XMonad
+--import qualified XMonad.StackSet
+--import qualified XMonad.Web.Types
+--import qualified Sixel
+--import Sixel (PaletteColor)
+import State (State(..))
+--import Graphics.X11.Xlib.Types (Dimension,Position,Rectangle(..))
+--import qualified XMonad.Web.Types
+import qualified Pager.Rasterizer as Rasterizer
+import System.Environment (lookupEnv)
+
+-- begin http client
+--import Network.HTTP.Client
+--import Network.HTTP.Client.Internal (Connection, openSocketConnection, makeConnection)
+--import Network.Socket.ByteString (sendAll, recv)
+--import qualified Control.Exception as E
+--import qualified Network.Socket as NS
+
+import qualified Network.Socket as S
+import qualified Network.Socket.ByteString as SBS
+import Network.HTTP.Client
+--import Network.HTTP.Client.Internal (makeConnection)
+--import Network.HTTP.Types.Status (statusCode)
+-- end http client
+
+
+showText :: Show a => a -> Text
+showText = Text.pack . show
+
+
+-- TODO move to Buffer
+bufferLength :: Buffer -> Int
+bufferLength (ls, rs) =
+    length ls + length rs
+
+
+insertChar :: Char -> Buffer -> Buffer
+insertChar c (ls, rs) = (ls <> [c], rs)
+
+insertString :: String -> Buffer -> Buffer
+insertString s (ls, rs) = (ls <> s, rs)
+
+
+(!!?) :: [a] -> Int -> Maybe a
+x !!? i | i >= 0 = listToMaybe (drop i x)
+_ !!? _ = Nothing
+
+
+lookupCursoredWorkspace :: State -> Maybe Workspace
+lookupCursoredWorkspace State{..} =
+  flip Map.lookup workspaces =<< foundWorkspaces !!? workspaceCursor
+
+
+---- XXX assumes that the cursor is already at the (cleared) input line
+---- TODO renderInputLine looks like it wants to be -> VT ()
+--renderInputLine :: Maybe Int -> Mode -> Buffer -> IO ()
+--renderInputLine mb_cnt m (lhs, rhs) = do
+--    --clearLine -- XXX do we need this clearLine?
+--    renderRight $
+--        SGR [30,1] $
+--        Plain (show m) <>
+--            maybe Empty
+--                  (("["<>) . (<>"]") . SGR [33,1] . Plain . show)
+--                  mb_cnt
+--    renderLeft $ promptString m <> gaudySpecial [35] (lhs ++ rhs)
+--    moveCursorLeft $ length $ lit rhs
+--
+--
+--renderLeft :: Blessings String -> IO ()
+--renderLeft = putStr . pp
+--
+--
+--renderRight :: Blessings String -> IO ()
+--renderRight a = do
+--    saveCursor
+--    moveCursorRight 1024 -- XXX obviously, this is a hack..^_^
+--    moveCursorLeft $ len a - 1
+--    renderLeft a
+--    unsaveCursor
+-- end move to Buffer
+
+renderBuffer :: State -> Blessings Text
+renderBuffer State{buffer=(ls0,rs0)} =
+    let
+      ls = Text.pack ls0
+      rs = Text.pack rs0
+    in
+    case Text.uncons rs of
+      Just (c, rs') ->
+        Plain ls <> SGR [48,5,200] (Plain $ Text.singleton c) <> Plain rs'
+
+      Nothing ->
+        let
+          c = ' '
+        in
+        Plain ls <> SGR [48,5,200] (Plain $ Text.singleton c) <> Plain rs
+
+
+data Event =
+    --EFlash (Blessings Text) |
+    EScan Scan |
+    EShutdown |
+    --EReload |
+    EResize Int Int
+    --EStateGet (State -> IO ())
+  deriving Show
+
+
+
+-- TODO handle exceptions / errors
+wmget :: Aeson.FromJSON a => Manager -> String -> IO (Maybe a)
+wmget manager path = do
+    -- TODO check path is absolute
+    let url = "http://localhost" <> path
+    let request = parseRequest_ url
+    response <- httpLbs request manager
+    --putStrLn $ "wmget: The status code was: " ++ (show $ statusCode $ responseStatus response)
+    return $ Aeson.decode $ responseBody response
+
+wmpost :: (Aeson.ToJSON a, Aeson.FromJSON b) => Manager -> String -> a -> IO (Maybe b)
+wmpost manager path content = do
+    -- TODO check path is absolute
+    let url = "http://localhost" <> path
+    let request = (parseRequest_ url) { method = "POST", requestBody = RequestBodyLBS $ Aeson.encode content }
+    response <- httpLbs request manager
+    --putStrLn $ "wmpost: The status code was: " ++ (show $ statusCode $ responseStatus response)
+    return $ Aeson.decode $ responseBody response
+
+--post path content = do
+--    -- TODO check path is absolute
+--    let url = "http://localhost" <> path
+--    let request = parseRequest_ { method = "POST", requestBody = RequestBodyLBS $ Aeson.encode content }
+--    httpLbs request manager
+
+
+-- TODO put displayNumber in some lib
+-- https://tronche.com/gui/x/xlib/display/opening.html (where's the manual in NixOS?)
+-- hostname:number.screen_number
+--displayNumber :: String -> Maybe Int
+--displayNumber =
+--    takeWhile Char.isDigit . dropWhile (==':')
+
+
+
+main :: IO ()
+main = do
+    -- TODO dedup with xmonad API
+    display <- read . fromMaybe "0" . fmap (takeWhile Char.isDigit . dropWhile (==':')) <$> lookupEnv "DISPLAY" :: IO Int
+
+    -- TODO use $XMONAD_CACHE_DIR
+    -- API says: -- TODO runtimeDir instead of cacheDir
+    cacheDir <- fromMaybe undefined <$> lookupEnv "XMONAD_CACHE_DIR"
+    let xmonadSocketPath = cacheDir <> "/warp-" <> show display <> ".sock"
+    manager <- newUnixDomainSocketManager xmonadSocketPath
+
+    --response <- get "/state"
+
+    Just workspaces <- wmget manager "/pager/state" :: IO (Maybe [Workspace])
+
+    --putStrLn $ "The status code was: " ++ (show $ statusCode $ responseStatus response)
+    --let body = responseBody response
+    ----print body
+    --let Just XMonad.Web.Types.State{..} = Aeson.decode body :: Maybe (XMonad.Web.Types.State (XMonad.Web.Types.DummyLayout Text))
+
+    ----x <- getXMonadState
+    --print (111 :: Int)
+    --mapM_ (putStrLn . XMonad.StackSet.tag) (XMonad.Web.Types.s_workspaces state)
+    --print (112 :: Int)
+    --mapM_ (putStrLn . show . XMonad.StackSet.stack) (XMonad.Web.Types.s_workspaces state)
+    --print (113 :: Int)
+    --mapM_ (putStrLn . show . XMonad.StackSet.layout) (XMonad.Web.Types.s_workspaces state)
+    --print (114 :: Int)
+    --mapM_ (putStrLn . show) (XMonad.Web.Types.s_windows state)
+    ----print (115 :: Int)
+    ----print state
+    --print (999 :: Int)
+
+    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
+                ]
+                [   25 -- hide cursor
+                ,   80 -- disable sixel scrolling 
+                ]
+    withScreen screen0 $ \_ -> do
+      (putEvent, getEvent) <- do
+          v <- newEmptyMVar
+          return (putMVar v, takeMVar v)
+
+      let q1 =
+            updateFoundWorkspaces $ def
+              { manager = manager
+              , termBorder = 2 -- TODO config
+              , workspaces =
+                  let
+                    f workspace@Workspace{workspace_name} = ( workspace_name, workspace )
+                  in
+                  Map.fromList (map f workspaces)
+              }
+          --windows =
+          --    let
+          --      f window@Window{window_id} = ( window_id, window )
+          --    in
+          --    Map.fromList (map f s_windows)
+          signalHandlers =
+              [ (sigINT, putEvent EShutdown)
+              , (28, winchHandler putEvent)
+              ]
+
+      installHandlers signalHandlers
+
+      threadIds <- mapM forkIO
+          [ forever $ scan stdin >>= putEvent . EScan
+          ]
+
+      winchHandler putEvent
+
+      run getEvent q1
+
+      hPutStr stdout "Fin"
+      mapM_ killThread threadIds
+
+
+run :: IO Event -> State -> IO ()
+run getEvent = rec . Right where
+    rec = \case
+        Right q -> -- do
+            --t <- getCurrentTime
+            --let q' = q { now = t }
+            redraw q >> getEvent >>= processEvent q >>= rec
+        Left _q -> return ()
+
+
+installHandlers :: [(Signal, IO ())] -> IO ()
+installHandlers =
+    mapM_ (\(s, h) -> installHandler s (Catch h) Nothing)
+
+
+processEvent :: State -> Event -> IO (Either State State)
+processEvent q = \case
+    EScan (ScanKey s) -> do
+        let
+            key = Text.pack s
+            (q', action) = keymap key q
+
+            realizeAction = \case
+              None ->
+                return ()
+
+              Batch a1 a2 -> do
+                realizeAction a1
+                realizeAction a2
+
+              FocusWorkspace name -> do
+                -- TODO make quitting configurable with some "quit after change focus" option
+                --jumpQndQuit :: State -> IO State
+                --jumpQndQuit q@State{manager} = do
+                --    case workspace_name <$> lookupCursoredWorkspace q of
+                --      Just name -> do
+                --        -- TODO response, TODO Cmd-like
+                --        _ <- wmpost manager ("/workspace/" <> Text.unpack name <> "/view") () :: IO (Maybe ())
+                --        raiseSignal sigINT
+                --        return q
+                --
+                --      Nothing ->
+                --        return q
+                _ <- wmpost (manager q') ("/workspace/" <> Text.unpack name <> "/view") () :: IO (Maybe ())
+                raiseSignal sigINT
+
+        -- TODO check for failures, and then Left instead of Right
+        realizeAction action
+
+        return $ Right q'
+
+    EScan mouseInfo@ScanMouse{..} ->
+        Right <$> mousemap mouseInfo q
+    EShutdown ->
+        return $ Left q
+    EResize w h ->
+        return $ Right q
+            { termWidth = w, termHeight = h
+            , flashMessage = Plain $ "resize " <> showText (w,h)
+
+            , workspaceViewportHeight = newWorkspaceViewportHeight
+            , workspaceViewportOffset = newWorkspaceViewportOffset
+            }
+      where
+        -- TODO resizeWorkspaceViewport
+        -- TODO what if h < 0?
+
+        newWorkspaceViewportHeight = h - 2 {- input line + status line -}
+
+        newWorkspaceViewportOffset =
+          if newWorkspaceViewportHeight > workspaceViewportHeight q then
+            max 0 $ workspaceViewportOffset q + (workspaceViewportHeight q - newWorkspaceViewportHeight)
+
+          --else if workspaceCursor q >= newWorkspaceViewportHeight + workspaceViewportOffset q then
+          else if newWorkspaceViewportHeight <= workspaceCursor q - workspaceViewportOffset q then
+            workspaceViewportOffset q + (workspaceViewportHeight q - newWorkspaceViewportHeight)
+
+          else
+            workspaceViewportOffset q
+
+          --if workspaceCursor q < workspaceViewportOffset q then
+          --  workspaceCursor q
+
+          --else if workspaceCursor q >= workspaceViewportOffset q + workspaceViewportHeight q then
+          --  workspaceCursor q - workspaceViewportHeight q + 1
+
+          --else
+          --  workspaceViewportOffset q
+
+
+-- negative ~ down, positive ~ up
+moveWorkspaceCursor :: Int -> State -> State
+moveWorkspaceCursor i q@State{..} =
+    --case compare i 0 of
+    --  LT -> moveWorkspaceCursorDown (-1) q
+    --  GT -> moveWorkspaceCursorUp 1 q
+    --  EQ -> q
+    q
+      { workspaceCursor = newWorkspaceCursor
+      , workspaceViewportOffset = newWorkspaceViewportOffset
+      }
+  where
+    newWorkspaceCursor = max 0 $ min (workspaceCursor + i) $ length foundWorkspaces - 1
+
+    -- TODO dedup with processEvent / EResize
+    newWorkspaceViewportOffset =
+      if newWorkspaceCursor < workspaceViewportOffset then
+        newWorkspaceCursor
+
+      else if newWorkspaceCursor >= workspaceViewportOffset + workspaceViewportHeight then
+        newWorkspaceCursor - workspaceViewportHeight + 1
+
+      else
+        workspaceViewportOffset
+
+
+      --if newWorkspaceCursor < workspaceCursor then
+      --  if newWorkspaceCursor < workspaceViewportOffset then
+      --    newWorkspaceCursor -- TODO clamp or is it already?
+      --  else
+      --    workspaceViewportOffset
+
+      --else if newWorkspaceCursor > workspaceCursor then
+      --  if newWorkspaceCursor >= workspaceViewportOffset + workspaceViewportHeight then
+      --    newWorkspaceCursor - workspaceViewportHeight + 1
+      --  else
+      --    workspaceViewportOffset
+
+      --else
+      --  workspaceViewportOffset
+
+    --workspaceCursorDelta = newWorkspaceCursor - workspaceCursor
+    --workspaceViewportDelta =
+    --    if isNewWorkspaceCursorOutOfViewport then
+    --      workspaceCursorDelta
+
+    --    else
+    --      0
+    --
+    --newWorkspaceViewportOffset = workspaceViewportOffset + workspaceViewportDelta
+
+    --isNewWorkspaceCursorOutOfViewport =
+    --      newWorkspaceCursor < workspaceViewportOffset ||
+    --      newWorkspaceCursor >= workspaceViewportOffset + workspaceViewportHeight
+
+    --    --if newWorkspaceCursor < workspaceViewportOffset then
+    --    --  workspaceViewportOffset - (workspaceCursor - newWorkspaceCursor)
+
+    --    --else if newWorkspaceCursor >= workspaceViewportOffset + workspaceViewportHeight then
+    --    --  workspaceViewportOffset + (newWorkspaceCursor - workspaceCursor)
+
+    --    --else
+    --    --  workspaceViewportOffset
+
+
+      --if newWorkspaceCursor < workspaceCursor then
+      --  if newWorkspaceCursor < workspaceViewportOffset then
+      --    workspaceViewportOffset - (workspaceCursor - newWorkspaceCursor)
+      --  else
+      --    workspaceViewportOffset
+
+      --else if newWorkspaceCursor > workspaceCursor then
+      --  if newWorkspaceCursor >= workspaceViewportOffset + workspaceViewportHeight then
+      --    workspaceViewportOffset + (newWorkspaceCursor - workspaceCursor)
+      --  else
+      --    workspaceViewportOffset
+
+      --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 -> Just (Text.decimal -> Right (charWidth, "") , 't')
+        ] <- Text.split (==';') s
+      = \q ->
+    ( q { charHeight, charWidth }
+    , None
+    )
+
+-- Up
+keymap "\ESC[A" = \q@State{..} ->
+    ( moveWorkspaceCursor count q & setCount 1
+    , None
+    )
+
+-- Down
+keymap "\ESC[B" = \q@State{..} ->
+    ( moveWorkspaceCursor (-count) q & setCount 1
+    , None
+    )
+
+-- PgUp
+keymap "\ESC[5~" = \q@State{..} ->
+    ( moveWorkspaceCursor (count * max 1 (workspaceViewportHeight - 1)) q & setCount 1
+    , None
+    )
+
+-- PgDn
+keymap "\ESC[6~" = \q@State{..} ->
+    ( moveWorkspaceCursor (-count * max 1 (workspaceViewportHeight - 1)) q & setCount 1
+    , None
+    )
+
+keymap "\ESCOP"   = \q -> (setCount 1 q, mempty)
+keymap "\ESCOQ"   = \q -> (setCount 2 q, mempty)
+keymap "\ESCOR"   = \q -> (setCount 3 q, mempty)
+keymap "\ESCOS"   = \q -> (setCount 4 q, mempty)
+keymap "\ESC[15~" = \q -> (setCount 5 q, mempty)
+keymap "\ESC[17~" = \q -> (setCount 6 q, mempty)
+keymap "\ESC[18~" = \q -> (setCount 7 q, mempty)
+keymap "\ESC[19~" = \q -> (setCount 8 q, mempty)
+keymap "\ESC[20~" = \q -> (setCount 9 q, mempty)
+keymap "\ESC[21~" = \q -> (setCount 0 q, mempty)
+
+-- Right
+keymap "\ESC[C" = \q@State{..} ->
+    ( q { buffer = Buffer.move Buffer.CharsForward 1 buffer }
+    , None
+    )
+
+-- Left
+keymap "\ESC[D" = \q@State{..} ->
+    ( q { buffer = Buffer.move Buffer.CharsBackward 1 buffer }
+    , None
+    )
+
+-- Home
+keymap "\ESC[H" = \q@State{..} ->
+    ( q { ex_offsetY = ex_offsetY - 1 }