diff options
| -rw-r--r-- | app/Main.hs | 118 | ||||
| -rw-r--r-- | app/Pretty.hs | 5 |
2 files changed, 79 insertions, 44 deletions
diff --git a/app/Main.hs b/app/Main.hs index f12d0d0..25a3c97 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -4,6 +4,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Main where @@ -12,7 +13,6 @@ import Control.Arrow import Control.Concurrent import Control.Exception import Control.Monad -import Control.Monad.Trans import Data.Bits import Data.List import Data.Map qualified as M @@ -46,25 +46,27 @@ spacingArg = O.option O.auto (O.long "spacing" <> O.value 0) data Env = Env { dpy :: X.Display, win :: X.Window, - swidth :: Int, - sheight :: Int, - wwidth :: Int, - wheight :: Int, wleft :: Int, + wheight :: Int, gc :: X.GC, pixm :: X.Pixmap, fnt :: X.XftFont, drw :: X.XftDraw, cmap :: X.Colormap, vis :: X.Visual, - xcolors :: M.Map P.XColor String + xcolors :: M.Map P.XColor String, + qT :: TQueue () } type Colors = M.Map (P.Intensity, P.Color) X.XftColor data State = State { dirty :: Bool, - ui :: Ui (S.Sensor () (Block P.Doc)) + ui :: Maybe (Ui (Block P.Doc)), + ui' :: Maybe Ui', + wwidth :: Int, + swidth :: Int, + sheight :: Int } main :: IO () @@ -74,25 +76,41 @@ main = do withColors env (run env stateT) run :: Env -> TVar State -> Colors -> IO () -run env stateT colors = do - -- XXX `ui` lives in state, but we treat is as if it was constant - -- XXX this is supposed to NOT wait for the next event if `state.dirty` - state <- atomically $ readTVar stateT - S.reactimateS (pollUi state.ui >>> S.arrS (go Nothing)) - where - go Nothing pUi = do - atomically do - writeTVar stateT . (\state -> state {dirty = False}) - =<< readTVar stateT - lUi <- liftIO (paint env colors Nothing pUi) - pure lUi - go (Just lUi') pUi = do - dirty <- atomically do - state@State {..} <- readTVar stateT - writeTVar stateT state {dirty = False} - pure dirty - lUi <- liftIO (paint env colors (if dirty then Nothing else Just lUi') pUi) - pure lUi +run env stateT colors = forever do + atomically do + state <- readTVar stateT + checkSTM (isJust state.ui) + readTQueue env.qT + state <- resizeIfNeeded env stateT + ui'' <- paint env state colors + atomically do + state <- readTVar stateT + writeTVar stateT state {ui' = Just ui''} + +resizeIfNeeded :: Env -> TVar State -> IO State +resizeIfNeeded Env {..} stateT = do + (needsResize, state) <- atomically do + state <- readTVar stateT + let state' :: State + state' = state {wwidth = state.swidth} + writeTVar stateT state' + pure (state.wwidth /= state.sheight, state') + when (needsResize) do + X.resizeWindow dpy win (fi state.wwidth) (fi wheight) + X.sync dpy False + pure state + +paint :: Env -> State -> Colors -> IO Ui' +paint Env {..} State {ui = fromJust -> ui, ..} colors = do + let env' = Ui.Env {..} + ui'' <- layOutUi env' ui + maybe + (renderUi env' colors ui'') + (\ui' -> renderUi' env' colors ui' ui'') + ui' + X.copyArea dpy pixm win gc 0 0 (fi wwidth) (fi wheight) 0 0 + X.sync dpy False + pure ui'' processEvents :: Ptr X.XEvent -> Env -> TVar State -> IO () processEvents ev env@(Env {..}) stateT = do @@ -109,24 +127,17 @@ processEvent ev (Env {..}) stateT = do | X.ExposeEvent {} <- e -> atomically do state <- readTVar stateT writeTVar stateT state {dirty = True} + writeTQueue qT () + | X.ConfigureEvent {ev_width, ev_height} <- e -> atomically do + state <- readTVar stateT + (writeTVar stateT) + state + { swidth = fi ev_width, + sheight = fi ev_height + } + writeTQueue qT () | otherwise -> pure () -paint :: Env -> Colors -> Maybe Ui' -> Ui (Block P.Doc) -> IO Ui' -paint Env {..} colors Nothing ui = do - let env' = Ui.Env {..} - ui' <- layOutUi env' ui - renderUi env' colors ui' - X.copyArea dpy pixm win gc 0 0 (fi wwidth) (fi wheight) 0 0 - X.sync dpy False - pure ui' -paint Env {..} colors (Just ui') ui = do - let env' = Ui.Env {..} - ui'' <- layOutUi env' ui - renderUi' env' colors ui' ui'' - X.copyArea dpy pixm win gc 0 0 (fi wwidth) (fi wheight) 0 0 - X.sync dpy False - pure ui'' - destroyWindow :: (Env, TVar State) -> IO () destroyWindow (Env {..}, _) = do X.destroyWindow dpy win @@ -138,6 +149,7 @@ createWindow args = do scr = X.defaultScreenOfDisplay dpy root = X.defaultRootWindow dpy trueColor = 4 + X.selectInput dpy root X.structureNotifyMask Just vinfo <- X.matchVisualInfo dpy scrn 32 trueColor let cls = X.inputOutput dpth = X.visualInfo_depth vinfo @@ -225,10 +237,30 @@ createWindow args = do (14 {- cyan -}, "rgb:0/255/255"), (15 {- white -}, "rgb:255/255/255") ] + qT <- atomically do + qT <- newTQueue + writeTQueue qT () + pure qT let env = Env {..} - stateT <- newTVarIO State {..} + stateT <- + newTVarIO + State + { ui = Nothing, + ui' = Nothing, + .. + } void $ forkIO $ X.allocaXEvent $ \ev -> forever do processEvents ev env stateT + void $ forkIO do + S.reactimateS + ( pollUi ui + >>> S.arrS + ( \ui -> atomically do + state <- readTVar stateT + writeTVar stateT state {ui = Just ui} + writeTQueue qT () + ) + ) pure (env, stateT) withColors :: Env -> (Colors -> IO a) -> IO a diff --git a/app/Pretty.hs b/app/Pretty.hs index 6d500a0..8101fb7 100644 --- a/app/Pretty.hs +++ b/app/Pretty.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} @@ -14,12 +15,14 @@ module Pretty ) where +import Control.DeepSeq +import GHC.Generics (Generic) import Pretty.Color data Doc = Col [Doc] | Lit (Maybe (Intensity, Color)) String - deriving (Show, Eq) + deriving (Generic, Show, Eq, NFData) class Pretty a where pretty :: a -> Doc |