path: root/src/main.hs

{-# 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.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@State{..} = \case
    EScan (ScanKey s) ->
        Right <$> keymap (Text.pack s) 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 then
            max 0 $ workspaceViewportOffset - (newWorkspaceViewportHeight - workspaceViewportHeight)
          else if workspaceCursor < newWorkspaceViewportHeight + workspaceViewportOffset then
            workspaceViewportOffset
          else
            workspaceViewportOffset + (workspaceViewportHeight - newWorkspaceViewportHeight)


keymap :: Text -> State -> IO State

keymap s
      | [ "\ESC[4"
        , Text.decimal -> Right (termHeightPixels, "")
        , Text.unsnoc -> Just (Text.decimal -> Right (termWidthPixels, "") , 't')
        ] <- Text.split (==';') s
      = \q ->
    return q { termHeightPixels, termWidthPixels }

keymap s
      | [ "\ESC[6"
        , Text.decimal -> Right (charHeight, "")
        , Text.unsnoc -> Just (Text.decimal -> Right (charWidth, "") , 't')
        ] <- Text.split (==';') s
      = \q ->
    return q { charHeight, charWidth }

-- Up
keymap "\ESC[A" = \q@State{..} ->
    let
      newWorkspaceCursor = max 0 $ min (workspaceCursor + 1) $ length foundWorkspaces - 1
      newWorkspaceViewportOffset =
        -- TODO dedup with processEvent / EResize
        if newWorkspaceCursor < workspaceViewportOffset + workspaceViewportHeight then
          workspaceViewportOffset
        else
          workspaceViewportOffset + (newWorkspaceCursor - workspaceCursor)
    in
    return q
      { workspaceCursor = newWorkspaceCursor
      , workspaceViewportOffset = newWorkspaceViewportOffset
      }

-- Down
keymap "\ESC[B" = \q@State{..} ->
    --return q { workspaceCursor = max 0 $ workspaceCursor - 1 }
    let
      newWorkspaceCursor = max 0 $ workspaceCursor - 1
      newWorkspaceViewportOffset =
        -- TODO dedup with processEvent / EResize
        if newWorkspaceCursor >= workspaceViewportOffset then
          workspaceViewportOffset
        else
          workspaceViewportOffset - (workspaceCursor - newWorkspaceCursor)
    in
    return q
      { workspaceCursor = newWorkspaceCursor
      , workspaceViewportOffset = newWorkspaceViewportOffset
      }

-- Right
keymap "\ESC[C" = \q@State{..} ->
    return q { buffer = Buffer.move Buffer.CharsForward 1 buffer }

-- Left
keymap "\ESC[D" = \q@State{..} ->
    return q { buffer = Buffer.move Buffer.CharsBackward 1 buffer }

-- Home
keymap "\ESC[H" = \q@State{..} ->
    return q { ex_offsetY = ex_offsetY - 1 }

-- End
keymap "\ESC[F" = \q@State{..} ->
    return q { ex_offsetY = ex_offsetY + 1 }

keymap "\b" = \q@State{..} ->
    updateFoundWorkspaces <$> return q { buffer = Buffer.delete Buffer.CharsBackward 1 buffer }

keymap "\n" =
    jumpQndQuit

keymap s
      | Text.length s == 1
      , [c] <- Text.unpack s
      , Char.isPrint c
      = \q@State{..} ->
    return (updateFoundWorkspaces q { buffer = insertChar c buffer }) >>= \q@State{..} ->
    -- TODO make the jump-when-exactly-one-match behavior configurable
    if length foundWorkspaces == 1 then

      -- TODO if length foundWorkspaces == 2 and one of the workspaces is
      --      focused, then jump to the other

      case workspace_focused <$> lookupCursoredWorkspace q of
        Just False ->
          jumpQndQuit q
        _ ->
          return q
    else
      return q

keymap s =
    displayKey s



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

    -- IfElse's Control.Monad.IfElse.awhenM:
    --awhenM (workspace_name <$> lookupCursoredWorkspace) $ \name -> do
    --  _ <- wmpost manager ("/workspace/" <> Text.unpack name <> "/view") () :: IO (Maybe ())
    --  raiseSignal sigINT
    --return q


updateFoundWorkspaces :: State -> State
updateFoundWorkspaces q@State{..} =
    q { foundWorkspaces = newFoundWorkspaces
      , workspaceCursor = max 0 $ min workspaceCursor $ length newFoundWorkspaces - 1
      }
  where
    -- TODO List.sortBy compareWorkspaces (requires workspaces to be something better than a string)
    newFoundWorkspaces = filter f (Map.keys workspaces)
    f = Text.isPrefixOf (Text.pack (Buffer.showBuffer buffer))


mousemap :: Scan -> State -> IO State
--mousemap ScanMouse{mouseButton=1,mouseY=y} = defaultMouse1Click y
--mousemap ScanMouse{mouseButton=3,mouseY=y} = \q -> defaultMouse1Click y q >>= toggleFold
--mousemap ScanMouse{mouseButton=4} = moveTreeDown 3
--mousemap ScanMouse{mouseButton=5} = moveTreeUp 3
--mousemap ScanMouse{mouseButton=0} = return
mousemap info = displayMouse info

displayKey :: Text -> State -> IO State
displayKey s q = return q { flashMessage = Plain $ showText s }

displayMouse :: Scan -> State -> IO State
displayMouse info q =
    return q { flashMessage = SGR [38,5,202] $ Plain $ showText info }







winchHandler :: (Event -> IO ()) -> IO ()
winchHandler putEvent = do
    -- TODO use events
    --hPutStr stdout "\ESCc" -- TODO only on change
    hPutStr stdout "\ESC[14t" -- query terminal width / height (in pixels)
    hPutStr stdout "\ESC[16t" -- query character width / height
    Term.size >>= \case
        Just Term.Window {Term.width = w, Term.height = h} ->
            putEvent $ EResize w h
        Nothing ->
            return ()






redraw :: State -> IO ()
redraw q@State{..} = do
    Text.hPutStr stdout . pp $
        "\ESC[H"
        <> (mintercalate "\n" $ map eraseRight2 $ render0 q)

        -- XXX this has no effect when sixel scrolling is disabled
        -- <> "\ESC[5;" <> Plain (showText $ maxWidth + 2) <> "H"

        <> workspacePreview
    hFlush stdout
  where

    workspacePreview :: Blessings Text
    workspacePreview =
      let
        previewWidth = paddingRight * charWidth :: Int
        previewHeight = round $ (fromIntegral previewWidth :: Double) / fromIntegral screenWidth * fromIntegral screenHeight :: Int
        previewGeometry = Geometry
            { geometry_width = fromIntegral previewWidth
            , geometry_height = fromIntegral previewHeight
            , geometry_x = fromIntegral $ termWidthPixels - previewWidth
            , geometry_y = fromIntegral $ ex_offsetY
            }
        --windows =
        --  case foundWorkspaces of
        --    [] -> []
        --    _ ->
        --      let
        --        cursoredWorkspace = foundWorkspaces !! workspaceCursor -- TODO safe
        --      in
        --      fromMaybe [] $ Map.lookup cursoredWorkspace workspaces
      in

      --case foundWorkspaces of
      --  [] -> ""
      --  _ ->
      --    let
      --      cursoredWorkspace = foundWorkspaces !! workspaceCursor -- TODO safe
      --      ws = fromMaybe emptyWorkspace $ Map.lookup cursoredWorkspace workspaces
      --      -- TODO def
      --      emptyWorkspace = Workspace
      --        { workspace_geometry = Geometry 0 0 0 0
      --        , workspace_focused = False
      --        , workspace_name = ""
      --        , workspace_windows = []
      --        }
      --    in
      --    Plain $ Text.decodeUtf8With (\_ _ -> Nothing) $ Rasterizer.renderWorkspacePreview previewGeometry q ws

      fromMaybe "" (renderWorkspacePreview previewGeometry q <$> lookupCursoredWorkspace q)


    renderWorkspacePreview :: Geometry -> State -> Workspace -> Blessings Text
    renderWorkspacePreview geometry q =
        Plain . Text.decodeUtf8With (\_ _ -> Nothing) . Rasterizer.renderWorkspacePreview geometry q


    maxWidth = termWidth - paddingRight

    -- This is not just padding right, but also the width of the workspace preview
    paddingRight = 10 {- #paddingRight put into state -}

    eraseRight2 s =
        if Blessings.length s < maxWidth then
          s <> SGR [38,5,234] (Plain $ Text.pack $ replicate (maxWidth - Blessings.length s) '@')
        else
          s

    --sub x x' c = if c == x then x' else c
    --eraseRight s =
    --    if Blessings.length s < termWidth
    --        then s <> "\ESC[K"
    --        else s










render0 :: State -> [Blessings Text]
render0 q@State{..} =
    map (Blessings.take maxWidth) ((shownWorkspacesPadding <> shownWorkspaces) `join` (shownWindowsPadding <> fromMaybe mempty  shownWindows)) <>

    -- debug workspace viewport
    [SGR [38,5,147] "> " <> renderBuffer q] <>
    [Blessings.take termWidth $ SGR [38,5,242] flashMessage]
  where
    maxWidth = termWidth - paddingRight

    -- This is not just padding right, but also the width of the workspace preview
    paddingRight = 10 {- #paddingRight put into state -}

    -- for debugging workspace viewport
    -- debug = Plain (showText (workspaceViewportOffset, workspaceViewportHeight, workspaceCursor)


    n = termHeight - 2 {- input line + status line -}

    shownWorkspaces :: [Blessings Text]
    shownWorkspaces =
        reverse $ map showWorkspace $ zip [workspaceViewportOffset..] (take n (drop workspaceViewportOffset $ foundWorkspaces'))
      where
        foundWorkspaces' = catMaybes $ map (flip Map.lookup workspaces) foundWorkspaces

    shownWorkspacesPadding = replicate (n - length shownWorkspaces) (SGR [38,5,234] "~")

    showWorkspace :: (Int, Workspace) -> Blessings Text
    showWorkspace (index, Workspace{..}) =
      let
        --windows = maybe [] workspace_windows $ Map.lookup name workspaces

        isUrgent = any window_urgent workspace_windows

        (ls,rs) = Text.splitAt (bufferLength buffer) workspace_name
        marker =
          if index == workspaceCursor then
            SGR [38,5,177] "> "
          else
            Plain "  "

        fgColor =
          if isUrgent then
            SGR [38,5,196]
          else if workspace_focused then
            SGR [38,5,238]
          else if length workspace_windows == 0 then
            SGR [38,5,246]
          else
            id
      in
      marker <> SGR [48,5,023] (fgColor (Plain ls)) <> fgColor (Plain rs)


    --cursoredWorkspace = foundWorkspaces !! workspaceCursor -- TODO safe
    --cursoredWorkspaceWindows = maybe [] workspace_windows $ Map.lookup cursoredWorkspace workspaces

    shownWindows :: Maybe [Blessings Text]
    --shownWindows = take (length shownWorkspaces) $ map (SGR [38,5,236] . Plain . window_title) cursoredWorkspaceWindows

    shownWindows =
      take (length shownWorkspaces) . map (SGR [38,5,236] . Plain . window_title) . workspace_windows <$> lookupCursoredWorkspace q

    shownWindowsPadding = replicate (n - maybe 0 length shownWindows) (SGR [38,5,234] "~")


join :: [Blessings Text] -> [Blessings Text] -> [Blessings Text]
join ls rs =
    zipWith (<>) lsFilled rs
  where
    rsTruncated = map (Blessings.take 10) rs

    lsWidth = maximum $ map Blessings.length ls
    lsFilled = map (lsFill lsWidth) ls
    lsFill n s =
        if Blessings.length s < n then
          s <> SGR [38,5,234] (Plain (Text.pack (replicate (n - Blessings.length s) '#') <> Text.singleton '|'))
        else
          s <> SGR [38,5,234] (Plain (Text.singleton '|'))




--joinColumns :: [Blessings.Text] -> [Blessings.Text] -> [Blessings.Text]
--joinColumns ls rs =




mintercalate :: Monoid b => b -> [b] -> b
mintercalate c (h:t) = foldl (\acc x -> acc <> c <> x) h t
mintercalate _ [] = mempty



-- begin http client
--getXMonadState :: IO (Maybe (XMonad.Web.Types.State (XMonad.Web.Types.DummyLayout Text)))
--getXMonadState = do
--  mgr <- newManager defaultManagerSettings {
--    managerRawConnection = createUnixConnection
--  }
--  req <- parseUrl "http://localhost/state"
--  res <- httpLbs req mgr
--  let body = responseBody res
--  return $ Aeson.decode body


--createUnixConnection :: IO (Maybe NS.HostAddress -> String -> Int -> IO Connection)
--createUnixConnection = return $ \_ _ _ -> openUnixConnection xmonadSocketPath
--
--openUnixConnection :: String -> IO Connection
--openUnixConnection addr = E.bracketOnError
--    (NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol)
--    (NS.close)
--    $ \sock -> do
--        NS.connect sock sockAddr
--        mySocketConnection sock chunksize
--  where
--    sockAddr = NS.SockAddrUnix addr
--    chunksize = 8192
--
---------------------------------------------------------------------------------
---- Copied from http-client
---------------------------------------------------------------------------------
--
--mySocketConnection :: NS.Socket -> Int -> IO Connection
--mySocketConnection socket chunksize = makeConnection
--    (recv socket chunksize)
--    (sendAll socket)
--    (NS.close socket)

newUnixDomainSocketManager :: FilePath -> IO Manager
newUnixDomainSocketManager path = do
  let mSettings = defaultManagerSettings { managerRawConnection = return $ openUnixSocket path }
  newManager mSettings
  where
    openUnixSocket filePath _ _ _ = do
      s <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
      S.connect s (S.SockAddrUnix filePath)
      makeConnection (SBS.recv s 8096)
                     (SBS.sendAll s)
                     (S.close s)
-- end http client