wipwip2

18 files changed, 2176 insertions, 3 deletions

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..b42ce69
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,3 @@
+/dist-newstyle
+/.graveyard
+/tmp
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..d9494ee
--- /dev/null
+++ b/README.md
@@ -0,0 +1,11 @@
+
+
+
+
+
+
+
+
+cabal2nix . > pager.nix && nix-shell
+./build
+tmp/main
diff --git a/TODO b/TODO
new file mode 100644
index 0000000..e86edbe
--- /dev/null
+++ b/TODO
@@ -0,0 +1,45 @@
+
+
+1.1 define Pager.API.Types
+1.2 provide Pager.API.Types via XMonad.Web
+1.3 purge X11 and XMonad types from pager
+
+
+
+
+- transient mode: close on change [optional, e.g. when openend wia Menu button]
+- persistent mode
+  - sticky
+
+- refresh (^L, \v)
+- list window names on right pane (showing urgenct, allow selecting)
+- hightlight selected window [blue?]
+- show urgent workspaces on bottom
+- show current even more on bottom (and greyed out, don't quickjump there)
+- show workspace count (filtered/all)
+
+- notifications
+
+- multi display support
+- xinerama
+
+- persistent prefixes
+- tab completion
+
+
+- get live updates from window manager (e.g. urgency)
+
+# bugfixes
+- remove workspace preview when there is no match
+
+# ideas
+- allow marking windows for quick swich to
+- jump to marked windo (Menu > F1..)
+
+
+
+- allow starting pager with the state as parameter, this would allow to run it without requiring XMonad.API
+
+
+- add caching? .graveyard/caching.hs (need to enable sixel scrolling)
+  TODO cache :: Map workspaceName (Maybe (windows,sixelText)) invalidate cache when windows have changed
diff --git a/build b/build
new file mode 100755
index 0000000..83033d2
--- /dev/null
+++ b/build
@@ -0,0 +1,39 @@
+#! /bin/sh
+# usage: ./build [{dev,prod}]
+
+set -efu
+
+main() {
+  case ${1-dev} in
+    dev) build_dev;;
+    prod) build_prod;;
+    *) echo "$0: bad mode: $1" >&2; exit 1;;
+  esac
+}
+
+build_dev() {
+  ghc -Wall \
+      -i$HOME/stockholm/tv/5pkgs/haskell/xmonad-tv/src \
+      -isrc \
+      -odir tmp \
+      -hidir tmp \
+      src/main.hs \
+      -threaded \
+      -O0 \
+      -o tmp/main
+}
+
+# TODO for prod, don't -i external packages (libraries)
+build_prod() {
+  ghc -Wall \
+      -i$HOME/stockholm/tv/5pkgs/haskell/xmonad-tv/src \
+      -isrc \
+      -odir tmp \
+      -hidir tmp \
+      src/main.hs \
+      -threaded \
+      -O3 \
+      -o tmp/main
+}
+
+main "$@"
diff --git a/pager.cabal b/pager.cabal
index b3df3c3..beb66a6 100644
--- a/pager.cabal
+++ b/pager.cabal
@@ -6,13 +6,69 @@ license: MIT
 author: tv <tv@krebsco.de>
 maintainer: tv@krebsco.de
 build-type: Simple
+--category: System
+--synopsis: window manager agnostic desktop pager
+--description: window manager agnostic desktop pager :)
+
+source-repository head
+  type: git
+  location: https://cgit.krebsco.de/pager
+
+source-repository this
+  type: git
+  location: https://cgit.krebsco.de/pager
+  tag: 1.0.0
+
+executable pager
+  main-is: main.hs
+  default-language: Haskell2010
+  ghc-options: -Wall -threaded -with-rtsopts=-N
+  hs-source-dirs: src
+  build-depends: base >= 4.13 && < 5
+               , aeson
+               , data-default
+               , blessings
+               , bytestring
+               , hack
+               , probability
+               , scanner
+               , speculate
+               , split
+               , text
+               , terminal-size
+               -- TODO hack
+               , http-client
+               , http-types
+               , unix
+               , time
+               , containers
+               , io-streams
+               , optparse-applicative
+               , network
+               , pager
+
+               -- TODO remove stuff for xmonad-web
+               --, transformers
+               -- END xmonad-web
+
+               --, X11
+               --, xmonad
+               --, xmonad-aeson
+               -- TODO , xmonad-web
+               --, xmonad-tv
+  other-modules: Much.Screen
+               , Pager.Rasterizer
+               , Pager.Types
+               , Sixel
+               , State
 
 library
-  build-depends: base
+  build-depends:
+    base
                , aeson
                , template-haskell
                , text
   default-language: Haskell2010
   exposed-modules: Pager.Types
-  ghc-options: -O2 -Wall
+  ghc-options: -Wall
   hs-source-dirs: src
diff --git a/pager.nix b/pager.nix
new file mode 100644
index 0000000..5f0de90
--- /dev/null
+++ b/pager.nix
@@ -0,0 +1,19 @@
+{ mkDerivation, aeson, base, blessings, bytestring, containers
+, data-default, hack, http-client, http-types, io-streams, network
+, optparse-applicative, probability, scanner, speculate, split
+, stdenv, template-haskell, terminal-size, text, time, unix
+}:
+mkDerivation {
+  pname = "pager";
+  version = "1.0.0";
+  src = ./.;
+  isLibrary = true;
+  isExecutable = true;
+  libraryHaskellDepends = [ aeson base template-haskell text ];
+  executableHaskellDepends = [
+    aeson base blessings bytestring containers data-default hack
+    http-client http-types io-streams network optparse-applicative
+    probability scanner speculate split terminal-size text time unix
+  ];
+  license = stdenv.lib.licenses.mit;
+}
diff --git a/read-jsons b/read-jsons
new file mode 100755
index 0000000..9d456f0
--- /dev/null
+++ b/read-jsons
diff --git a/read-jsons.hs b/read-jsons.hs
new file mode 100644
index 0000000..0f9e973
--- /dev/null
+++ b/read-jsons.hs
@@ -0,0 +1,140 @@
+{-# LANGUAGE OverloadedStrings, DeriveGeneric, NoMonomorphismRestriction, RankNTypes, BangPatterns #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+module Main where
+
+import Control.Exception (catch)
+import Control.Monad (forever)
+import Data.Bool (bool)
+import qualified Data.Text as Text
+import qualified Data.Text.Read as Text
+import qualified Data.Text.IO as Text
+import qualified Data.Char as Char
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Types as Aeson (Parser)
+--import qualified Data.ByteString.Streaming.Aeson as Aeson (streamParse)
+import qualified Data.ByteString as ByteString
+import qualified Data.ByteString.Lazy as ByteString.Lazy
+--import Data.JsonStream.Parser (value, arrayOf, (.:), Parser)
+--import Data.Aeson (FromJSON, parseJSON, withObject)
+import qualified Data.Aeson.TH as TH (deriveJSON, defaultOptions, defaultTaggedObject, Options(fieldLabelModifier,constructorTagModifier,sumEncoding),tagFieldName)
+import Data.Text (Text)
+import Data.Function ((&))
+--import Streaming
+--import qualified Streaming.Prelude as S
+import           System.IO.Streams (Generator, InputStream, OutputStream)
+import qualified System.IO.Streams as Streams
+import Control.Applicative
+import qualified Data.Aeson as Aeson
+import Data.ByteString
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import System.IO (stdin, stderr)
+import qualified System.IO as String (hPutStrLn)
+import System.IO (hFlush)
+import GHC.IO.Handle.FD (fdToHandle)
+import System.IO.Streams hiding (stdin, stderr)
+import System.IO.Streams.Attoparsec (parseFromStream)
+import System.IO.Streams.Attoparsec (ParseException)
+import Options.Applicative
+
+data Options = Options
+    { optionsSignalInputURI :: Maybe Text
+    , optionsControlOutputURI :: Maybe Text
+    , optionsDebugOutputURI :: Maybe Text
+    }
+  deriving (Show)
+
+--main :: IO ()
+--main = do
+--    options <- execParser optionsParser
+--    putStrLn
+--        (concat ["Hello, ", optVal options, ", the flag is ", show (optFlag options)])
+--  where
+optionsParser :: ParserInfo Options
+optionsParser =
+    info
+        (helper <*> versionOption <*> programOptions)
+        (fullDesc <> progDesc "optparse example" <>
+         header
+             "optparse-example - a small example program for optparse-applicative")
+  where
+    versionOption :: Parser (a -> a)
+    versionOption = infoOption "0.0" (long "version" <> help "Show version")
+    programOptions :: Parser Options
+    programOptions =
+        Options
+          <$> optional (strOption $ long "signal" <> metavar "URI") -- value "default <> help ".."
+          <*> optional (strOption $ long "control" <> metavar "URI")
+          <*> optional (strOption $ long "debug" <> metavar "URI")
+
+
+
+data Msg = Msg
+    { msg_text :: Maybe Text
+    } | Time { time_value :: Double }
+  deriving (Show)
+
+$(TH.deriveJSON TH.defaultOptions
+  { TH.constructorTagModifier = Prelude.map Char.toLower
+  , TH.fieldLabelModifier = Prelude.tail . Prelude.dropWhile (/='_')
+  , TH.sumEncoding = TH.defaultTaggedObject { TH.tagFieldName = "type" }
+  } ''Msg)
+
+
+--parseJSONFromStream :: FromJSON a => InputStream ByteString -> IO a
+--parseJSONFromStream = parseJSON <$> parseFromStream json'
+
+
+handleFromURI = \case
+  Just s | ["fd", Text.decimal -> Right (h, "")] <- Text.split (==':') s -> do
+    -- TODO exceptions?
+    Right . Just <$> fdToHandle h
+
+  Just s ->
+    return $ Left $ "unsupported URI: " <> s
+
+  Nothing ->
+    return $ Right Nothing
+
+
+-- while jq -cn '[{type:"msg",value:"\(now)"},{"type":"time","value":now}][]'; do sleep 1; echo 121231.2; done | (exec 3<&0 4>&1 5>&2; exec  xterm -e ./read-jsons --signal=fd:3 --control=fd:4 --debug=fd:5)
+main :: IO ()
+main = do
+    options <- execParser optionsParser
+    print options
+
+    jsonOut <- fdToHandle 4
+    debugOutHandle <- fdToHandle 5
+
+    -- TODO specify protocol
+    -- TODO http+unix:/path/to/socket (TODO client vs server)
+    -- TODO fd:
+    maybeSignalInputHandle <- handleFromURI $ optionsSignalInputURI options
+
+    case maybeSignalInputHandle of
+      Right (Just signalInputHandle) -> do
+        String.hPutStrLn debugOutHandle $ "signal input handle: " <> show signalInputHandle
+
+        --let notEOF s = if ByteString.null s then Nothing else Just s
+        -- TODO Data.ByteString.Extra.hGetMaybe
+        let maybeSome = bool Nothing . Just <*> not . ByteString.null
+        let hGetMaybe h c = maybeSome <$> ByteString.hGet h c
+
+        let parse stream = Aeson.fromJSON <$> parseFromStream Aeson.json' stream :: IO (Aeson.Result Msg)
+
+
+        makeInputStream (hGetMaybe signalInputHandle 1) >>= forever . ((>>=String.hPutStrLn debugOutHandle . show) . parse)
+        -- TODO `catch` \e -> Prelude.putStrLn ("Caught " <> show (e :: ParseException))
+
+      Right Nothing ->
+          hPutStrLn debugOutHandle $ "signal input disabled"
+
+      Left error -> do
+          Text.hPutStrLn debugOutHandle $ "failed to open signal input: " <> error
diff --git a/shell.nix b/shell.nix
new file mode 100644
index 0000000..836da25
--- /dev/null
+++ b/shell.nix
@@ -0,0 +1,22 @@
+{ nixpkgs ? import <nixpkgs> {}, compiler ? "default", doBenchmark ? false }:
+
+let
+
+  inherit (nixpkgs) pkgs;
+
+  haskellPackages = if compiler == "default"
+                       then pkgs.haskellPackages
+                       else pkgs.haskell.packages.${compiler};
+
+  variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id;
+
+  drv = variant (haskellPackages.callPackage ./pager.nix {
+  });
+
+in
+
+  pkgs.lib.overrideDerivation drv.env (oldAttrs: {
+    buildInputs = [
+      pkgs.cabal-install
+    ];
+  })
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 (looku