diff options
| -rw-r--r-- | app/Main.hs | 8 | ||||
| -rw-r--r-- | app/Sensor.hs | 32 | ||||
| -rw-r--r-- | app/Ui.hs | 82 |
3 files changed, 81 insertions, 41 deletions
diff --git a/app/Main.hs b/app/Main.hs index 573e6a1..f12d0d0 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -187,16 +187,16 @@ createWindow args = do Ui $ intercalate [pure (lit " ")] $ [ [lit <$> wmWorkspaces], - [lit <$> wmName, pure fill], + [litShrink <$> wmName, pure fill], [pure (lit (if args.icons then "\xf4bc " else "cpu ")), lit <$> cpu], [pure (lit (if args.icons then "\xf035b " else "mem ")), lit <$> mem], [pure (lit (if args.icons then "\xf0a0 " else "disk ")), lit <$> disk], [pure (lit (if args.icons then "\xf1638 " else "io ")), lit <$> io], [pure (lit (if args.icons then "\xf0200 " else "net ")), lit <$> net], - [pure (lit " "), lit <$> Sensor.snd], - [pure (lit " "), lit <$> thermal], + [pure (lit " "), lit <$> Sensor.snd, pure (lit " ")], + [pure (lit (if args.icons then "\xf2cb " else "temp ")), lit <$> thermal], [pure (lit " "), lit <$> bat], - [lit <$> weatherForecast], + -- [lit <$> weatherForecast], [pure (lit " "), lit <$> date, pure (lit ", "), lit <$> time] ] xcolors <- do diff --git a/app/Sensor.hs b/app/Sensor.hs index 2c2e860..de14783 100644 --- a/app/Sensor.hs +++ b/app/Sensor.hs @@ -114,16 +114,23 @@ diagram n sf = S.feedbackS [] $ proc ((), xs) -> do x <- sf -< () returnA -< (P.diagram n (reverse (x : xs)), take (2 * (n - 1) + 1) (x : xs)) -thermal :: S.Sensor () String -thermal = S.sensor (\() -> "thermal") $ \() yield -> forever do - yield . fmt =<< parse <* sleep +thermal :: S.Sensor () (P.Diagram [Float]) +thermal = + ((\x -> clamp 0 1 (x / 100)) <$$$>) $ + diagram 1 $ + S.sensor (\() -> "thermal") $ \() yield -> forever do + yield =<< parse <* sleep where parse = liftIO do is <- listDirectory "/sys/class/thermal" maximum <$> mapM (parse1 . ("/sys/class/thermal" </>)) is parse1 fp = do - (choice 0 [readFile (fp </> "temp") (pure . read @Int . strip)]) - fmt temp = (printf "%.1f" (fromIntegral temp / (1000 :: Float))) + (choice 0 [readFile (fp </> "temp") (pure . (/ 1000) . fromIntegral . read @Int . strip)]) + +clamp :: (Ord a) => a -> a -> a -> a +clamp hi lo + | hi > lo = min hi . max lo + | otherwise = clamp lo hi ioStat :: S.Sensor () Int ioStat = S.sensor (\() -> "ioStat") $ \() yield -> forever do @@ -636,8 +643,8 @@ time = <$> currentTimeZone <*> currentTime -wmName :: S.Sensor () String -wmName = activeWindow >>> S.withDefaultS "" wmNameOf +wmName :: S.Sensor () P.Doc +wmName = activeWindow >>> S.withDefaultS (P.pretty "") wmNameOf data ActiveWindow = ActiveWindow deriving (Show) @@ -682,7 +689,7 @@ activeWindow = do waitForEvent ) -wmNameOf :: S.Sensor X.Window String +wmNameOf :: S.Sensor X.Window P.Doc wmNameOf = S.sensor (\win -> printf "wmNameOf %s" (show win)) @@ -716,7 +723,7 @@ wmNameOf = waitForEvent readWmName = do - yield + yield . P.color P.Magenta . P.pretty =<< fmap (strip . head) . liftIO . X.wcTextPropertyToTextList dpy =<< liftIO (X.getTextProperty dpy win netWmName) forever do @@ -815,12 +822,15 @@ instance P.Pretty [Workspace] where P.Col . intersperse (P.pretty " ") . map P.pretty instance P.Pretty Workspace where - pretty (Active s) = P.color P.White (P.pretty s) - pretty (Inactive s) = P.color P.Cyan (P.pretty s) + pretty (Active s) = P.color P.Cyan (P.pretty s) + pretty (Inactive s) = P.color P.White (P.pretty s) (<$$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) f <$$> x = fmap f <$> x +(<$$$>) :: (Functor f, Functor g, Functor h) => (a -> b) -> f (g (h a)) -> f (g (h b)) +f <$$$> x = fmap f <$$> x + infixl 4 <$$> fi :: (Integral a, Num b) => a -> b @@ -1,6 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} @@ -12,8 +13,10 @@ module Ui ( Ui (Ui), Block, + Flex (..), lit, fill, + litShrink, pollUi, Env (..), Ui', @@ -48,41 +51,39 @@ data Ui a = Ui [a] ) data Block a - = Lit a - | Fill + = Lit Flex a deriving (Eq, Functor, Show, Generic, NFData) +data Flex = Flex + { canGrow :: Bool, + canShrink :: Bool + } + deriving (Eq, Show, Generic, NFData) + lit :: (P.Pretty a) => a -> Block P.Doc -lit = Lit . P.pretty +lit = Lit (Flex False False) . P.pretty + +litShrink :: (P.Pretty a) => a -> Block P.Doc +litShrink = Lit (Flex False True) . P.pretty -fill :: Block a -fill = Fill +fill :: Block P.Doc +fill = Lit (Flex True False) (P.pretty "") pollUi :: Ui (S.Sensor () (Block P.Doc)) -> S.Sensor () (Ui (Block P.Doc)) pollUi (Ui sfs) = Ui <$> S.concatS sfs layOutUi :: Env -> Ui (Block P.Doc) -> IO Ui' -layOutUi env (Ui bs) = layOut env (Ui' (concatMap go bs)) +layOutUi env (Ui bs) = shrinkText env =<< layOut env (Ui' (concatMap go bs)) where - go (Lit doc) = go' doc - go Fill = + go (Lit flex (P.Lit color string)) = [ C { rect = def, - fill = True, - color = Nothing, - string = "" - } - ] - - go' (P.Lit color string) = - [ C - { rect = def, - fill = False, .. } ] - go' (P.Col docs) = - concatMap go' docs + go (Lit flex (P.Col docs)) = + -- TODO bug `P.Col` needs container support in `C` + concatMap (go . Lit flex) docs layOut :: Env -> Ui' -> IO Ui' layOut env@Env {..} (Ui' cs) = do @@ -95,12 +96,41 @@ layOut env@Env {..} (Ui' cs) = do left <- get <* modify (+ rect.width) pure c {rect = rect {left = left}} - expa rwidth (c@C {fill = True} : cs) = - do - c {rect = c.rect {width = c.rect.width + rwidth}} - : map (\c -> c {rect = c.rect {left = c.rect.left + rwidth}}) cs - expa rwidth (c : cs) = c : expa rwidth cs expa _ [] = [] + expa 0 cs = cs + expa rwidth (c@C {flex = Flex False False} : cs) = c : expa rwidth cs + expa rwidth (c@C {flex = Flex {..}} : cs) = + if + | rwidth > 0 && canGrow -> + c {rect = c.rect {width = c.rect.width + rwidth}} + : map (\c -> c {rect = c.rect {left = c.rect.left + rwidth}}) cs + | rwidth < 0 && canShrink -> + c {rect = c.rect {width = c.rect.width + rwidth}} + : map (\c -> c {rect = c.rect {left = c.rect.left + rwidth}}) cs + | otherwise -> c : expa rwidth cs + +shrinkText :: Env -> Ui' -> IO Ui' +shrinkText Env {..} (Ui' cs) = Ui' <$> mapM go cs + where + go C {..} = do + string' <- fit rect.width string + pure C {string = string', ..} + + fit _ "" = pure "" + fit rwidth string = do + glyphInfo <- X.xftTextExtents dpy fnt string + let width = X.xglyphinfo_xOff glyphInfo + if width <= rwidth + then pure string + else fit' rwidth (init string) + + fit' _ "" = pure "" + fit' rwidth string = do + glyphInfo <- X.xftTextExtents dpy fnt (string ++ "…") + let width = X.xglyphinfo_xOff glyphInfo + if width <= rwidth + then pure (string ++ "…") + else fit' rwidth (init string) extents :: Env -> C -> IO Rect extents Env {..} (C {..}) = do @@ -158,7 +188,7 @@ data Ui' = Ui' [C] deriving (Show, Generic, NFData) data C = C { rect :: Rect, - fill :: Bool, + flex :: Flex, color :: Maybe (P.Intensity, P.Color), string :: String } |