sectile (empty) → 0.1.0.0
raw patch · 31 files changed
+3507/−0 lines, 31 filesdep +aesondep +asyncdep +base
Dependencies added: aeson, async, base, bytestring, dhall, directory, ede, either, hedgehog, hspec, hspec-core, hspec-discover, hspec-hedgehog, lens, lens-regex-pcre, mtl, optics, optics-core, optparse-applicative, pcre-light, process, sectile, text, time, unordered-containers
Files
- LICENSE +15/−0
- app/Convert.hs +223/−0
- app/DhallTypes.hs +189/−0
- app/Main.hs +78/−0
- sectile.cabal +174/−0
- src/Data/Sectile.hs +46/−0
- src/Data/Sectile/Display.hs +296/−0
- src/Data/Sectile/Runners.hs +63/−0
- src/Data/Sectile/Segments.hs +307/−0
- src/Data/Sectile/Style.hs +264/−0
- src/Data/Sectile/System/Linux.hs +31/−0
- src/Data/Sectile/System/Linux/Battery.hs +38/−0
- src/Data/Sectile/System/Linux/Cpu.hs +59/−0
- src/Data/Sectile/System/Linux/Disk.hs +69/−0
- src/Data/Sectile/System/Linux/Internal.hs +99/−0
- src/Data/Sectile/System/Linux/Load.hs +66/−0
- src/Data/Sectile/System/Linux/Memory.hs +70/−0
- src/Data/Sectile/System/Linux/Network.hs +120/−0
- src/Data/Sectile/System/Linux/Thermal.hs +28/−0
- src/Data/Sectile/System/Linux/Uptime.hs +54/−0
- src/Data/Sectile/System/Linux/Wifi.hs +39/−0
- src/Data/Sectile/Themes.hs +243/−0
- src/Data/Sectile/Tmux.hs +190/−0
- src/Data/Sectile/Types.hs +253/−0
- test/Data/Sectile/DisplaySpec.hs +98/−0
- test/Data/Sectile/SegmentsSpec.hs +110/−0
- test/Data/Sectile/StyleSpec.hs +76/−0
- test/Data/Sectile/System/LinuxSpec.hs +64/−0
- test/Data/Sectile/TmuxSpec.hs +38/−0
- test/Data/Sectile/TypesSpec.hs +106/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,15 @@+ISC License++Copyright (c) 2026 Gautier DI FOLCO++Permission to use, copy, modify, and/or distribute this software for any+purpose with or without fee is hereby granted, provided that the above+copyright notice and this permission notice appear in all copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH+REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY+AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,+INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM+LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR+OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR+PERFORMANCE OF THIS SOFTWARE.
+ app/Convert.hs view
@@ -0,0 +1,223 @@+-- |+-- Module : Convert+-- Copyright : Gautier DI FOLCO+-- License : ISC+--+-- Maintainer : Gautier DI FOLCO <foss@difolco.dev>+-- Stability : Stable+-- Portability : Portable+--+-- Convert Dhall DTOs to sectile library types.+module Convert+ ( convertBar,+ )+where++import Control.Concurrent.Async (mapConcurrently)+import Data.Char (isDigit)+import qualified Data.Sectile as Sectile+import qualified Data.Sectile.Display as Display+import qualified Data.Sectile.Style as Style+import qualified Data.Sectile.System.Linux as System+import qualified Data.Sectile.Tmux as Colour+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Word as Word+import qualified DhallTypes as S+import Numeric.Natural (Natural)+import qualified Optics.Core as Optics++-- | Convert a full bar configuration into a list of sectile segments.+convertBar :: S.BarConfig -> [Sectile.Segment IO]+convertBar cfg =+ let groupRows [] = []+ groupRows (x : xs) = case x.row of+ Nothing -> convertNode x : groupRows xs+ Just r ->+ let (rowNodes, rest) = span (\n -> n.row == Just r) (x : xs)+ in Sectile.row mapConcurrently Sectile.Isolating (mkName (T.pack $ "row-" ++ show r)) (map convertNode rowNodes) : groupRows rest+ segs = groupRows cfg.segments+ in case cfg.separator of+ Nothing -> segs+ Just sep ->+ let sepSeg = Sectile.string sep+ in intercalateSeg sepSeg segs++-- | Convert a single segment node.+convertNode :: S.SegmentNode -> Sectile.Segment IO+convertNode cfg =+ let seg = convertSegment cfg.segment+ withStyle = case cfg.style of+ Nothing -> seg+ Just s -> applyStyle s seg+ withDisplay = case cfg.display of+ Nothing -> withStyle+ Just d -> applyDisplay d withStyle+ in withDisplay++-- | Convert a single segment configuration to a library segment.+convertSegment :: S.Segment -> Sectile.Segment IO+convertSegment =+ \case+ S.String {..} ->+ Sectile.string text+ S.Shell {..} ->+ Sectile.sh (mkName name) (T.unpack command) Nothing+ S.Time {..} ->+ Sectile.time (mkName name) (T.unpack format)+ S.Volume {..} ->+ Sectile.volume (mkName name)+ S.Mpris {..} ->+ Sectile.mpris (mkName name)+ S.Git {..} ->+ Sectile.git (mkName name) (T.unpack path)+ S.HttpPoll {..} ->+ Sectile.httpPoll (mkName name) (T.unpack url)+ S.Uptime {..} ->+ System.uptime (mkName name)+ S.Memory {..} ->+ System.memory (mkName name)+ S.Load {..} ->+ System.load (mkName name)+ S.Cpu {..} ->+ System.cpu (mkName name)+ S.Disk {..} ->+ System.disk (mkName name) (T.unpack mountPoint)+ S.NetworkUp {..} ->+ System.networkUp (mkName name) interfaces+ S.NetworkDown {..} ->+ System.networkDown (mkName name) interfaces+ S.Battery {..} ->+ System.battery (mkName name) (T.unpack battery)+ S.Thermal {..} ->+ System.thermal (mkName name) (T.unpack zone)+ S.Wifi {..} ->+ System.wifi (mkName name) (T.unpack interface)++-- | Apply a style configuration to a segment.+applyStyle :: S.StyleConfig -> Sectile.Segment IO -> Sectile.Segment IO+applyStyle cfg seg =+ let parsePercent t =+ case T.splitOn "%" t of+ [] -> Nothing+ [_] -> Nothing+ (xs : _) ->+ let numStr = T.takeWhileEnd (\c -> c == '.' || isDigit c) xs+ in case reads (T.unpack numStr) of+ [(d, "")] -> Just (d / 100.0)+ _ -> Nothing+ parseLoad t =+ case reads (T.unpack t) of+ [(d, _)] -> Just (max 0 (min 1 (d / 4.0)))+ _ -> Nothing++ getParser =+ \case+ "percentage" -> parsePercent+ "load" -> parseLoad+ _ -> const Nothing++ getGradientSource = \case+ S.ParseText p -> Style.parseTextGradient (getParser p)+ S.Scale key -> Style.scaleGradient key+ S.Ratio k1 k2 -> Style.ratioGradient k1 k2++ applyColorConfig optic cfgVal =+ case cfgVal of+ Nothing -> id+ Just (S.Colour c) -> Style.forceStyle (Optics.set optic (Just (convertColour c)))+ Just (S.Gradient (S.GradientConfig f t src)) ->+ let S.ColourRecord r1 g1 b1 = f+ S.ColourRecord r2 g2 b2 = t+ in Style.gradient+ (Optics.set optic . Just)+ (fromIntegral r1, fromIntegral g1, fromIntegral b1)+ (fromIntegral r2, fromIntegral g2, fromIntegral b2)+ (getGradientSource src)++ withFg = applyColorConfig Style.styleForeground cfg.foreground+ withBg = applyColorConfig Style.styleBackground cfg.background++ applyOptic optic converter =+ maybe id (Style.forceStyle . Optics.set optic . Just . converter)++ withBold = case cfg.bold of+ Nothing -> id+ Just True -> Style.forceStyle (Optics.set Style.styleConsoleIntensity (Just Colour.BoldIntensity))+ Just False -> id++ withItalic = applyOptic Style.styleItalic id cfg.italic+ withStrikethrough = applyOptic Style.styleStrikethrough id cfg.strikethrough+ withSwap = applyOptic Style.styleSwapForegroundBackground id cfg.swapForegroundBackground+ withConcealed = applyOptic Style.styleConcealed id cfg.concealed+ withOverlined = applyOptic Style.styleOverlined id cfg.overlined+ withConsoleIntensity = applyOptic Style.styleConsoleIntensity convertConsoleIntensity cfg.consoleIntensity+ withUnderlining = applyOptic Style.styleUnderlining convertUnderlining cfg.underlining+ withBlinking = applyOptic Style.styleBlinking convertBlinking cfg.blinking+ withHyperlink = applyOptic Style.styleHyperlink id cfg.hyperlink+ in withHyperlink $ withBlinking $ withUnderlining $ withConsoleIntensity $ withOverlined $ withConcealed $ withSwap $ withStrikethrough $ withItalic $ withBold $ withBg $ withFg seg++-- | Apply a display transformation to a segment.+applyDisplay :: S.DisplayConfig -> Sectile.Segment IO -> Sectile.Segment IO+applyDisplay =+ \case+ S.NoTransform -> id+ S.TakeStart {..} -> Display.takeStart (fromIntegral width)+ S.TakeEnd {..} -> Display.takeEnd (fromIntegral width)+ S.PadStart {..} -> Display.padStart (fromIntegral width)+ S.PadEnd {..} -> Display.padEnd (fromIntegral width)+ S.FixedSizeStart {..} -> Display.fixedSizeStart (fromIntegral width)+ S.FixedSizeEnd {..} -> Display.fixedSizeEnd (fromIntegral width)+ S.ProgressBar {..} -> Display.progressBar (fromIntegral width)+ S.Marquee {..} -> Display.marquee (fromIntegral width) (fromIntegral tickSeconds)+ S.Reformat {..} -> Sectile.reformat (convertPropagatingStyle propagatingStyle) format++convertPropagatingStyle :: Maybe S.PropagatingStyle -> Sectile.PropagatingStyle+convertPropagatingStyle =+ \case+ Nothing -> Sectile.PropagateInner+ Just s ->+ case s of+ S.Reset -> Sectile.Reset+ S.PropagateIncoming -> Sectile.PropagateIncoming+ S.PropagateInner -> Sectile.PropagateInner++-- | Convert a Dhall colour to a safe-coloured-text colour.+convertColour :: S.Colour -> Colour.Colour+convertColour c = Colour.Colour24Bit (toW8 c.r) (toW8 c.g) (toW8 c.b)+ where+ toW8 :: Natural -> Word.Word8+ toW8 = fromIntegral . min 255++convertConsoleIntensity :: S.ConsoleIntensity -> Colour.ConsoleIntensity+convertConsoleIntensity =+ \case+ S.BoldIntensity -> Colour.BoldIntensity+ S.FaintIntensity -> Colour.FaintIntensity+ S.NormalIntensity -> Colour.NormalIntensity++convertUnderlining :: S.Underlining -> Colour.Underlining+convertUnderlining =+ \case+ S.SingleUnderline -> Colour.SingleUnderline+ S.DoubleUnderline -> Colour.DoubleUnderline+ S.NoUnderline -> Colour.NoUnderline++convertBlinking :: S.Blinking -> Colour.Blinking+convertBlinking =+ \case+ S.SlowBlinking -> Colour.SlowBlinking+ S.RapidBlinking -> Colour.RapidBlinking+ S.NoBlinking -> Colour.NoBlinking++-- | Create a segment name from text.+mkName :: T.Text -> Sectile.Name+mkName = Sectile.Name . T.encodeUtf8Builder++-- | Intersperse a separator segment between segments.+intercalateSeg :: Sectile.Segment IO -> [Sectile.Segment IO] -> [Sectile.Segment IO]+intercalateSeg sep =+ \case+ [] -> []+ [x] -> [x]+ (x : xs) -> x : sep : intercalateSeg sep xs
+ app/DhallTypes.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# OPTIONS_GHC -Wno-partial-fields #-}++-- |+-- Module : DhallTypes+-- Copyright : Gautier DI FOLCO+-- License : ISC+--+-- Maintainer : Gautier DI FOLCO <foss@difolco.dev>+-- Stability : Stable+-- Portability : Portable+--+-- Dhall-compatible DTOs for sectile configuration.+-- These types mirror the sectile library types but derive 'FromDhall'+-- for configuration file parsing.+module DhallTypes+ ( -- * Segment configuration+ Segment (..),+ SegmentNode (..),++ -- * Style configuration+ Colour (..),+ ColourConfig (..),+ ConsoleIntensity (..),+ Underlining (..),+ Blinking (..),+ StyleConfig (..),++ -- * Display configuration+ DisplayConfig (..),+ PropagatingStyle (..),++ -- * Theme configuration+ ThemeName (..),++ -- * Top-level configuration+ BarConfig (..),+ GradientConfig (..),+ GradientSourceConfig (..),+ )+where++import Data.String (IsString)+import Dhall++-- | A colour specified as 24-bit RGB components.+data Colour = ColourRecord+ { r :: Natural,+ g :: Natural,+ b :: Natural+ }+ deriving stock (Eq, Show, Generic)++deriving anyclass instance FromDhall Colour++-- | Data for gradient configuration.+data GradientSourceConfig+ = ParseText {parser :: Text}+ | Scale {key :: Text}+ | Ratio {k1 :: Text, k2 :: Text}+ deriving stock (Eq, Show, Generic)++deriving anyclass instance FromDhall GradientSourceConfig++-- | Gradient rendering configuration: two RGB endpoints and a value source.+data GradientConfig = GradientConfig+ { from :: Colour,+ to :: Colour,+ source :: GradientSourceConfig+ }+ deriving stock (Eq, Show, Generic)++deriving anyclass instance FromDhall GradientConfig++-- | Text emphasis: bold, faint, or normal.+data ConsoleIntensity = BoldIntensity | FaintIntensity | NormalIntensity deriving stock (Eq, Show, Generic)++deriving anyclass instance FromDhall ConsoleIntensity++-- | Underlining style: single, double, or none.+data Underlining = SingleUnderline | DoubleUnderline | NoUnderline deriving stock (Eq, Show, Generic)++deriving anyclass instance FromDhall Underlining++-- | Blinking style: slow, rapid, or none.+data Blinking = SlowBlinking | RapidBlinking | NoBlinking deriving stock (Eq, Show, Generic)++deriving anyclass instance FromDhall Blinking++-- | A segment colour: either a fixed colour or a gradient.+data ColourConfig = Colour Colour | Gradient GradientConfig+ deriving stock (Eq, Show, Generic)++deriving anyclass instance FromDhall ColourConfig++-- | Style configuration for a segment.+data StyleConfig = StyleConfig+ { foreground :: Maybe ColourConfig,+ background :: Maybe ColourConfig,+ bold :: Maybe Bool,+ italic :: Maybe Bool,+ strikethrough :: Maybe Bool,+ swapForegroundBackground :: Maybe Bool,+ concealed :: Maybe Bool,+ overlined :: Maybe Bool,+ consoleIntensity :: Maybe ConsoleIntensity,+ underlining :: Maybe Underlining,+ blinking :: Maybe Blinking,+ hyperlink :: Maybe Text+ }+ deriving stock (Eq, Show, Generic)++deriving anyclass instance FromDhall StyleConfig++-- | Named theme selection.+newtype ThemeName = ThemeName {getThemeName :: Text}+ deriving stock (Generic)+ deriving newtype (Eq, Ord, Show, IsString, FromDhall)++-- | How style propagates between segments: reset to no style, keep the+-- incoming style, or take the style the segment itself set.+data PropagatingStyle+ = Reset+ | PropagateIncoming+ | PropagateInner+ deriving stock (Eq, Show, Generic)++deriving anyclass instance FromDhall PropagatingStyle++-- | Display transformation configuration.+data DisplayConfig+ = NoTransform+ | TakeStart {width :: Natural}+ | TakeEnd {width :: Natural}+ | PadStart {width :: Natural}+ | PadEnd {width :: Natural}+ | FixedSizeStart {width :: Natural}+ | FixedSizeEnd {width :: Natural}+ | ProgressBar {width :: Natural}+ | Marquee {width :: Natural, tickSeconds :: Natural}+ | Reformat {propagatingStyle :: Maybe PropagatingStyle, format :: Text}+ deriving stock (Eq, Show, Generic)++deriving anyclass instance FromDhall DisplayConfig++-- | A segment in the status bar configuration.+data Segment+ = String {text :: Text}+ | Shell {name :: Text, command :: Text}+ | Time {name :: Text, format :: Text}+ | Volume {name :: Text}+ | Mpris {name :: Text}+ | Git {name :: Text, path :: Text}+ | HttpPoll {name :: Text, url :: Text}+ | Uptime {name :: Text}+ | Memory {name :: Text}+ | Load {name :: Text}+ | Cpu {name :: Text}+ | Disk {name :: Text, mountPoint :: Text}+ | NetworkUp {name :: Text, interfaces :: [Text]}+ | NetworkDown {name :: Text, interfaces :: [Text]}+ | Battery {name :: Text, battery :: Text}+ | Thermal {name :: Text, zone :: Text}+ | Wifi {name :: Text, interface :: Text}+ deriving stock (Eq, Show, Generic)++deriving anyclass instance FromDhall Segment++-- | A segment with its styling and display configuration.+data SegmentNode = SegmentNode+ { segment :: Segment,+ style :: Maybe StyleConfig,+ display :: Maybe DisplayConfig,+ row :: Maybe Natural+ }+ deriving stock (Eq, Show, Generic)++deriving anyclass instance FromDhall SegmentNode++-- | Top-level bar configuration.+data BarConfig = BarConfig+ { segments :: [SegmentNode],+ separator :: Maybe Text,+ theme :: Maybe ThemeName+ }+ deriving stock (Eq, Show, Generic)++deriving anyclass instance FromDhall BarConfig
+ app/Main.hs view
@@ -0,0 +1,78 @@+-- |+-- Module : Main+-- Copyright : Gautier DI FOLCO+-- License : ISC+--+-- Maintainer : Gautier DI FOLCO <foss@difolco.dev>+-- Stability : Stable+-- Portability : Portable+module Main (main) where++import Control.Concurrent.Async (mapConcurrently)+import Convert (convertBar)+import qualified Data.ByteString.Builder as B+import qualified Data.Either.Validation as V+import Data.Sectile (ScopingBindings (Isolating), explainSegment, renderSegment, row)+import qualified Data.Sectile.Tmux as Colour+import qualified Data.Text.IO as Text.IO+import qualified Dhall+import qualified Dhall.Core+import DhallTypes (BarConfig)+import Options.Applicative as Options+import System.IO (stdout)++main :: IO ()+main = do+ args <- parseArgs+ case args of+ DumpFormat ->+ case Dhall.expected (Dhall.auto @BarConfig) of+ V.Success result -> Text.IO.putStrLn (Dhall.Core.pretty result)+ V.Failure errors -> print errors+ Render (RenderArgs {..}) -> do+ bar <- Dhall.inputFile (Dhall.auto @BarConfig) configFile+ let segments = convertBar bar+ status = row mapConcurrently Isolating "bar" segments+ output <- renderSegment capabilities status+ B.hPutBuilder stdout output+ putStrLn ""+ Explain (RenderArgs {..}) -> do+ bar <- Dhall.inputFile (Dhall.auto @BarConfig) configFile+ let segments = convertBar bar+ status = row mapConcurrently Isolating "bar" segments+ output <- explainSegment capabilities status+ B.hPutBuilder stdout output+ putStrLn ""++parseArgs :: IO Args+parseArgs =+ customExecParser (prefs showHelpOnEmpty) $+ info (argsParser <**> helper) (fullDesc <> header "sectile: composable status line from Dhall config")+ where+ argsParser :: Parser Args+ argsParser =+ hsubparser+ ( command "dump-dhall-format" (info (pure DumpFormat) (progDesc "Dump Dhall type definition"))+ <> command "render" (info (Render <$> renderP) (progDesc "Render the status bar"))+ <> command "explain" (info (Explain <$> renderP) (progDesc "Explain the status bar configuration"))+ )+ renderP :: Parser RenderArgs+ renderP =+ RenderArgs+ <$> strOption (long "config" <> short 'c' <> metavar "FILE_PATH" <> help "Dhall config file (.dhall)")+ <*> colourFlag+ colourFlag :: Parser Colour.TerminalCapabilities+ colourFlag =+ flag' Colour.With24BitColours (long "24bit-colours" <> help "Use 24-bit true colour")+ <|> flag' Colour.With8BitColours (long "8bit-colours" <> help "Use 8-bit true colour")+ <|> flag' Colour.WithoutColours (long "no-colours" <> help "Disable colours")+ <|> pure Colour.With8Colours++data Args = DumpFormat | Render RenderArgs | Explain RenderArgs+ deriving stock (Eq, Ord, Show)++data RenderArgs = RenderArgs+ { configFile :: FilePath,+ capabilities :: Colour.TerminalCapabilities+ }+ deriving stock (Eq, Ord, Show)
+ sectile.cabal view
@@ -0,0 +1,174 @@+cabal-version: 3.0+name: sectile+version: 0.1.0.0+author: Gautier DI FOLCO+maintainer: foss@difolco.dev+category: Terminal+build-type: Simple+license: ISC+license-file: LICENSE+synopsis: Composable status line builder+description: Composable status line builder.+Homepage: https://github.com/blackheaven/sectile+tested-with: GHC==9.6.6, GHC==9.8.4, GHC==9.10.1, GHC==9.12.1++library+ default-language: Haskell2010+ build-depends:+ base == 4.*+ , aeson == 2.*+ , bytestring == 0.12.*+ , ede >= 0.3.4.0 && < 0.4+ , lens == 5.*+ , lens-regex-pcre == 1.1.*+ , mtl >= 2.3.1 && < 2.4+ , optics == 0.4.*+ , optics-core == 0.4.*+ , pcre-light == 0.4.*+ , process == 1.6.*+ , directory == 1.3.*+ , text == 2.*+ , time >= 1.12 && < 2+ , unordered-containers >= 0.2.20.1 && < 0.3+ hs-source-dirs: src+ exposed-modules:+ Data.Sectile+ Data.Sectile.Display+ Data.Sectile.Runners+ Data.Sectile.Segments+ Data.Sectile.Style+ Data.Sectile.System.Linux+ Data.Sectile.System.Linux.Battery+ Data.Sectile.System.Linux.Cpu+ Data.Sectile.System.Linux.Disk+ Data.Sectile.System.Linux.Internal+ Data.Sectile.System.Linux.Load+ Data.Sectile.System.Linux.Memory+ Data.Sectile.System.Linux.Network+ Data.Sectile.System.Linux.Thermal+ Data.Sectile.System.Linux.Uptime+ Data.Sectile.System.Linux.Wifi+ Data.Sectile.Themes+ Data.Sectile.Tmux+ Data.Sectile.Types+ other-modules:+ Paths_sectile+ autogen-modules:+ Paths_sectile+ default-extensions:+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DeriveGeneric+ DerivingStrategies+ DerivingVia+ DuplicateRecordFields+ FlexibleContexts+ GADTs+ GeneralizedNewtypeDeriving+ KindSignatures+ LambdaCase+ OverloadedStrings+ OverloadedRecordDot+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ TypeApplications+ TypeFamilies+ TypeOperators+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints++test-suite spec+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules:+ Data.Sectile.DisplaySpec+ Data.Sectile.SegmentsSpec+ Data.Sectile.StyleSpec+ Data.Sectile.TmuxSpec+ Data.Sectile.System.LinuxSpec+ Data.Sectile.TypesSpec+ Paths_sectile+ autogen-modules:+ Paths_sectile+ default-extensions:+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DeriveGeneric+ DerivingStrategies+ DerivingVia+ DuplicateRecordFields+ FlexibleContexts+ GADTs+ GeneralizedNewtypeDeriving+ KindSignatures+ LambdaCase+ OverloadedStrings+ OverloadedRecordDot+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ TypeApplications+ TypeFamilies+ TypeOperators+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints+ build-depends:+ base+ , bytestring+ , sectile+ , hedgehog+ , hspec+ , hspec-core+ , hspec-discover+ , hspec-hedgehog+ , mtl+ , aeson+ , unordered-containers+ , optics-core+ , text+ , time+ , pcre-light+ default-language: Haskell2010++executable sectile+ main-is: Main.hs+ hs-source-dirs: app+ other-modules:+ Convert+ DhallTypes+ default-extensions:+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DeriveGeneric+ DerivingStrategies+ DerivingVia+ DuplicateRecordFields+ FlexibleContexts+ GADTs+ GeneralizedNewtypeDeriving+ KindSignatures+ LambdaCase+ OverloadedStrings+ OverloadedRecordDot+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ TypeApplications+ TypeFamilies+ TypeOperators+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints+ build-depends:+ base+ , sectile+ , bytestring+ , dhall == 1.*+ , either == 5.*+ , optparse-applicative+ , text+ , async+ , optics-core++ default-language: Haskell2010
+ src/Data/Sectile.hs view
@@ -0,0 +1,46 @@+-- |+-- Module : Data.Sectile+-- Copyright : Gautier DI FOLCO+-- License : ISC+--+-- Maintainer : Gautier DI FOLCO <foss@difolco.dev>+-- Stability : Stable+-- Portability : Portable+--+-- Composable status line builder.+--+-- @sectile@ lets you compose terminal status lines from reusable segments+-- that can be styled, padded, truncated, and combined.+--+-- Build segments with 'string', 'sh', 'time', or the system monitoring+-- functions from "Data.Sectile.System.Linux". Combine them with 'row' and 'between'.+-- Style them with 'changeStyle', 'forceStyle', and the optics from+-- "Data.Sectile.Style". Control display width with the functions from+-- "Data.Sectile.Display".+--+-- Example:+--+-- > import Data.Sectile+-- > import Data.Sectile.System.Linux+-- > import qualified Data.ByteString.Builder as B+-- > import qualified Data.Sectile.Tmux as Colour+-- >+-- > main :: IO ()+-- > main = do+-- > let status =+-- > row mapM "status" $+-- > between (string " [") (string "] ") $+-- > [ time "clock" "%H:%M",+-- > string " | ",+-- > sh "host" "hostname" Nothing+-- > ]+-- > output <- renderSegment Colour.With8Colours status+-- > B.hPutBuilder stdout output+module Data.Sectile (module X) where++import Data.Sectile.Display as X+import Data.Sectile.Runners as X+import Data.Sectile.Segments as X+import Data.Sectile.Style as X+import Data.Sectile.Themes as X+import Data.Sectile.Types as X
+ src/Data/Sectile/Display.hs view
@@ -0,0 +1,296 @@+-- |+-- Module : Data.Sectile.Display+-- Copyright : Gautier DI FOLCO+-- License : ISC+--+-- Maintainer : Gautier DI FOLCO <foss@difolco.dev>+-- Stability : Stable+-- Portability : Portable+module Data.Sectile.Display+ ( -- * Truncation+ takeStart,+ takeEnd,++ -- * Padding+ padStart,+ padEnd,++ -- * Fixed-size+ fixedSizeStart,+ fixedSizeEnd,++ -- * Regex rewriting+ regex,++ -- * Combinators+ progressBar,+ hideIf,+ marquee,+ )+where++import qualified Control.Lens as Lens+import qualified Control.Lens.Regex.Text as Regex+import qualified Data.Char as Char+import Data.Maybe (listToMaybe)+import qualified Data.Sectile.Tmux as Colour+import Data.Sectile.Types+import qualified Data.Text as T+import qualified Data.Text.Read as T+import qualified Data.Time.Clock.POSIX as Time+import qualified Text.Regex.PCRE.Light as PCRE++-- | Keep only the first @n@ characters of a segment's rendered text.+--+-- Truncates chunks from the end to fit within the character limit.+--+-- Example:+--+-- > import Data.Sectile+-- > import Data.Sectile.Display+-- >+-- > short :: Segment IO -> Segment IO+-- > short = takeStart 10+-- > -- "Hello, world!" becomes "Hello, wor"+takeStart :: (Functor m) => Int -> Segment m -> Segment m+takeStart = transformChunks . chunksStart++-- | Keep only the last @n@ characters of a segment's rendered text.+--+-- Truncates chunks from the start to fit within the character limit.+--+-- Example:+--+-- > import Data.Sectile+-- > import Data.Sectile.Display+-- >+-- > tail5 :: Segment IO -> Segment IO+-- > tail5 = takeEnd 5+-- > -- "Hello, world!" becomes "orld!"+takeEnd :: (Functor m) => Int -> Segment m -> Segment m+takeEnd = transformChunks . chunksEnd++-- | Pad the start of a segment with spaces to reach at least @n@ characters.+--+-- If the segment is already @n@ or more characters, it is unchanged.+--+-- Example:+--+-- > import Data.Sectile+-- > import Data.Sectile.Display+-- >+-- > rightAligned :: Segment IO -> Segment IO+-- > rightAligned = padStart 20+-- > -- "hi" becomes " hi"+padStart :: (Functor m) => Int -> Segment m -> Segment m+padStart n = transformChunks (padChunksStart n)++-- | Pad the end of a segment with spaces to reach at least @n@ characters.+--+-- If the segment is already @n@ or more characters, it is unchanged.+--+-- Example:+--+-- > import Data.Sectile+-- > import Data.Sectile.Display+-- >+-- > leftAligned :: Segment IO -> Segment IO+-- > leftAligned = padEnd 20+-- > -- "hi" becomes "hi "+padEnd :: (Functor m) => Int -> Segment m -> Segment m+padEnd n = transformChunks (padChunksEnd n)++-- | Constrain a segment to exactly @n@ characters, padding at the start+-- or truncating from the end as needed.+--+-- Example:+--+-- > import Data.Sectile+-- > import Data.Sectile.Display+-- >+-- > fixed :: Segment IO -> Segment IO+-- > fixed = fixedSizeStart 10+-- > -- "Hi" becomes " Hi"+-- > -- "Hello, world!" becomes "Hello, wor"+fixedSizeStart :: (Functor m) => Int -> Segment m -> Segment m+fixedSizeStart n = transformChunks (padChunksStart n . chunksStart n)++-- | Constrain a segment to exactly @n@ characters, padding at the end+-- or truncating from the start as needed.+--+-- Example:+--+-- > import Data.Sectile+-- > import Data.Sectile.Display+-- >+-- > fixed :: Segment IO -> Segment IO+-- > fixed = fixedSizeEnd 10+-- > -- "Hi" becomes "Hi "+-- > -- "Hello, world!" becomes "orld!"+fixedSizeEnd :: (Functor m) => Int -> Segment m -> Segment m+fixedSizeEnd n = transformChunks (padChunksEnd n . chunksEnd n)++-- | Apply a PCRE regex replacement to a segment's rendered text.+--+-- Takes a compiled regex and a replacement function.+-- The replacement function receives the matched text and returns+-- the replacement.+--+-- Example:+--+-- > import Data.Sectile+-- > import Data.Sectile.Display+-- > import qualified Text.Regex.PCRE.Light as PCRE+-- >+-- > -- Remove all digits+-- > noDigits :: Segment IO -> Segment IO+-- > noDigits seg =+-- > let pat = PCRE.compile "[0-9]+" []+-- > in regex pat (const "") seg+regex :: (Functor m) => PCRE.Regex -> (T.Text -> T.Text) -> Segment m -> Segment m+regex pat replacement = transformChunks (regexReplace pat replacement)++-- | Convert a numerical segment output into an ASCII progress bar.+--+-- Parses the first sequence of digits from the rendered text and bounds it between 0-100.+-- Replaces the text with a bar of the specified width.+--+-- Example:+--+-- > import Data.Sectile+-- > import Data.Sectile.Display+-- >+-- > batBar :: Segment IO+-- > batBar = progressBar 10 (string "50%")+-- > -- Renders as "[==== ]"+progressBar :: (Functor m) => Int -> Segment m -> Segment m+progressBar width = transformChunks $ \cs ->+ let txt = mconcat $ map Colour.chunkText cs+ digits = T.filter Char.isDigit txt+ parsed = case T.decimal digits of+ Right (n, _) -> n+ Left _ -> 0 :: Int+ pct = max 0 $ min 100 parsed+ filled = (pct * width) `div` 100+ empty = width - filled+ bar = "[" <> T.replicate filled "=" <> T.replicate empty " " <> "]"+ in [Colour.Chunk bar Colour.noStyle]++-- | Conditionally hide a segment if its rendered text matches a predicate.+--+-- Example:+--+-- > import Data.Sectile+-- > import Data.Sectile.Display+-- > import qualified Data.Text as T+-- >+-- > hideEmpty :: Segment IO -> Segment IO+-- > hideEmpty = hideIf T.null+hideIf :: (Functor m) => (T.Text -> Bool) -> Segment m -> Segment m+hideIf p = transformChunks $ \cs ->+ if p (mconcat $ map Colour.chunkText cs) then [] else cs++-- | Scroll a long segment text horizontally over time.+--+-- Takes a fixed width and a number of seconds per tick.+--+-- Example:+--+-- > import Data.Sectile+-- > import Data.Sectile.Display+-- >+-- > scrolling :: Segment IO -> Segment IO+-- > scrolling = marquee 10 1+marquee :: Int -> Int -> Segment IO -> Segment IO+marquee width tickLenSeg (Segment s) = Segment $ do+ now <- Time.getPOSIXTime+ let ticks = floor now `div` tickLenSeg+ runSeg <- s+ pure $ do+ formatted <- runSeg+ let txt = mconcat $ map Colour.chunkText formatted.rendered+ len = T.length txt+ shifted =+ if len <= width+ then txt+ else+ let offset = ticks `mod` len+ padded = txt <> " " <> txt+ in T.take width (T.drop offset padded)+ pure+ formatted+ { rendered = [Colour.Chunk shifted Colour.noStyle],+ explain = \renderSyle renderChunks ->+ formatted.explain renderSyle $ renderChunks . const [Colour.Chunk shifted Colour.noStyle]+ }++-- Internal helpers++-- | Apply a chunk transformation to a segment.+transformChunks :: (Functor m) => ([Colour.Chunk] -> [Colour.Chunk]) -> Segment m -> Segment m+transformChunks f (Segment s) = Segment $ fmap transform s+ where+ transform g = do+ formatted <- g+ pure+ formatted+ { rendered = f formatted.rendered,+ explain = \renderSyle renderChunks ->+ formatted.explain renderSyle $ renderChunks . f+ }++-- | Total width of a list of chunks.+chunksWidth :: [Colour.Chunk] -> Int+chunksWidth = sum . map Colour.chunkWidth++-- | Take the first n characters across chunks.+chunksStart :: Int -> [Colour.Chunk] -> [Colour.Chunk]+chunksStart _ [] = []+chunksStart n _ | n <= 0 = []+chunksStart n (c : cs) =+ let w = Colour.chunkWidth c+ in if w <= n+ then c : chunksStart (n - w) cs+ else [c {Colour.chunkText = T.take n c.chunkText}]++-- | Take the last n characters across chunks.+chunksEnd :: Int -> [Colour.Chunk] -> [Colour.Chunk]+chunksEnd n cs = map reverseChunk $ reverse $ chunksStart n $ reverse $ map reverseChunk cs+ where+ reverseChunk c = c {Colour.chunkText = T.reverse c.chunkText}++-- | Pad chunks at the start with spaces to reach width n.+padChunksStart :: Int -> [Colour.Chunk] -> [Colour.Chunk]+padChunksStart n cs =+ let w = chunksWidth cs+ padding = n - w+ in if padding > 0+ then mkPadChunk padding (firstStyle cs) : cs+ else cs++-- | Pad chunks at the end with spaces to reach width n.+padChunksEnd :: Int -> [Colour.Chunk] -> [Colour.Chunk]+padChunksEnd n cs =+ let w = chunksWidth cs+ padding = n - w+ in if padding > 0+ then cs <> [mkPadChunk padding (firstStyle cs)]+ else cs++-- | Create a padding chunk of n spaces.+mkPadChunk :: Int -> Colour.ChunkStyle -> Colour.Chunk+mkPadChunk n style =+ Colour.Chunk+ { Colour.chunkText = T.replicate n " ",+ Colour.chunkStyle = style+ }++firstStyle :: [Colour.Chunk] -> Colour.ChunkStyle+firstStyle = maybe Colour.noStyle Colour.chunkStyle . listToMaybe++-- | Apply regex replacement to chunk text.+regexReplace :: PCRE.Regex -> (T.Text -> T.Text) -> [Colour.Chunk] -> [Colour.Chunk]+regexReplace pat replacement = map replaceInChunk+ where+ replaceInChunk c =+ c {Colour.chunkText = Lens.over (Regex.regexing pat . Regex.match) replacement c.chunkText}
+ src/Data/Sectile/Runners.hs view
@@ -0,0 +1,63 @@+-- |+-- Module : Data.Sectile.Runners+-- Copyright : Gautier DI FOLCO+-- License : ISC+--+-- Maintainer : Gautier DI FOLCO <foss@difolco.dev>+-- Stability : Stable+-- Portability : Portable+module Data.Sectile.Runners+ ( -- * Runners+ renderSegment,+ explainSegment,+ )+where++import Control.Monad.State (evalState)+import qualified Data.ByteString.Builder as B+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Sectile.Tmux as Colour+import Data.Sectile.Types++-- | Render a segment to a 'B.Builder' using the given terminal capabilities.+--+-- This is the main function for producing terminal output from a segment.+--+-- Example:+--+-- > import Data.Sectile+-- > import qualified Data.ByteString.Builder as B+-- > import qualified Data.Sectile.Tmux as Colour+-- >+-- > main :: IO ()+-- > main = do+-- > output <- renderSegment Colour.With8Colours (string "Hello")+-- > B.hPutBuilder stdout output+renderSegment :: (Functor m) => Colour.TerminalCapabilities -> Segment m -> m B.Builder+renderSegment t s = Colour.renderChunksUtf8BSBuilder t . (.rendered) . (`evalState` Env Colour.noStyle HashMap.empty) <$> s.runSegment++-- | Render an explanation tree for a segment, useful for debugging.+--+-- Produces a tree-formatted explanation of how a segment was built,+-- including types, values, and nested structure.+--+-- Example:+--+-- > import Data.Sectile+-- > import qualified Data.ByteString.Builder as B+-- > import qualified Data.Sectile.Tmux as Colour+-- >+-- > debugSegment :: IO ()+-- > debugSegment = do+-- > output <- explainSegment Colour.With8Colours (string "test")+-- > B.hPutBuilder stdout output+explainSegment :: (Functor m) => Colour.TerminalCapabilities -> Segment m -> m B.Builder+explainSegment t s = withFormat . (`evalState` Env Colour.noStyle HashMap.empty) <$> s.runSegment+ where+ withFormat fmt =+ go 0 $ fmt.explain (Colour.renderChunkStyleUtf8BSBuilder t) (Colour.renderChunksUtf8BSBuilder t)+ go level =+ \case+ DetailPlain x -> mconcat (replicate (2 * level) " ") <> "└──" <> x+ DetailNested x -> go (level + 1) x+ DetailList xs -> foldMap (\x -> go level x <> "\n") xs
+ src/Data/Sectile/Segments.hs view
@@ -0,0 +1,307 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module : Data.Sectile.Segments+-- Copyright : Gautier DI FOLCO+-- License : ISC+--+-- Maintainer : Gautier DI FOLCO <foss@difolco.dev>+-- Stability : Stable+-- Portability : Portable+module Data.Sectile.Segments+ ( -- * Core builders+ string,+ ScopingBindings (..),+ row,+ sh,+ time,+ volume,+ mpris,+ git,+ httpPoll,+ PropagatingStyle (..),+ reformat,+ )+where++import qualified Control.Exception+import Control.Monad (void)+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import Data.Bifunctor (first)+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Lazy as LBS+import qualified Data.HashMap.Strict as HashMap+import qualified Data.List as List+import Data.Maybe (catMaybes, fromMaybe)+import qualified Data.Sectile.Tmux as Colour+import Data.Sectile.Types+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TLE+import qualified Data.Time as Time+import qualified Data.Time.Clock.POSIX as POSIX+import qualified System.Process as Process+import qualified Text.EDE as EDE++-- | Create a pure text segment.+string :: (Applicative m) => T.Text -> Segment m+string txt =+ Segment $+ pure $ do+ currentSt <- currentStyle+ bnds <- currentBindings+ let (finalStyle, rendered) = Colour.parseAnsiChunks currentSt txt+ explain renderStyle renderChunks =+ DetailList $+ [ DetailPlain "Type: string",+ DetailPlain $ "Value: " <> T.encodeUtf8Builder txt,+ DetailPlain $ "Style: " <> fromMaybe "<none>" (renderStyle currentSt) <> " -> " <> fromMaybe "<none>" (renderStyle finalStyle),+ DetailPlain $ "Rendered: " <> renderChunks rendered+ ]+ <> bindingsDetail bnds+ _ <- updateStyle (const finalStyle)+ pure Formatted {..}++-- | Scope or propagate bindings+data ScopingBindings+ = Isolating+ | Propagating+ deriving stock (Eq, Show)++-- | Combine multiple segments into a named row.+row :: (Monad m) => SegmentsRunner m -> ScopingBindings -> Name -> [Segment m] -> Segment m+row runSegments scopingBindings name@(Name nameBuilder) ss =+ Segment $ do+ formattedsM <- runSegments (.runSegment) ss+ pure $ scopeBindings name $ do+ initialBindings <- currentBindings+ let rebindings =+ case scopingBindings of+ Propagating -> pure ()+ Isolating -> void $ updateBindings $ const initialBindings+ formatteds <- mapM (<* rebindings) formattedsM+ let rendered = concatMap (.rendered) formatteds+ explain :: (Colour.ChunkStyle -> Maybe B.Builder) -> ([Colour.Chunk] -> B.Builder) -> Detail B.Builder+ explain renderStyle renderChunks =+ DetailList $+ [ DetailPlain $ "Name: " <> nameBuilder,+ DetailPlain "Type: row",+ DetailPlain $ "Rendered: " <> renderChunks rendered,+ DetailPlain "Details:"+ ]+ <> map (\formatted -> DetailNested $ formatted.explain renderStyle renderChunks) formatteds+ pure Formatted {..}++-- | Run a shell command and capture its stdout as a segment.+sh :: Name -> String -> Maybe [(String, String)] -> Segment IO+sh (Name name) cmd env =+ Segment $ do+ let proc =+ (Process.shell cmd)+ { Process.env = env,+ Process.std_in = Process.CreatePipe,+ Process.std_out = Process.CreatePipe,+ Process.std_err = Process.CreatePipe+ }+ result <- tryReadProcess proc+ let stdout = case result of+ Right out -> T.pack out+ Left _ -> "Error on " <> TL.toStrict (TLE.decodeUtf8 (B.toLazyByteString name))+ pure $ do+ currentSt <- currentStyle+ bnds <- currentBindings+ let (finalStyle, rendered) = Colour.parseAnsiChunks currentSt stdout+ explain renderStyle renderChunks =+ DetailList $+ [ DetailPlain $ "Name: " <> name,+ DetailPlain "Type: sh",+ DetailPlain $ "Command: " <> T.encodeUtf8Builder (T.pack cmd),+ DetailPlain $ "STDOUT: " <> T.encodeUtf8Builder stdout,+ DetailPlain $ "Style: " <> fromMaybe "<none>" (renderStyle currentSt) <> " -> " <> fromMaybe "<none>" (renderStyle finalStyle),+ DetailPlain $ "Rendered: " <> renderChunks rendered+ ]+ <> bindingsDetail bnds+ _ <- updateStyle (const finalStyle)+ pure Formatted {..}++-- | Display the current time formatted with the given format string.+time :: Name -> String -> Segment IO+time (Name name) format =+ Segment $ do+ result <- tryIO $ Time.formatTime Time.defaultTimeLocale format <$> Time.getZonedTime+ posix <- POSIX.getPOSIXTime+ let txt = case result of+ Right t -> T.pack t+ Left _ -> "Error on " <> TL.toStrict (TLE.decodeUtf8 (B.toLazyByteString name))+ let nameT = T.decodeUtf8 (LBS.toStrict (B.toLazyByteString name))+ let generatedBnds = HashMap.singleton (nameT <> ".raw") (Aeson.Number (realToFrac posix))+ pure $ do+ currentSt <- currentStyle+ _ <- appendBindings generatedBnds+ bnds <- currentBindings+ let (finalStyle, rendered) = Colour.parseAnsiChunks currentSt txt+ explain renderStyle renderChunks =+ DetailList $+ [ DetailPlain $ "Name: " <> name,+ DetailPlain "Type: time",+ DetailPlain $ "Format: " <> T.encodeUtf8Builder (T.pack format),+ DetailPlain $ "Formatted: " <> T.encodeUtf8Builder txt,+ DetailPlain $ "Style: " <> fromMaybe "<none>" (renderStyle currentSt) <> " -> " <> fromMaybe "<none>" (renderStyle finalStyle),+ DetailPlain $ "Rendered: " <> renderChunks rendered+ ]+ <> bindingsDetail bnds+ _ <- updateStyle (const finalStyle)+ pure Formatted {..}++-- | Display the current volume using wpctl (Pipewire).+volume :: Name -> Segment IO+volume name = sh name "wpctl get-volume @DEFAULT_AUDIO_SINK@" Nothing++-- | Display the currently playing song via playerctl (MPRIS).+mpris :: Name -> Segment IO+mpris name = sh name "playerctl metadata --format '{{artist}} - {{title}}'" Nothing++-- | Display git branch and status for a specific repository.+git :: Name -> FilePath -> Segment IO+git name path = sh name ("git -C " <> path <> " status --porcelain -b | head -n 1") Nothing++-- | Display the result of polling an HTTP endpoint using curl.+httpPoll :: Name -> String -> Segment IO+httpPoll name url = sh name ("curl -s " <> url) Nothing++-- | Try to read a process, catching any IOException.+tryReadProcess :: Process.CreateProcess -> IO (Either IOError String)+tryReadProcess proc = tryIO (Process.readCreateProcess proc "")++-- | Try an IO action, catching IOExceptions.+tryIO :: IO a -> IO (Either IOError a)+tryIO act = (Right <$> act) `Control.Exception.catch` (pure . Left)++-- | Style propagation for reformatted segments+data PropagatingStyle+ = Reset+ | PropagateIncoming+ | PropagateInner+ deriving stock (Eq, Show)++-- | Reformat a segment's output using an EDE template.+reformat :: (Functor m) => PropagatingStyle -> T.Text -> Segment m -> Segment m+reformat propStyle format (Segment s) = Segment $ fmap transform s+ where+ transform action = do+ oldSt <- currentStyle+ formatted <- action+ innerSt <- currentStyle+ bnds <- currentBindings+ let rawText = mconcat $ map Colour.chunkText formatted.rendered+ styleText =+ T.decodeUtf8 $+ LBS.toStrict $+ B.toLazyByteString $+ Colour.renderChunksUtf8BSBuilder Colour.With24BitColours formatted.rendered++ effectiveIncomingSt = case propStyle of+ Reset -> Colour.noStyle+ PropagateIncoming -> oldSt+ PropagateInner -> innerSt++ incomingStyleText =+ T.replace "#[default]" "" $+ T.decodeUtf8 $+ LBS.toStrict $+ B.toLazyByteString $+ Colour.renderChunksUtf8BSBuilder Colour.With24BitColours [Colour.Chunk "" effectiveIncomingSt]++ styleToObj :: T.Text -> Colour.ChunkStyle -> Aeson.Value+ styleToObj sText st =+ Aeson.toJSON $+ HashMap.fromList $+ [ ("raw" :: T.Text, Aeson.String sText)+ ]+ <> catMaybes+ [ (,) "foreground" . Aeson.String . Colour.renderColour <$> Colour.chunkStyleForeground st,+ (,) "background" . Aeson.String . Colour.renderColour <$> Colour.chunkStyleBackground st,+ (,) "italic" . Aeson.Bool <$> Colour.chunkStyleItalic st,+ (,) "strikethrough" . Aeson.Bool <$> Colour.chunkStyleStrikethrough st,+ (,) "swapForegroundBackground" . Aeson.Bool <$> Colour.chunkStyleSwapForegroundBackground st,+ (,) "concealed" . Aeson.Bool <$> Colour.chunkStyleConcealed st,+ (,) "overlined" . Aeson.Bool <$> Colour.chunkStyleOverlined st,+ (,) "bold" . Aeson.Bool . (== Colour.BoldIntensity) <$> Colour.chunkStyleConsoleIntensity st,+ (,) "dim" . Aeson.Bool . (== Colour.FaintIntensity) <$> Colour.chunkStyleConsoleIntensity st,+ (,) "underlined" . Aeson.Bool . (`elem` [Colour.SingleUnderline, Colour.DoubleUnderline]) <$> Colour.chunkStyleUnderlining st,+ (,) "blink" . Aeson.Bool . (`elem` [Colour.SlowBlinking, Colour.RapidBlinking]) <$> Colour.chunkStyleBlinking st,+ (,) "hyperlink" . Aeson.String <$> Colour.chunkStyleHyperlink st+ ]++ envObj =+ HashMap.fromList+ [ ( "_inner",+ Aeson.toJSON $+ HashMap.fromList+ [ ("raw" :: T.Text, Aeson.String rawText),+ ("style" :: T.Text, styleToObj styleText innerSt)+ ]+ ),+ ( "_incoming",+ Aeson.toJSON $+ HashMap.fromList+ [ ("style" :: T.Text, styleToObj incomingStyleText oldSt)+ ]+ )+ ]++ mergedEnv = HashMap.union envObj bnds++ let explain renderStyle renderChunks =+ DetailList $+ [ DetailPlain "Type: reformat",+ DetailPlain $ "Format: " <> T.encodeUtf8Builder format,+ DetailPlain $ "PropagatingStyle: " <> B.stringUtf8 (show propStyle)+ ]+ <> bindingsDetail mergedEnv+ <> [ DetailPlain "Inner segment:",+ DetailNested $ formatted.explain renderStyle renderChunks+ ]++ case EDE.parse (T.encodeUtf8 format) of+ EDE.Failure err -> do+ let (_errStyle, errRendered) = Colour.parseAnsiChunks Colour.noStyle (T.pack $ show err)+ pure (formatted {rendered = errRendered, explain = explain})+ EDE.Success tmpl -> case EDE.render tmpl (nestify mergedEnv) of+ EDE.Failure err -> do+ let (_errStyle, errRendered) = Colour.parseAnsiChunks Colour.noStyle (T.pack $ show err)+ pure (formatted {rendered = errRendered, explain = explain})+ EDE.Success renderedText -> do+ let (newStyle, newRendered) = Colour.parseAnsiChunks effectiveIncomingSt (TL.toStrict renderedText)+ _ <- updateStyle (const newStyle)+ pure (formatted {rendered = newRendered, explain = explain})++ nestify :: HashMap.HashMap T.Text Aeson.Value -> HashMap.HashMap T.Text Aeson.Value+ nestify flatMap = HashMap.fromList $ map (first Key.toText) $ KeyMap.toList $ List.foldl' insertPath KeyMap.empty (HashMap.toList flatMap)+ where+ insertPath :: KeyMap.KeyMap Aeson.Value -> (T.Text, Aeson.Value) -> KeyMap.KeyMap Aeson.Value+ insertPath obj (key, val) = go obj (T.splitOn "." key) val++ go :: KeyMap.KeyMap Aeson.Value -> [T.Text] -> Aeson.Value -> KeyMap.KeyMap Aeson.Value+ go obj [] _ = obj+ go obj [k] val =+ let k' = Key.fromText k+ in case KeyMap.lookup k' obj of+ Just (Aeson.Object _) ->+ obj+ _ ->+ KeyMap.insert k' val obj+ go obj (k : ks) val =+ let k' = Key.fromText k+ in case KeyMap.lookup k' obj of+ Just (Aeson.Object existingObj) ->+ KeyMap.insert k' (Aeson.Object (go existingObj ks val)) obj+ _ ->+ KeyMap.insert k' (Aeson.Object (go KeyMap.empty ks val)) obj
+ src/Data/Sectile/Style.hs view
@@ -0,0 +1,264 @@+-- |+-- Module : Data.Sectile.Style+-- Copyright : Gautier DI FOLCO+-- License : ISC+--+-- Maintainer : Gautier DI FOLCO <foss@difolco.dev>+-- Stability : Stable+-- Portability : Portable+module Data.Sectile.Style+ ( -- * Style combinators+ between,+ changeStyle,+ forceStyle,++ -- * Style transformations+ resetStyle,+ swapForegroundBackgroundStyle,++ -- * Combinators+ warnIf,+ GradientSource (..),+ parseTextGradient,+ scaleGradient,+ ratioGradient,+ gradient,++ -- * Style optics+ styleItalic,+ styleStrikethrough,+ styleSwapForegroundBackground,+ styleConcealed,+ styleOverlined,+ styleConsoleIntensity,+ styleUnderlining,+ styleBlinking,+ styleForeground,+ styleBackground,+ styleHyperlink,+ )+where++import qualified Data.Aeson as Aeson+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Sectile.Tmux as Colour+import Data.Sectile.Types+import qualified Data.Text as T+import Data.Word (Word8)+import qualified Optics.Core as Optics++-- | Wrap a list of segments between a start and end segment.+--+-- Example:+--+-- > import Data.Sectile+-- >+-- > wrapped :: [Segment IO]+-- > wrapped = between (string "[") (string "]") [string "a", string "b"]+-- > -- Produces: [string "[", string "a", string "b", string "]"]+between :: Segment m -> Segment m -> [Segment m] -> [Segment m]+between start end ss = start : (ss <> [end])++-- | Modify the incoming style before it reaches a segment.+--+-- The style transformation is applied to the style passed *into* the segment,+-- but does not affect the rendered output retroactively.+--+-- Example:+--+-- > import Data.Sectile+-- > import qualified Data.Sectile.Tmux as Colour+-- >+-- > boldSegment :: Segment IO -> Segment IO+-- > boldSegment = changeStyle (\s -> s {Colour.chunkStyleConsoleIntensity = Just Colour.BoldIntensity})+changeStyle :: (Functor m) => (Colour.ChunkStyle -> Colour.ChunkStyle) -> Segment m -> Segment m+changeStyle c (Segment s) = Segment $ fmap transform s+ where+ transform action = do+ _ <- updateStyle c+ action++-- | Force a style transformation on all chunks in a segment's output.+--+-- Unlike 'changeStyle', this modifies every chunk in the rendered output,+-- the final style, and the explanation renderer.+--+-- Example:+--+-- > import Data.Sectile+-- > import qualified Data.Sectile.Tmux as Colour+-- >+-- > makeItalic :: Segment IO -> Segment IO+-- > makeItalic = forceStyle (\s -> s {Colour.chunkStyleItalic = Just True})+forceStyle :: (Functor m) => (Colour.ChunkStyle -> Colour.ChunkStyle) -> Segment m -> Segment m+forceStyle c (Segment s) = Segment $ fmap transform s+ where+ transform action = do+ formatted <- action+ _ <- updateStyle c+ pure+ formatted+ { rendered = updateChunk <$> formatted.rendered,+ explain = \renderSyle renderChunks ->+ formatted.explain renderSyle $ renderChunks . map updateChunk+ }+ updateChunk chunk = chunk {Colour.chunkStyle = c $ Colour.chunkStyle chunk}++-- | Reset a style to the default (no styling).+--+-- Example:+--+-- > import Data.Sectile+-- >+-- > plain :: Segment IO -> Segment IO+-- > plain = changeStyle resetStyle+resetStyle :: Colour.ChunkStyle -> Colour.ChunkStyle+resetStyle = const Colour.noStyle++-- | Swap foreground and background colours in a style.+--+-- Example:+--+-- > import Data.Sectile+-- >+-- > inverted :: Segment IO -> Segment IO+-- > inverted = forceStyle swapForegroundBackgroundStyle+swapForegroundBackgroundStyle :: Colour.ChunkStyle -> Colour.ChunkStyle+swapForegroundBackgroundStyle s =+ s+ { Colour.chunkStyleForeground = Colour.chunkStyleBackground s,+ Colour.chunkStyleBackground = Colour.chunkStyleForeground s+ }++-- | Apply a style if the segment text matches a predicate.+--+-- Example:+--+-- > import Data.Sectile+-- > import Data.Sectile.Style+-- > import qualified Data.Sectile.Tmux as Colour+-- > import qualified Data.Text as T+-- >+-- > alert :: Segment IO -> Segment IO+-- > alert = warnIf (\t -> "Error" `T.isInfixOf` t) (Colour.noStyle {Colour.chunkStyleForeground = Just (Colour.Colour8 Colour.Bright Colour.Red)})+warnIf :: (Functor m) => (T.Text -> Bool) -> Colour.ChunkStyle -> Segment m -> Segment m+warnIf p warnStyle (Segment s) = Segment $ fmap transform s+ where+ transform action = do+ formatted <- action+ let txt = mconcat $ map Colour.chunkText formatted.rendered+ applyWarn c = c {Colour.chunkStyle = warnStyle}+ if p txt+ then+ pure+ formatted+ { rendered = map applyWarn formatted.rendered,+ explain = \renderSyle renderChunks ->+ formatted.explain renderSyle $ renderChunks . map applyWarn+ }+ else pure formatted++-- | A source of gradient input: extracts a value from the segment+-- bindings or the rendered text.+newtype GradientSource = GradientSource (HashMap.HashMap T.Text Aeson.Value -> T.Text -> Maybe Double)++-- | Build a 'GradientSource' by parsing the segment's rendered text.+parseTextGradient :: (T.Text -> Maybe Double) -> GradientSource+parseTextGradient f = GradientSource $ \_ txt -> f txt++-- | Build a 'GradientSource' from a numeric binding stored under @key@.+scaleGradient :: T.Text -> GradientSource+scaleGradient key = GradientSource $ \bnds _ ->+ case HashMap.lookup key bnds of+ Just (Aeson.Number n) -> Just (realToFrac n)+ _ -> Nothing++-- | Build a 'GradientSource' from the ratio of two numeric bindings.+ratioGradient :: T.Text -> T.Text -> GradientSource+ratioGradient k1 k2 = GradientSource $ \bnds _ ->+ case (HashMap.lookup k1 bnds, HashMap.lookup k2 bnds) of+ (Just (Aeson.Number n1), Just (Aeson.Number n2)) | n2 /= 0 -> Just (realToFrac (n1 / n2))+ _ -> Nothing++-- | Apply a color gradient based on a parsed value.+gradient ::+ (Functor m) =>+ (Colour.Colour -> Colour.ChunkStyle -> Colour.ChunkStyle) ->+ (Word8, Word8, Word8) ->+ (Word8, Word8, Word8) ->+ GradientSource ->+ Segment m ->+ Segment m+gradient applyColor (r1, g1, b1) (r2, g2, b2) source (Segment s) =+ Segment $ fmap transform s+ where+ transform action = do+ formatted <- action+ bnds <- currentBindings+ let txt = mconcat $ map Colour.chunkText formatted.rendered+ let GradientSource gradFn = source+ let mPct = gradFn bnds txt+ case mPct of+ Just pct -> do+ let p = max 0 (min 1 pct)+ r = round $ fromIntegral r1 * (1 - p) + fromIntegral r2 * p+ g = round $ fromIntegral g1 * (1 - p) + fromIntegral g2 * p+ b = round $ fromIntegral b1 * (1 - p) + fromIntegral b2 * p+ col = Colour.Colour24Bit r g b+ applyGrad = applyColor col+ _ <- updateStyle applyGrad+ let applyGradChunk chunk =+ chunk+ { Colour.chunkStyle = applyGrad $ Colour.chunkStyle chunk+ }+ pure+ formatted+ { rendered = map applyGradChunk formatted.rendered,+ explain = \renderSyle renderChunks ->+ formatted.explain renderSyle $ renderChunks . map applyGradChunk+ }+ Nothing -> pure formatted++-- | Lens for the italic flag of a 'Colour.ChunkStyle'.+styleItalic :: Optics.Lens' Colour.ChunkStyle (Maybe Bool)+styleItalic = Optics.lens Colour.chunkStyleItalic (\s a -> s {Colour.chunkStyleItalic = a})++-- | Lens for the strikethrough flag of a 'Colour.ChunkStyle'.+styleStrikethrough :: Optics.Lens' Colour.ChunkStyle (Maybe Bool)+styleStrikethrough = Optics.lens Colour.chunkStyleStrikethrough (\s a -> s {Colour.chunkStyleStrikethrough = a})++-- | Lens for the swap-foreground-background flag of a 'Colour.ChunkStyle'.+styleSwapForegroundBackground :: Optics.Lens' Colour.ChunkStyle (Maybe Bool)+styleSwapForegroundBackground = Optics.lens Colour.chunkStyleSwapForegroundBackground (\s a -> s {Colour.chunkStyleSwapForegroundBackground = a})++-- | Lens for the concealed flag of a 'Colour.ChunkStyle'.+styleConcealed :: Optics.Lens' Colour.ChunkStyle (Maybe Bool)+styleConcealed = Optics.lens Colour.chunkStyleConcealed (\s a -> s {Colour.chunkStyleConcealed = a})++-- | Lens for the overlined flag of a 'Colour.ChunkStyle'.+styleOverlined :: Optics.Lens' Colour.ChunkStyle (Maybe Bool)+styleOverlined = Optics.lens Colour.chunkStyleOverlined (\s a -> s {Colour.chunkStyleOverlined = a})++-- | Lens for the console intensity of a 'Colour.ChunkStyle'.+styleConsoleIntensity :: Optics.Lens' Colour.ChunkStyle (Maybe Colour.ConsoleIntensity)+styleConsoleIntensity = Optics.lens Colour.chunkStyleConsoleIntensity (\s a -> s {Colour.chunkStyleConsoleIntensity = a})++-- | Lens for the underlining of a 'Colour.ChunkStyle'.+styleUnderlining :: Optics.Lens' Colour.ChunkStyle (Maybe Colour.Underlining)+styleUnderlining = Optics.lens Colour.chunkStyleUnderlining (\s a -> s {Colour.chunkStyleUnderlining = a})++-- | Lens for the blinking of a 'Colour.ChunkStyle'.+styleBlinking :: Optics.Lens' Colour.ChunkStyle (Maybe Colour.Blinking)+styleBlinking = Optics.lens Colour.chunkStyleBlinking (\s a -> s {Colour.chunkStyleBlinking = a})++-- | Lens for the foreground colour of a 'Colour.ChunkStyle'.+styleForeground :: Optics.Lens' Colour.ChunkStyle (Maybe Colour.Colour)+styleForeground = Optics.lens Colour.chunkStyleForeground (\s a -> s {Colour.chunkStyleForeground = a})++-- | Lens for the background colour of a 'Colour.ChunkStyle'.+styleBackground :: Optics.Lens' Colour.ChunkStyle (Maybe Colour.Colour)+styleBackground = Optics.lens Colour.chunkStyleBackground (\s a -> s {Colour.chunkStyleBackground = a})++-- | Lens for the hyperlink URL of a 'Colour.ChunkStyle'.+styleHyperlink :: Optics.Lens' Colour.ChunkStyle (Maybe T.Text)+styleHyperlink = Optics.lens Colour.chunkStyleHyperlink (\s a -> s {Colour.chunkStyleHyperlink = a})
+ src/Data/Sectile/System/Linux.hs view
@@ -0,0 +1,31 @@+-- |+-- Module : Data.Sectile.System.Linux+-- Copyright : Gautier DI FOLCO+-- License : ISC+--+-- Maintainer : Gautier DI FOLCO <foss@difolco.dev>+-- Stability : Stable+-- Portability : Portable+module Data.Sectile.System.Linux+ ( uptime,+ memory,+ load,+ cpu,+ disk,+ networkUp,+ networkDown,+ battery,+ thermal,+ wifi,+ )+where++import Data.Sectile.System.Linux.Battery+import Data.Sectile.System.Linux.Cpu+import Data.Sectile.System.Linux.Disk+import Data.Sectile.System.Linux.Load+import Data.Sectile.System.Linux.Memory+import Data.Sectile.System.Linux.Network+import Data.Sectile.System.Linux.Thermal+import Data.Sectile.System.Linux.Uptime+import Data.Sectile.System.Linux.Wifi
+ src/Data/Sectile/System/Linux/Battery.hs view
@@ -0,0 +1,38 @@+-- |+-- Module : Data.Sectile.System.Linux.Battery+-- Copyright : Gautier DI FOLCO+-- License : ISC+--+-- Maintainer : Gautier DI FOLCO <foss@difolco.dev>+-- Stability : Stable+-- Portability : Portable+module Data.Sectile.System.Linux.Battery (battery) where++import qualified Data.HashMap.Strict as HashMap+import Data.Sectile.System.Linux.Internal+import Data.Sectile.Types+import qualified Data.Text as T++-- | Display battery capacity and status by reading @\/sys\/class\/power_supply\/BAT*@.+battery :: Name -> String -> Segment IO+battery name@(Name nameB) bat =+ Segment $ do+ capRes <- tryReadFile ("/sys/class/power_supply/" <> bat <> "/capacity")+ statRes <- tryReadFile ("/sys/class/power_supply/" <> bat <> "/status")+ let (txt, bnds) = case (capRes, statRes) of+ (Right cap, Right stat) ->+ let capT = T.strip cap+ statT = T.strip stat+ prefix = case statT of+ "Charging" -> "CHG"+ "Discharging" -> "BAT"+ "Full" -> "FULL"+ _ -> "UNK"+ val = case readDouble capT of+ Just v -> v / 100+ Nothing -> 0+ in (prefix <> " " <> capT <> "%", percentBindings name val)+ _ -> (errMsg nameB, HashMap.empty)+ pure $ do+ _ <- appendBindings bnds+ mkFormatted nameB "battery" txt [("Battery", T.pack bat)]
+ src/Data/Sectile/System/Linux/Cpu.hs view
@@ -0,0 +1,59 @@+-- |+-- Module : Data.Sectile.System.Linux.Cpu+-- Copyright : Gautier DI FOLCO+-- License : ISC+--+-- Maintainer : Gautier DI FOLCO <foss@difolco.dev>+-- Stability : Stable+-- Portability : Portable+module Data.Sectile.System.Linux.Cpu (cpu) where++import qualified Data.Aeson as Aeson+import qualified Data.HashMap.Strict as HashMap+import Data.Maybe (mapMaybe)+import Data.Sectile.System.Linux.Internal+import Data.Sectile.Types+import qualified Data.Text as T++-- | Display CPU usage percentage by reading @\/proc\/stat@.+--+-- Shows the aggregate CPU usage as a percentage.+--+-- Example:+--+-- > import Data.Sectile+-- >+-- > cpuSegment :: Segment IO+-- > cpuSegment = cpu "cpu"+-- > -- Renders e.g. "5.6%"+cpu :: Name -> Segment IO+cpu name@(Name nameB) =+ Segment $ do+ result <- tryReadFile "/proc/stat"+ let (txt, bnds) = case result of+ Right content ->+ case parseCpuUsage name content of+ Just (formatted, b) -> (formatted, b)+ Nothing -> (errMsg nameB, HashMap.empty)+ Left _ -> (errMsg nameB, HashMap.empty)+ pure $ do+ _ <- appendBindings bnds+ mkFormatted nameB "cpu" txt []++-- | Parse /proc/stat cpu line to get usage percentage.+parseCpuUsage :: Name -> T.Text -> Maybe (T.Text, HashMap.HashMap T.Text Aeson.Value)+parseCpuUsage name content =+ let lns = T.lines content+ in case filter (T.isPrefixOf "cpu ") lns of+ (cpuLine : _) ->+ let ws = drop 1 $ T.words cpuLine+ nums = mapMaybe readDouble ws+ in case nums of+ (user : nice : system : idle : iowait : irq : softirq : steal : _) ->+ let total = user + nice + system + idle + iowait + irq + softirq + steal+ busy = total - idle - iowait+ pct = busy / total+ bnds = percentBindings name pct+ in Just (T.pack (showFFloat1 (pct * 100)) <> "%", bnds)+ _ -> Nothing+ _ -> Nothing
+ src/Data/Sectile/System/Linux/Disk.hs view
@@ -0,0 +1,69 @@+-- |+-- Module : Data.Sectile.System.Linux.Disk+-- Copyright : Gautier DI FOLCO+-- License : ISC+--+-- Maintainer : Gautier DI FOLCO <foss@difolco.dev>+-- Stability : Stable+-- Portability : Portable+module Data.Sectile.System.Linux.Disk (disk) where++import qualified Data.Aeson as Aeson+import qualified Data.HashMap.Strict as HashMap+import Data.Sectile.System.Linux.Internal+import Data.Sectile.Types+import qualified Data.Text as T+import qualified System.Exit as Exit+import qualified System.Process as Process++-- | Display disk usage for a given mount point.+--+-- Uses 'System.Process' to call @df@.+--+-- Shows used, total, and percentage, e.g. @"\/" 450GiB (88%)@.+--+-- Example:+--+-- > import Data.Sectile+-- >+-- > diskSegment :: Segment IO+-- > diskSegment = disk "disk" "/"+-- > -- Renders e.g. "\/ 1.5TiB / 1.8TiB (88%)"+disk :: Name -> FilePath -> Segment IO+disk name@(Name nameB) mountPoint =+ Segment $ do+ (exitCode, out, _) <- Process.readProcessWithExitCode "df" ["--output=size,used,avail,pcent", "-B1024", mountPoint] ""+ let (txt, bnds) = case exitCode of+ Exit.ExitSuccess ->+ case parseDiskUsage name (T.pack out) of+ Just (formatted, b) -> (formatted, b)+ Nothing -> (errMsg nameB, HashMap.empty)+ _ -> (errMsg nameB, HashMap.empty)+ pure $ do+ _ <- appendBindings bnds+ mkFormatted nameB "disk" txt [("MountPoint", T.pack mountPoint)]++-- | Parse disk usage from df --output=size,used,avail,pcent -B1024 output.+parseDiskUsage :: Name -> T.Text -> Maybe (T.Text, HashMap.HashMap T.Text Aeson.Value)+parseDiskUsage (Name nameB) content =+ let lns = T.lines content+ in case lns of+ (_ : dataLine : _) ->+ case T.words dataLine of+ (sizeT : usedT : availT : _pcentT : _) ->+ case (readDouble sizeT, readDouble usedT, readDouble availT) of+ (Just sizeKB, Just usedKB, Just availKB) ->+ let size = sizeKB * 1024+ used = usedKB * 1024+ avail = availKB * 1024+ bnds =+ unitBindings "B" (Name (nameB <> ".total")) size+ <> unitBindings "B" (Name (nameB <> ".used.total")) used+ <> percentBindings (Name (nameB <> ".used")) (used / size)+ <> unitBindings "B" (Name (nameB <> ".free.total")) avail+ <> percentBindings (Name (nameB <> ".free")) (avail / size)+ txt = formatKiB (round availKB) <> " (" <> T.pack (show (round (avail / size * 100) :: Int)) <> "%)"+ in Just (txt, bnds)+ _ -> Nothing+ _ -> Nothing+ _ -> Nothing
+ src/Data/Sectile/System/Linux/Internal.hs view
@@ -0,0 +1,99 @@+-- |+-- Module : Data.Sectile.System.Linux.Internal+-- Copyright : Gautier DI FOLCO+-- License : ISC+--+-- Maintainer : Gautier DI FOLCO <foss@difolco.dev>+-- Stability : Stable+-- Portability : Portable+module Data.Sectile.System.Linux.Internal+ ( errMsg,+ mkFormatted,+ tryReadFile,+ tryWriteFile,+ formatKiB,+ showFFloat1,+ readInt,+ readDouble,+ )+where++import qualified Control.Exception as Exception+import Control.Monad.State (State)+import qualified Data.ByteString.Builder as B+import Data.Maybe (fromMaybe)+import qualified Data.Sectile.Tmux as Colour+import Data.Sectile.Types+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TLE+import qualified Data.Text.Read as T+import Numeric (showFFloat)++-- Internal helpers++-- | Build an error message from a segment name.+errMsg :: B.Builder -> T.Text+errMsg name = "Error on " <> TL.toStrict (TLE.decodeUtf8 (B.toLazyByteString name))++-- | Build a 'Formatted' value with standard explain structure.+mkFormatted :: B.Builder -> T.Text -> T.Text -> [(T.Text, T.Text)] -> State Env Formatted+mkFormatted name typeName txt extraFields = do+ currentSt <- currentStyle+ bnds <- currentBindings+ let (finalStyle, rendered) = Colour.parseAnsiChunks currentSt txt+ explain renderStyle renderChunks =+ DetailList $+ [ DetailPlain $ "Name: " <> name,+ DetailPlain $ "Type: " <> T.encodeUtf8Builder typeName,+ DetailPlain $ "Value: " <> T.encodeUtf8Builder txt,+ DetailPlain $ "Style: " <> fromMaybe "<none>" (renderStyle currentSt) <> " -> " <> fromMaybe "<none>" (renderStyle finalStyle),+ DetailPlain $ "Rendered: " <> renderChunks rendered+ ]+ <> map (\(k, v) -> DetailPlain $ T.encodeUtf8Builder k <> ": " <> T.encodeUtf8Builder v) extraFields+ <> bindingsDetail bnds+ _ <- updateStyle (const finalStyle)+ pure Formatted {..}++-- | Try to read a file, catching any IOException.+tryReadFile :: FilePath -> IO (Either IOError T.Text)+tryReadFile path =+ (Right . T.pack <$> readFile path)+ `Exception.catch` (\(e :: IOError) -> pure $ Left e)++-- | Try to write a file, catching any IOException.+tryWriteFile :: FilePath -> T.Text -> IO (Either IOError ())+tryWriteFile path content =+ (Right <$> writeFile path (T.unpack content))+ `Exception.catch` (\(e :: IOError) -> pure $ Left e)++-- | Format kibibytes to human-readable.+formatKiB :: Int -> T.Text+formatKiB kb+ | kb >= 1024 ^ (4 :: Int) = T.pack (showFFloat1 (fromIntegral kb / (1024.0 ** 4) :: Double)) <> "EiB"+ | kb >= 1024 ^ (3 :: Int) = T.pack (showFFloat1 (fromIntegral kb / (1024.0 ** 3) :: Double)) <> "TiB"+ | kb >= 1024 ^ (2 :: Int) = T.pack (showFFloat1 (fromIntegral kb / (1024.0 ** 2) :: Double)) <> "GiB"+ | kb >= 1024 = T.pack (showFFloat1 (fromIntegral kb / 1024.0 :: Double)) <> "MiB"+ | otherwise = T.pack (show kb) <> "KiB"++-- | Show a Double with 1 decimal place.+showFFloat1 :: Double -> String+showFFloat1 x = showFFloat (Just n) x ""+ where+ n+ | abs x >= 100 = 0+ | abs x >= 10 = 1+ | otherwise = 2++-- | Read an Int from Text, returning Nothing on failure.+readInt :: T.Text -> Maybe Int+readInt t = case T.decimal t of+ Right (n, _) -> Just n+ Left _ -> Nothing++-- | Read a Double from Text, returning Nothing on failure.+readDouble :: T.Text -> Maybe Double+readDouble t = case T.double t of+ Right (n, _) -> Just n+ Left _ -> Nothing
+ src/Data/Sectile/System/Linux/Load.hs view
@@ -0,0 +1,66 @@+-- |+-- Module : Data.Sectile.System.Linux.Load+-- Copyright : Gautier DI FOLCO+-- License : ISC+--+-- Maintainer : Gautier DI FOLCO <foss@difolco.dev>+-- Stability : Stable+-- Portability : Portable+module Data.Sectile.System.Linux.Load (load) where++import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Lazy as LBS+import qualified Data.HashMap.Strict as HashMap+import Data.Sectile.System.Linux.Internal+import Data.Sectile.Types+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import GHC.Conc (getNumProcessors)++-- | Display system load averages by reading @\/proc\/loadavg@.+--+-- Shows the 1, 5, and 15 minute load averages.+--+-- Example:+--+-- > import Data.Sectile+-- >+-- > loadSegment :: Segment IO+-- > loadSegment = load "load"+-- > -- Renders e.g. "1.59 1.29 1.39"+load :: Name -> Segment IO+load name@(Name nameB) =+ Segment $ do+ result <- tryReadFile "/proc/loadavg"+ threads <- getNumProcessors+ let (txt, bnds) = case result of+ Right content ->+ case parseLoadavg threads name content of+ Just (formatted, b) -> (formatted, b)+ Nothing -> (errMsg nameB, HashMap.empty)+ Left _ -> (errMsg nameB, HashMap.empty)+ pure $ do+ _ <- appendBindings bnds+ mkFormatted nameB "load" txt []++-- | Parse /proc/loadavg: "1.59 1.29 1.39 3/4059 665034" -> "1.59 1.29 1.39"+parseLoadavg :: Int -> Name -> T.Text -> Maybe (T.Text, HashMap.HashMap T.Text Aeson.Value)+parseLoadavg threads (Name nameB) content =+ let ws = T.words (T.strip content)+ in case ws of+ (l1 : l5 : l15 : _) ->+ case (readDouble l1, readDouble l5, readDouble l15) of+ (Just n1, Just n5, Just n15) ->+ let txt = l1 <> " " <> l5 <> " " <> l15+ nameT = T.decodeUtf8 (LBS.toStrict (B.toLazyByteString nameB))+ bnds =+ HashMap.fromList+ [ (nameT <> ".1m.raw", Aeson.Number (realToFrac n1)),+ (nameT <> ".5m.raw", Aeson.Number (realToFrac n5)),+ (nameT <> ".15m.raw", Aeson.Number (realToFrac n15)),+ (nameT <> ".threads", Aeson.Number (fromIntegral threads))+ ]+ in Just (txt, bnds)+ _ -> Nothing+ _ -> Nothing
+ src/Data/Sectile/System/Linux/Memory.hs view
@@ -0,0 +1,70 @@+-- |+-- Module : Data.Sectile.System.Linux.Memory+-- Copyright : Gautier DI FOLCO+-- License : ISC+--+-- Maintainer : Gautier DI FOLCO <foss@difolco.dev>+-- Stability : Stable+-- Portability : Portable+module Data.Sectile.System.Linux.Memory (memory) where++import qualified Data.Aeson as Aeson+import qualified Data.HashMap.Strict as HashMap+import Data.Sectile.System.Linux.Internal+import Data.Sectile.Types+import qualified Data.Text as T+import qualified Data.Text.Read as T++-- | Display memory usage by reading @\/proc\/meminfo@.+--+-- Shows used and total memory in human-readable format, e.g. @"8.2GiB / 15.6GiB (52%)"@.+--+-- Example:+--+-- > import Data.Sectile+-- >+-- > memSegment :: Segment IO+-- > memSegment = memory "mem"+-- > -- Renders e.g. "8.2GiB / 15.6GiB (52%)"+memory :: Name -> Segment IO+memory name@(Name nameB) =+ Segment $ do+ result <- tryReadFile "/proc/meminfo"+ let (txt, bnds) = case result of+ Right content ->+ case parseMeminfo name content of+ Just (formatted, b) -> (formatted, b)+ Nothing -> (errMsg nameB, HashMap.empty)+ Left _ -> (errMsg nameB, HashMap.empty)+ pure $ do+ _ <- appendBindings bnds+ mkFormatted nameB "memory" txt []++-- | Parse /proc/meminfo to extract MemTotal, MemAvailable.+parseMeminfo :: Name -> T.Text -> Maybe (T.Text, HashMap.HashMap T.Text Aeson.Value)+parseMeminfo (Name nameB) content =+ let lns = T.lines content+ findField key = case filter (T.isPrefixOf key) lns of+ (l : _) -> case T.decimal (T.strip $ T.drop 1 $ T.dropWhile (/= ':') l) of+ Right (kb :: Int, _) -> Just kb+ Left _ -> Nothing+ [] -> Nothing+ in case (findField "MemTotal:", findField "MemAvailable:") of+ (Just totalKB, Just availKB) ->+ let total = fromIntegral totalKB * 1024 :: Double+ avail = fromIntegral availKB * 1024 :: Double+ used = total - avail+ pct = used / total+ bnds =+ unitBindings "B" (Name (nameB <> ".total")) total+ <> unitBindings "B" (Name (nameB <> ".used.total")) used+ <> percentBindings (Name (nameB <> ".used")) pct+ <> unitBindings "B" (Name (nameB <> ".free.total")) avail+ <> percentBindings (Name (nameB <> ".free")) (avail / total)+ txt =+ T.pack (show (round (used / (1024 * 1024 * 1024)) :: Int))+ <> " GiB ("+ <> T.pack (show (round (pct * 100) :: Int))+ <> "%)"+ in Just (txt, bnds)+ _ -> Nothing
+ src/Data/Sectile/System/Linux/Network.hs view
@@ -0,0 +1,120 @@+-- |+-- Module : Data.Sectile.System.Linux.Network+-- Copyright : Gautier DI FOLCO+-- License : ISC+--+-- Maintainer : Gautier DI FOLCO <foss@difolco.dev>+-- Stability : Stable+-- Portability : Portable+module Data.Sectile.System.Linux.Network+ ( networkStats,+ networkUp,+ networkDown,+ parseNetDevBytes,+ NetDirection (..),+ )+where++import qualified Control.Exception as Exception+import qualified Data.ByteString.Builder as B+import Data.Maybe (mapMaybe)+import Data.Sectile.System.Linux.Internal+import Data.Sectile.Types+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TLE+import qualified Data.Time.Clock.POSIX as POSIX+import qualified System.Directory as Dir+import qualified System.Exit as Exit+import qualified System.Process as Process++-- | Display network speed for a given list of interfaces.+networkStats :: Name -> [T.Text] -> NetDirection -> Segment IO+networkStats name@(Name nameB) ifaces direction = Segment $ do+ contentRes <- tryReadFile "/proc/net/dev"+ case contentRes of+ Left _ -> pure $ mkFormatted nameB typeName (errMsg nameB) []+ Right content -> do+ let statsList = mapMaybe (\iface -> parseNetDevBytes iface direction content) ifaces+ case statsList of+ [] -> pure $ mkFormatted nameB typeName (errMsg nameB) []+ _ -> do+ let totalBytes = sum statsList+ now <- POSIX.getPOSIXTime+ let nowMs = round (now * 1000) :: Int++ sessionOutRes <-+ (Right <$> Process.readProcessWithExitCode "tmux" ["display-message", "-p", "#S"] "")+ `Exception.catch` (\(_ :: IOError) -> pure $ Left ())+ let session = case sessionOutRes of+ Right (Exit.ExitSuccess, out, _) -> T.unpack (T.strip (T.pack out))+ _ -> "default"++ let segName = T.unpack $ TL.toStrict $ TLE.decodeUtf8 $ B.toLazyByteString nameB+ let memFile = "/tmp/tmux-net-speeds-mem-" <> session <> "-" <> segName++ fileExists <- Dir.doesFileExist memFile+ rate <-+ if fileExists+ then do+ fileContent <- tryReadFile memFile+ case fileContent of+ Right fc -> do+ case T.words (T.strip fc) of+ [tsStr, bytesStr] -> do+ case (readInt tsStr, readInt bytesStr) of+ (Just tsPrev, Just bytesPrev) -> do+ let dt = nowMs - tsPrev+ if dt > 0+ then pure $ Just $ (totalBytes - bytesPrev) * 1000 `div` dt+ else pure Nothing+ _ -> pure Nothing+ _ -> pure Nothing+ Left _ -> pure Nothing+ else pure Nothing++ _ <- tryWriteFile memFile (T.pack (show nowMs) <> " " <> T.pack (show totalBytes))++ let (txt, bnds) = case rate of+ Just r -> (formatKiB (r `div` 1024) <> "/s", unitBindings "B/s" name (fromIntegral r))+ Nothing -> (" - B/s", unitBindings "B/s" name 0)++ pure $ do+ _ <- appendBindings bnds+ mkFormatted nameB typeName txt [("Interfaces", T.intercalate "," ifaces)]+ where+ typeName = case direction of+ NetTransmit -> "networkUp"+ NetReceive -> "networkDown"++-- | Display network upload speed for a given list of interfaces.+networkUp :: Name -> [T.Text] -> Segment IO+networkUp name ifaces = networkStats name ifaces NetTransmit++-- | Display network download speed for a given list of interfaces.+networkDown :: Name -> [T.Text] -> Segment IO+networkDown name ifaces = networkStats name ifaces NetReceive++-- | Parse /proc/net/dev for a specific interface returning bytes.+parseNetDevBytes :: T.Text -> NetDirection -> T.Text -> Maybe Int+parseNetDevBytes iface direction content =+ let lns = T.lines content+ ifacePrefix = T.strip iface <> ":"+ matchLine l =+ let stripped = T.stripStart l+ in T.isPrefixOf ifacePrefix stripped+ in case filter matchLine lns of+ (l : _) ->+ let parts = T.words $ T.drop (T.length ifacePrefix) $ T.stripStart l+ -- Receive: bytes(0) packets(1) ...+ -- Transmit: bytes(8) packets(9) ...+ idx = case direction of+ NetReceive -> 0+ NetTransmit -> 8+ in case drop idx parts of+ (val : _) -> readInt val+ _ -> Nothing+ _ -> Nothing++-- | Direction of network traffic: received (download) or transmitted (upload).+data NetDirection = NetReceive | NetTransmit
+ src/Data/Sectile/System/Linux/Thermal.hs view
@@ -0,0 +1,28 @@+-- |+-- Module : Data.Sectile.System.Linux.Thermal+-- Copyright : Gautier DI FOLCO+-- License : ISC+--+-- Maintainer : Gautier DI FOLCO <foss@difolco.dev>+-- Stability : Stable+-- Portability : Portable+module Data.Sectile.System.Linux.Thermal (thermal) where++import qualified Data.HashMap.Strict as HashMap+import Data.Sectile.System.Linux.Internal+import Data.Sectile.Types+import qualified Data.Text as T++-- | Display system temperature by reading @\/sys\/class\/thermal\/thermal_zone*\/temp@.+thermal :: Name -> String -> Segment IO+thermal name@(Name nameB) zone =+ Segment $ do+ res <- tryReadFile ("/sys/class/thermal/" <> zone <> "/temp")+ let (txt, bnds) = case res of+ Right tempStr -> case readDouble (T.strip tempStr) of+ Just temp -> (T.pack (show (round (temp / 1000) :: Int)) <> "C", unitBindings "C" name (temp / 1000))+ Nothing -> (errMsg nameB, HashMap.empty)+ Left _ -> (errMsg nameB, HashMap.empty)+ pure $ do+ _ <- appendBindings bnds+ mkFormatted nameB "thermal" txt [("Zone", T.pack zone)]
+ src/Data/Sectile/System/Linux/Uptime.hs view
@@ -0,0 +1,54 @@+-- |+-- Module : Data.Sectile.System.Linux.Uptime+-- Copyright : Gautier DI FOLCO+-- License : ISC+--+-- Maintainer : Gautier DI FOLCO <foss@difolco.dev>+-- Stability : Stable+-- Portability : Portable+module Data.Sectile.System.Linux.Uptime (uptime) where++import qualified Data.Aeson as Aeson+import qualified Data.HashMap.Strict as HashMap+import Data.Sectile.System.Linux.Internal+import Data.Sectile.Types+import qualified Data.Text as T+import qualified Data.Text.Read as T++-- | Display system uptime by reading @\/proc\/uptime@.+--+-- Formats the uptime as @Xd Xh Xm@.+--+-- Example:+--+-- > import Data.Sectile+-- >+-- > uptimeSegment :: Segment IO+-- > uptimeSegment = uptime "uptime"+-- > -- Renders e.g. "3d 2h 15m"+uptime :: Name -> Segment IO+uptime name@(Name nameB) =+ Segment $ do+ result <- tryReadFile "/proc/uptime"+ let (txt, bnds) = case result of+ Right content ->+ case parseUptime name content of+ Just (formatted, b) -> (formatted, b)+ Nothing -> (errMsg nameB, HashMap.empty)+ Left _ -> (errMsg nameB, HashMap.empty)+ pure $ do+ _ <- appendBindings bnds+ mkFormatted nameB "uptime" txt []++-- | Parse /proc/uptime: "12345.67 89012.34" -> "Xd Xh Xm"+parseUptime :: Name -> T.Text -> Maybe (T.Text, HashMap.HashMap T.Text Aeson.Value)+parseUptime name content = case T.double (T.strip content) of+ Right (seconds :: Double, _) ->+ let totalMinutes = floor seconds `div` 60 :: Int+ minutes = totalMinutes `mod` 60+ hours = (totalMinutes `div` 60) `mod` 24+ days = totalMinutes `div` (60 * 24)+ txt = T.pack (show days) <> "d " <> T.pack (show hours) <> "h " <> T.pack (show minutes) <> "m"+ bnds = unitBindings "s" name seconds+ in Just (txt, bnds)+ Left _ -> Nothing
+ src/Data/Sectile/System/Linux/Wifi.hs view
@@ -0,0 +1,39 @@+-- |+-- Module : Data.Sectile.System.Linux.Wifi+-- Copyright : Gautier DI FOLCO+-- License : ISC+--+-- Maintainer : Gautier DI FOLCO <foss@difolco.dev>+-- Stability : Stable+-- Portability : Portable+module Data.Sectile.System.Linux.Wifi (wifi) where++import Data.Sectile.System.Linux.Internal+import Data.Sectile.Types+import qualified Data.Text as T++-- | Display WiFi link quality by reading @\/proc\/net\/wireless@.+wifi :: Name -> String -> Segment IO+wifi (Name nameB) iface =+ Segment $ do+ res <- tryReadFile "/proc/net/wireless"+ let txt = case res of+ Right content -> case parseWifi iface content of+ Just formatted -> formatted+ Nothing -> errMsg nameB+ Left _ -> errMsg nameB+ pure $ mkFormatted nameB "wifi" txt [("Interface", T.pack iface)]++-- | Parse /proc/net/wireless for a specific interface.+parseWifi :: String -> T.Text -> Maybe T.Text+parseWifi iface content =+ let lns = T.lines content+ ifacePrefix = T.pack iface <> ":"+ matchLine l = T.isPrefixOf ifacePrefix (T.stripStart l)+ in case filter matchLine lns of+ (l : _) ->+ let parts = T.words $ T.drop (T.length ifacePrefix) $ T.stripStart l+ in case parts of+ (_status : link : level : _) -> Just $ T.strip (T.dropWhileEnd (== '.') link) <> "% " <> T.strip (T.dropWhileEnd (== '.') level) <> "dBm"+ _ -> Nothing+ _ -> Nothing
+ src/Data/Sectile/Themes.hs view
@@ -0,0 +1,243 @@+-- |+-- Module : Data.Sectile.Themes+-- Copyright : Gautier DI FOLCO+-- License : ISC+--+-- Maintainer : Gautier DI FOLCO <foss@difolco.dev>+-- Stability : Stable+-- Portability : Portable+--+-- Predefined colour themes inspired by tmux2k.+--+-- Each 'Theme' provides a complete colour palette that can be used to+-- style status line segments. Themes are based on+-- <https://github.com/2KAbhishek/tmux2k tmux2k> colour schemes.+--+-- Example:+--+-- > import Data.Sectile+-- > import Data.Sectile.Themes+-- > import Data.Sectile.Style+-- >+-- > styledSegment :: Segment IO+-- > styledSegment =+-- > let t = catppuccin+-- > in forceStyle (themeStyle t.blue t.black) (string "hello")+module Data.Sectile.Themes+ ( -- * Theme type+ Theme (..),++ -- * Predefined themes+ defaultTheme,+ catppuccin,+ gruvbox,+ monokai,+ onedark,++ -- * Theme helpers+ themeStyle,+ )+where++import qualified Data.Sectile.Tmux as Colour+import Data.Word (Word8)++-- | A complete colour palette for theming status line segments.+--+-- Each field holds a 24-bit RGB colour. The palette covers three+-- intensities (light, normal, dark) of eight hues, plus black, gray,+-- and white.+data Theme = Theme+ { black :: Colour.Colour,+ gray :: Colour.Colour,+ white :: Colour.Colour,+ lightBlue :: Colour.Colour,+ blue :: Colour.Colour,+ darkBlue :: Colour.Colour,+ lightGreen :: Colour.Colour,+ green :: Colour.Colour,+ darkGreen :: Colour.Colour,+ lightOrange :: Colour.Colour,+ orange :: Colour.Colour,+ darkOrange :: Colour.Colour,+ lightPink :: Colour.Colour,+ pink :: Colour.Colour,+ darkPink :: Colour.Colour,+ lightPurple :: Colour.Colour,+ purple :: Colour.Colour,+ darkPurple :: Colour.Colour,+ lightRed :: Colour.Colour,+ red :: Colour.Colour,+ darkRed :: Colour.Colour,+ lightYellow :: Colour.Colour,+ yellow :: Colour.Colour,+ darkYellow :: Colour.Colour+ }+ deriving stock (Show, Eq)++-- | Build a 'Colour.ChunkStyle' with the given foreground and background colours.+--+-- Example:+--+-- > let t = catppuccin+-- > in forceStyle (themeStyle t.blue t.black) segment+themeStyle :: Colour.Colour -> Colour.Colour -> Colour.ChunkStyle -> Colour.ChunkStyle+themeStyle fg bg style =+ style+ { Colour.chunkStyleForeground = Just fg,+ Colour.chunkStyleBackground = Just bg+ }++-- | Shorthand for constructing a 24-bit colour from RGB components.+rgb :: Word8 -> Word8 -> Word8 -> Colour.Colour+rgb = Colour.Colour24Bit++-- | The default tmux2k theme.+defaultTheme :: Theme+defaultTheme =+ Theme+ { black = rgb 0x00 0x00 0x00,+ gray = rgb 0x3f 0x3f 0x4f,+ white = rgb 0xff 0xff 0xff,+ lightBlue = rgb 0x11 0xdd 0xdd,+ blue = rgb 0x16 0x88 0xf0,+ darkBlue = rgb 0x00 0x00 0xcd,+ lightGreen = rgb 0xcc 0xff 0xcc,+ green = rgb 0x3d 0xd5 0x0a,+ darkGreen = rgb 0x00 0x64 0x00,+ lightOrange = rgb 0xff 0xa0 0x7a,+ orange = rgb 0xff 0xa5 0x00,+ darkOrange = rgb 0xff 0x45 0x00,+ lightPink = rgb 0xff 0xb6 0xc1,+ pink = rgb 0xff 0x69 0xb4,+ darkPink = rgb 0xff 0x14 0x93,+ lightPurple = rgb 0xdd 0xa0 0xdd,+ purple = rgb 0xbf 0x58 0xff,+ darkPurple = rgb 0x4b 0x00 0x82,+ lightRed = rgb 0xff 0x4a 0x6a,+ red = rgb 0xff 0x1f 0x1f,+ darkRed = rgb 0x80 0x00 0x00,+ lightYellow = rgb 0xff 0xfa 0xcd,+ yellow = rgb 0xff 0xd2 0x1a,+ darkYellow = rgb 0xb8 0x86 0x0b+ }++-- | The Catppuccin Macchiato theme.+catppuccin :: Theme+catppuccin =+ Theme+ { black = rgb 0x1e 0x20 0x30,+ gray = rgb 0x3f 0x3f 0x3f,+ white = rgb 0xff 0xff 0xff,+ lightBlue = rgb 0x91 0xd7 0xe3,+ blue = rgb 0x8a 0xad 0xf4,+ darkBlue = rgb 0x00 0x00 0x8b,+ lightGreen = rgb 0x8b 0xd5 0xca,+ green = rgb 0xa6 0xda 0x95,+ darkGreen = rgb 0x00 0x64 0x00,+ lightOrange = rgb 0xff 0xa0 0x7a,+ orange = rgb 0xf5 0xa9 0x7f,+ darkOrange = rgb 0xff 0x45 0x00,+ lightPink = rgb 0xff 0xb6 0xc1,+ pink = rgb 0xf5 0xbd 0xe6,+ darkPink = rgb 0xff 0x14 0x93,+ lightPurple = rgb 0xdd 0xa0 0xdd,+ purple = rgb 0xb6 0xa0 0xfe,+ darkPurple = rgb 0x4b 0x00 0x82,+ lightRed = rgb 0xee 0x99 0xa0,+ red = rgb 0xed 0x87 0x96,+ darkRed = rgb 0xb0 0x30 0x60,+ lightYellow = rgb 0xff 0xfa 0xcd,+ yellow = rgb 0xee 0xd4 0x9f,+ darkYellow = rgb 0xb8 0x86 0x0b+ }++-- | The Gruvbox theme.+gruvbox :: Theme+gruvbox =+ Theme+ { black = rgb 0x28 0x28 0x28,+ gray = rgb 0x4f 0x4f 0x4f,+ white = rgb 0xeb 0xdb 0xb2,+ lightBlue = rgb 0x83 0xa5 0x98,+ blue = rgb 0x45 0x85 0x88,+ darkBlue = rgb 0x07 0x66 0x78,+ lightGreen = rgb 0xb8 0xbb 0x26,+ green = rgb 0x98 0x97 0x1a,+ darkGreen = rgb 0x79 0x74 0x0e,+ lightOrange = rgb 0xff 0xa0 0x7a,+ orange = rgb 0xd7 0x99 0x21,+ darkOrange = rgb 0xff 0x45 0x00,+ lightPink = rgb 0xff 0xb6 0xc1,+ pink = rgb 0xf3 0x86 0xcb,+ darkPink = rgb 0xff 0x14 0x93,+ lightPurple = rgb 0xf3 0x86 0xcb,+ purple = rgb 0xb1 0x62 0xd6,+ darkPurple = rgb 0x8f 0x3f 0x71,+ lightRed = rgb 0xfb 0x49 0x34,+ red = rgb 0xcc 0x24 0x1d,+ darkRed = rgb 0x9d 0x00 0x06,+ lightYellow = rgb 0xff 0xfa 0xcd,+ yellow = rgb 0xfa 0xbd 0x2f,+ darkYellow = rgb 0xb8 0x86 0x0b+ }++-- | The Monokai theme.+monokai :: Theme+monokai =+ Theme+ { black = rgb 0x27 0x28 0x22,+ gray = rgb 0x4f 0x4f 0x4f,+ white = rgb 0xf8 0xf8 0xf2,+ lightBlue = rgb 0x66 0xd9 0xef,+ blue = rgb 0x66 0xd9 0xef,+ darkBlue = rgb 0x00 0x5f 0x87,+ lightGreen = rgb 0xa6 0xe2 0x2e,+ green = rgb 0xa6 0xe2 0x2e,+ darkGreen = rgb 0x5f 0x87 0x00,+ lightOrange = rgb 0xff 0xa0 0x7a,+ orange = rgb 0xff 0xa0 0x7a,+ darkOrange = rgb 0xff 0x45 0x00,+ lightPink = rgb 0xff 0xb6 0xc1,+ pink = rgb 0xfe 0x81 0xff,+ darkPink = rgb 0xff 0x14 0x93,+ lightPurple = rgb 0xfe 0x81 0xff,+ purple = rgb 0xae 0x81 0xff,+ darkPurple = rgb 0x5f 0x00 0xaf,+ lightRed = rgb 0xff 0x61 0x88,+ red = rgb 0xf9 0x26 0x72,+ darkRed = rgb 0xd7 0x00 0x5f,+ lightYellow = rgb 0xff 0xfa 0xcd,+ yellow = rgb 0xe6 0xdb 0x74,+ darkYellow = rgb 0xb8 0x86 0x0b+ }++-- | The One Dark theme.+onedark :: Theme+onedark =+ Theme+ { black = rgb 0x2d 0x31 0x39,+ gray = rgb 0x4f 0x4f 0x4f,+ white = rgb 0xf8 0xf8 0xf8,+ lightBlue = rgb 0x61 0xaf 0xef,+ blue = rgb 0x61 0xaf 0xef,+ darkBlue = rgb 0x1b 0x4f 0x9c,+ lightGreen = rgb 0x98 0xc3 0x79,+ green = rgb 0x98 0xc3 0x79,+ darkGreen = rgb 0x4b 0x56 0x32,+ lightOrange = rgb 0xff 0xa0 0x7a,+ orange = rgb 0xff 0xa0 0x7a,+ darkOrange = rgb 0xff 0x45 0x00,+ lightPink = rgb 0xff 0xb6 0xc1,+ pink = rgb 0xf6 0x78 0xcd,+ darkPink = rgb 0xff 0x14 0x93,+ lightPurple = rgb 0xf6 0x78 0xcd,+ purple = rgb 0xc6 0x78 0xfd,+ darkPurple = rgb 0x5f 0x00 0xaf,+ lightRed = rgb 0xe0 0x6c 0x75,+ red = rgb 0xe0 0x6c 0x75,+ darkRed = rgb 0xbe 0x50 0x46,+ lightYellow = rgb 0xff 0xfa 0xcd,+ yellow = rgb 0xe5 0xc0 0x7b,+ darkYellow = rgb 0xb8 0x86 0x0b+ }
+ src/Data/Sectile/Tmux.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module : Data.Sectile.Tmux+-- Copyright : Gautier DI FOLCO+-- License : ISC+--+-- Maintainer : Gautier DI FOLCO <foss@difolco.dev>+-- Stability : Stable+-- Portability : Portable+module Data.Sectile.Tmux+ ( Chunk (..),+ ChunkStyle (..),+ Colour (..),+ TerminalColour (..),+ Brightness (..),+ ConsoleIntensity (..),+ Underlining (..),+ Blinking (..),+ noStyle,+ chunkWidth,+ TerminalCapabilities (..),+ renderChunksUtf8BSBuilder,+ renderChunkStyleUtf8BSBuilder,+ parseAnsiChunks,+ renderColour,+ )+where++import qualified Data.ByteString.Builder as B+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Word (Word8)+import Numeric (showHex)++-- | The eight named terminal colours.+data TerminalColour = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White+ deriving (Show, Eq, Ord)++-- | Dull or bright variant of a 'TerminalColour'.+data Brightness = Bright | Dull+ deriving (Show, Eq, Ord)++-- | A colour: either an 8-colour ('Brightness' + 'TerminalColour') or a 24-bit RGB triple.+data Colour+ = Colour8 Brightness TerminalColour+ | Colour24Bit Word8 Word8 Word8+ deriving (Show, Eq, Ord)++-- | Text emphasis: bold, faint, or normal.+data ConsoleIntensity = BoldIntensity | FaintIntensity | NormalIntensity+ deriving (Show, Eq, Ord)++-- | Underlining style: single, double, or none.+data Underlining = SingleUnderline | DoubleUnderline | NoUnderline+ deriving (Show, Eq, Ord)++-- | Blinking style: slow, rapid, or none.+data Blinking = SlowBlinking | RapidBlinking | NoBlinking+ deriving (Show, Eq, Ord)++-- | Styling attributes for a chunk; every attribute is optional.+--+-- Fields cover foreground\/background colours, italic, strikethrough,+-- reversed, concealed, overlined, console intensity, underlining,+-- blinking, and hyperlink URL.+data ChunkStyle = ChunkStyle+ { chunkStyleForeground :: Maybe Colour,+ chunkStyleBackground :: Maybe Colour,+ chunkStyleItalic :: Maybe Bool,+ chunkStyleStrikethrough :: Maybe Bool,+ chunkStyleSwapForegroundBackground :: Maybe Bool,+ chunkStyleConcealed :: Maybe Bool,+ chunkStyleOverlined :: Maybe Bool,+ chunkStyleConsoleIntensity :: Maybe ConsoleIntensity,+ chunkStyleUnderlining :: Maybe Underlining,+ chunkStyleBlinking :: Maybe Blinking,+ chunkStyleHyperlink :: Maybe Text+ }+ deriving (Show, Eq, Ord)++-- | A 'ChunkStyle' with no styling applied.+noStyle :: ChunkStyle+noStyle =+ ChunkStyle+ { chunkStyleForeground = Nothing,+ chunkStyleBackground = Nothing,+ chunkStyleItalic = Nothing,+ chunkStyleStrikethrough = Nothing,+ chunkStyleSwapForegroundBackground = Nothing,+ chunkStyleConcealed = Nothing,+ chunkStyleOverlined = Nothing,+ chunkStyleConsoleIntensity = Nothing,+ chunkStyleUnderlining = Nothing,+ chunkStyleBlinking = Nothing,+ chunkStyleHyperlink = Nothing+ }++-- | A piece of rendered text and its style.+data Chunk = Chunk+ { chunkText :: Text,+ chunkStyle :: ChunkStyle+ }++-- | Length (in code points) of the chunk's text.+chunkWidth :: Chunk -> Int+chunkWidth = T.length . chunkText++-- | Colour support of the target terminal.+data TerminalCapabilities+ = WithoutColours+ | With8Colours+ | With8BitColours+ | With24BitColours+ deriving (Show, Eq, Ord)++-- | Wrap text as a single chunk carrying the given base style;+-- no ANSI sequence processing is performed.+parseAnsiChunks :: ChunkStyle -> Text -> (ChunkStyle, [Chunk])+parseAnsiChunks style txt = (style, [Chunk txt style])++-- | Render chunks as a tmux style-prefixed UTF-8 'B.Builder'.+renderChunksUtf8BSBuilder :: TerminalCapabilities -> [Chunk] -> B.Builder+renderChunksUtf8BSBuilder cap = foldMap renderChunk+ where+ renderChunk c =+ let txt = chunkText c+ in case renderChunkStyleUtf8BSBuilder cap (chunkStyle c) of+ Nothing -> B.byteString (T.encodeUtf8 txt)+ Just renderedStyle -> renderedStyle <> B.byteString (T.encodeUtf8 txt) <> "#[default]"++-- | Render a style as a tmux style specification, or 'Nothing' when the+-- terminal has no colour support or the style is empty.+renderChunkStyleUtf8BSBuilder :: TerminalCapabilities -> ChunkStyle -> Maybe B.Builder+renderChunkStyleUtf8BSBuilder cap style =+ if cap == WithoutColours || null attrs+ then Nothing+ else Just $ "#[" <> B.byteString (T.encodeUtf8 $ T.intercalate "," attrs) <> "]"+ where+ fg = case chunkStyleForeground style of+ Nothing -> []+ Just col -> ["fg=" <> renderColour col]+ bg = case chunkStyleBackground style of+ Nothing -> []+ Just col -> ["bg=" <> renderColour col]+ bold = case chunkStyleConsoleIntensity style of+ Just BoldIntensity -> ["bold"]+ Just FaintIntensity -> ["dim"]+ _ -> []+ italic = case chunkStyleItalic style of+ Just True -> ["italics"]+ _ -> []+ underlined = case chunkStyleUnderlining style of+ Just SingleUnderline -> ["underscore"]+ Just DoubleUnderline -> ["underscore"]+ _ -> []+ blink = case chunkStyleBlinking style of+ Just SlowBlinking -> ["blink"]+ Just RapidBlinking -> ["blink"]+ _ -> []+ reverse' = case chunkStyleSwapForegroundBackground style of+ Just True -> ["reverse"]+ _ -> []+ hidden = case chunkStyleConcealed style of+ Just True -> ["hidden"]+ _ -> []+ strike = case chunkStyleStrikethrough style of+ Just True -> ["strikethrough"]+ _ -> []+ attrs = mconcat [fg, bg, bold, italic, underlined, blink, reverse', hidden, strike]++-- | Render a 'Colour' as a tmux colour name or hex value.+renderColour :: Colour -> Text+renderColour =+ \case+ Colour8 _ Black -> "black"+ Colour8 _ Red -> "red"+ Colour8 _ Green -> "green"+ Colour8 _ Yellow -> "yellow"+ Colour8 _ Blue -> "blue"+ Colour8 _ Magenta -> "magenta"+ Colour8 _ Cyan -> "cyan"+ Colour8 _ White -> "white"+ Colour24Bit r g b ->+ let hex = pad (showHex r "") <> pad (showHex g "") <> pad (showHex b "")+ pad s+ | length s == 1 = "0" <> s+ | otherwise = s+ in "#" <> T.pack hex
+ src/Data/Sectile/Types.hs view
@@ -0,0 +1,253 @@+-- |+-- Module : Data.Sectile.Types+-- Copyright : Gautier DI FOLCO+-- License : ISC+--+-- Maintainer : Gautier DI FOLCO <foss@difolco.dev>+-- Stability : Stable+-- Portability : Portable+module Data.Sectile.Types+ ( -- * Main types+ Segment (..),+ Formatted (..),+ Env (..),+ Detail (..),+ bindingsDetail,++ -- * Segment builder types+ Name (..),+ Unit (..),++ -- * Runner type+ SegmentsRunner,++ -- * Environment helpers+ currentStyle,+ updateStyle,+ currentBindings,+ appendBindings,+ updateBindings,+ scopeBindings,++ -- * Binding helpers+ unitBindings,+ percentBindings,+ )+where++import Control.Monad.State (State, gets, modify)+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import Data.Bifunctor (Bifunctor (first))+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Lazy as LBS+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Foldable as Foldable+import qualified Data.List as List+import qualified Data.Sectile.Tmux as Colour+import Data.String (IsString)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as Text.Encoding+import Numeric (showFFloat)++-- | A composable segment of a status line.+--+-- A segment wraps an effectful computation that, given a 'Colour.ChunkStyle',+-- produces a 'Formatted' output. Segments can be combined using 'Data.Sectile.Row.row'+-- and styled using functions from "Data.Sectile.Style".+--+-- Example:+--+-- > import Data.Sectile+-- >+-- > hello :: Segment IO+-- > hello = string "Hello, world!"+newtype Segment m = Segment+ { runSegment :: m (State Env Formatted)+ }++-- | The result of rendering a 'Segment'.+--+-- Contains the rendered chunks, the style that should carry over to the+-- next segment, and an explanation tree for debugging.+--+-- Example:+--+-- > import qualified Data.Sectile.Tmux as Colour+-- >+-- > -- A Formatted value carries rendered output and debug info+-- > inspectRendered :: Formatted -> [Colour.Chunk]+-- > inspectRendered fmt = fmt.rendered+data Formatted = Formatted+ { rendered :: [Colour.Chunk],+ explain :: (Colour.ChunkStyle -> Maybe B.Builder) -> ([Colour.Chunk] -> B.Builder) -> Detail B.Builder+ }++-- | Segment environment: carries the incoming 'Env.style' and the+-- accumulated 'Env.bindings' across segments.+data Env = Env+ { style :: Colour.ChunkStyle,+ bindings :: HashMap Text Aeson.Value+ }++-- | A tree structure for segment explanations, used by 'Data.Sectile.Runners.explainSegment'.+--+-- * 'DetailPlain' holds a single line of explanation.+-- * 'DetailNested' indents its child one level deeper.+-- * 'DetailList' groups multiple explanation entries.+--+-- Example:+--+-- > explanationTree :: Detail String+-- > explanationTree =+-- > DetailList+-- > [ DetailPlain "Type: string",+-- > DetailNested (DetailPlain "nested detail")+-- > ]+data Detail a+ = DetailPlain a+ | DetailNested (Detail a)+ | DetailList [Detail a]++-- | A name for a segment, used for identification in explanations.+--+-- Can be created using @OverloadedStrings@:+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- >+-- > myName :: Name+-- > myName = "my-segment"+newtype Name+ = Name {unName :: B.Builder}+ deriving newtype (IsString, Semigroup, Monoid)++-- | A unit for a segment, used for binding helpers.+newtype Unit+ = Unit {unUnit :: Text}+ deriving newtype (IsString, Eq, Show)++-- | A strategy for running multiple segments.+--+-- This type alias represents a function that runs a collection of segments,+-- allowing different execution strategies (sequential via 'mapM' or+-- concurrent via @Control.Concurrent.Async.mapConcurrently@).+--+-- Example:+--+-- > import Data.Sectile+-- >+-- > -- Sequential runner+-- > sequentialRunner :: SegmentsRunner IO+-- > sequentialRunner = mapM+type SegmentsRunner m =+ (Segment m -> m (State Env Formatted)) ->+ [Segment m] ->+ m [State Env Formatted]++-- | The 'Colour.ChunkStyle' currently carried by the environment.+currentStyle :: State Env Colour.ChunkStyle+currentStyle = gets style++-- | Apply a transformation to the environment style and return the result.+updateStyle :: (Colour.ChunkStyle -> Colour.ChunkStyle) -> State Env Colour.ChunkStyle+updateStyle f = do+ modify (\env -> env {style = f (style env)})+ gets style++-- | The bindings currently carried by the environment.+currentBindings :: State Env (HashMap Text Aeson.Value)+currentBindings = gets bindings++-- | Apply a transformation to the environment bindings and return the result.+updateBindings :: (HashMap Text Aeson.Value -> HashMap Text Aeson.Value) -> State Env (HashMap Text Aeson.Value)+updateBindings f = do+ modify (\env -> env {bindings = f (bindings env)})+ gets bindings++-- | Add bindings; keys in the new map take precedence over existing ones.+appendBindings :: HashMap Text Aeson.Value -> State Env (HashMap Text Aeson.Value)+appendBindings newBindings = updateBindings (HashMap.union newBindings)++-- | Run an action with bindings scoped under the given 'Name':+-- child bindings get prefixed with the name.+scopeBindings :: Name -> State Env a -> State Env a+scopeBindings (Name nameBuilder) action = do+ let prefix = Text.Encoding.decodeUtf8 (LBS.toStrict (B.toLazyByteString nameBuilder)) <> "."+ mapKeys f hm = HashMap.fromList $ first f <$> HashMap.toList hm+ oldBindings <- gets bindings+ modify (\env -> env {bindings = HashMap.empty})+ result <- action+ childBindings <- gets bindings+ let prefixedChildBindings = mapKeys (prefix <>) childBindings+ modify (\env -> env {bindings = HashMap.union prefixedChildBindings oldBindings})+ pure result++-- | Build bindings for a value with a base unit (e.g. @\"B\"@), scaled+-- to the largest fitting binary magnitude (KiB, MiB, ...).+unitBindings :: Unit -> Name -> Double -> HashMap Text Aeson.Value+unitBindings (Unit base) (Name nameBuilder) val =+ HashMap.fromList+ [ (nameT, Aeson.String (full <> prefix <> base)),+ (nameT <> ".raw", Aeson.Number (realToFrac val)),+ (nameT <> ".value.full", Aeson.String full),+ (nameT <> ".value.round", Aeson.String (T.pack $ showFFloat (Just 0) scaled "")),+ (nameT <> ".unit.full", Aeson.String (prefix <> base)),+ (nameT <> ".unit.base", Aeson.String base),+ (nameT <> ".unit.prefix", Aeson.String prefix)+ ]+ where+ nameT = Text.Encoding.decodeUtf8 $ LBS.toStrict $ B.toLazyByteString nameBuilder+ full = T.pack $ showFFloat (Just 1) scaled ""+ (prefix, scaled)+ | abs val >= 1024 ** 6 = ("Ei", val / (1024 ** 6))+ | abs val >= 1024 ** 5 = ("Pi", val / (1024 ** 5))+ | abs val >= 1024 ** 4 = ("Ti", val / (1024 ** 4))+ | abs val >= 1024 ** 3 = ("Gi", val / (1024 ** 3))+ | abs val >= 1024 ** 2 = ("Mi", val / (1024 ** 2))+ | abs val >= 1024 = ("Ki", val / 1024)+ | otherwise = ("", val)++-- | Build bindings for a value expressed as a percentage.+percentBindings :: Name -> Double -> HashMap Text Aeson.Value+percentBindings (Name nameBuilder) val =+ HashMap.fromList+ [ (nameT, Aeson.String (full <> "%")),+ (nameT <> ".raw", Aeson.Number (realToFrac val)),+ (nameT <> ".absolute", Aeson.String (T.pack $ showFFloat (Just 2) val "")),+ (nameT <> ".percent.full", Aeson.String full),+ (nameT <> ".percent.round", Aeson.String (T.pack $ showFFloat (Just 0) (val * 100) ""))+ ]+ where+ nameT = Text.Encoding.decodeUtf8 $ LBS.toStrict $ B.toLazyByteString nameBuilder+ full = T.pack $ showFFloat (Just 1) (val * 100) ""++-- | Render bindings as a @"Bindings:"@ detail block: one+-- @path = value@ line per leaf, flattening nested JSON objects into+-- dot-separated paths (e.g. @_inner.style.raw@).+bindingsDetail :: HashMap Text Aeson.Value -> [Detail B.Builder]+bindingsDetail bnds+ | HashMap.null bnds = []+ | otherwise =+ [ DetailPlain "Bindings:",+ DetailNested $+ DetailList+ [DetailPlain (Text.Encoding.encodeUtf8Builder path <> " = " <> valueBuilder v) | (path, v) <- leaves]+ ]+ where+ leaves = List.sortOn fst (concatMap (flattenValue "") (HashMap.toList bnds))+ flattenValue prefix (k, v) = descend (joinKey prefix k) v+ joinKey "" k = k+ joinKey prefix k = prefix <> "." <> k+ descend path (Aeson.Object obj)+ | KeyMap.null obj = [(path, Aeson.Object obj)]+ | otherwise = concatMap (\(k, v) -> descend (joinKey path (Key.toText k)) v) (KeyMap.toList obj)+ descend path (Aeson.Array arr)+ | Foldable.null arr = [(path, Aeson.Array arr)]+ | otherwise =+ concat [descend (joinKey path (T.pack (show i))) v | (i, v) <- zip [0 :: Int ..] (Foldable.toList arr)]+ descend path v = [(path, v)]+ valueBuilder (Aeson.String t) = Text.Encoding.encodeUtf8Builder t+ valueBuilder v = B.lazyByteString (Aeson.encode v)
+ test/Data/Sectile/DisplaySpec.hs view
@@ -0,0 +1,98 @@+module Data.Sectile.DisplaySpec (spec) where++import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Lazy as BSL+import Data.Sectile+import qualified Data.Sectile.Tmux as Colour+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Test.Hspec++spec :: Spec+spec = do+ describe "takeStart" $ do+ it "truncates to n characters" $ do+ output <-+ renderSegment Colour.WithoutColours $+ takeStart 5 (string "Hello, world!")+ builderToText output `shouldBe` "Hello"++ it "returns full text when shorter than n" $ do+ output <-+ renderSegment Colour.WithoutColours $+ takeStart 20 (string "Hello")+ builderToText output `shouldBe` "Hello"++ it "returns empty for n=0" $ do+ output <-+ renderSegment Colour.WithoutColours $+ takeStart 0 (string "Hello")+ builderToText output `shouldBe` ""++ describe "takeEnd" $ do+ it "keeps last n characters" $ do+ output <-+ renderSegment Colour.WithoutColours $+ takeEnd 6 (string "Hello, world!")+ builderToText output `shouldBe` "world!"++ it "returns full text when shorter than n" $ do+ output <-+ renderSegment Colour.WithoutColours $+ takeEnd 20 (string "Hello")+ builderToText output `shouldBe` "Hello"++ describe "padStart" $ do+ it "pads with spaces at the start" $ do+ output <-+ renderSegment Colour.WithoutColours $+ padStart 8 (string "Hi")+ builderToText output `shouldBe` " Hi"++ it "does not pad when already long enough" $ do+ output <-+ renderSegment Colour.WithoutColours $+ padStart 2 (string "Hello")+ builderToText output `shouldBe` "Hello"++ describe "padEnd" $ do+ it "pads with spaces at the end" $ do+ output <-+ renderSegment Colour.WithoutColours $+ padEnd 8 (string "Hi")+ builderToText output `shouldBe` "Hi "++ it "does not pad when already long enough" $ do+ output <-+ renderSegment Colour.WithoutColours $+ padEnd 2 (string "Hello")+ builderToText output `shouldBe` "Hello"++ describe "fixedSizeStart" $ do+ it "pads short text at start" $ do+ output <-+ renderSegment Colour.WithoutColours $+ fixedSizeStart 6 (string "Hi")+ builderToText output `shouldBe` " Hi"++ it "truncates long text from end" $ do+ output <-+ renderSegment Colour.WithoutColours $+ fixedSizeStart 5 (string "Hello, world!")+ builderToText output `shouldBe` "Hello"++ describe "fixedSizeEnd" $ do+ it "pads short text at end" $ do+ output <-+ renderSegment Colour.WithoutColours $+ fixedSizeEnd 6 (string "Hi")+ builderToText output `shouldBe` "Hi "++ it "truncates long text from start" $ do+ output <-+ renderSegment Colour.WithoutColours $+ fixedSizeEnd 6 (string "Hello, world!")+ builderToText output `shouldBe` "world!"++builderToText :: B.Builder -> T.Text+builderToText = T.decodeUtf8 . BSL.toStrict . B.toLazyByteString
+ test/Data/Sectile/SegmentsSpec.hs view
@@ -0,0 +1,110 @@+module Data.Sectile.SegmentsSpec (spec) where++import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Lazy as BSL+import qualified Data.HashMap.Strict as HashMap+import Data.Sectile+import qualified Data.Sectile.Tmux as Colour+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Test.Hspec++spec :: Spec+spec = do+ describe "string" $ do+ it "renders plain text" $ do+ output <- renderSegment Colour.WithoutColours (string "hello")+ builderToText output `shouldBe` "hello"++ it "renders empty text" $ do+ output <- renderSegment Colour.WithoutColours (string "")+ builderToText output `shouldBe` ""++ it "preserves text content" $ do+ output <- renderSegment Colour.WithoutColours (string "foo bar baz")+ builderToText output `shouldBe` "foo bar baz"++ describe "row" $ do+ it "concatenates segments" $ do+ output <-+ renderSegment Colour.WithoutColours $+ row mapM Isolating "test" [string "a", string "b", string "c"]+ builderToText output `shouldBe` "abc"++ it "handles empty segment list" $ do+ output <-+ renderSegment Colour.WithoutColours $+ row mapM Isolating "empty" []+ builderToText output `shouldBe` ""++ it "handles single segment" $ do+ output <-+ renderSegment Colour.WithoutColours $+ row mapM Isolating "single" [string "only"]+ builderToText output `shouldBe` "only"++ describe "between" $ do+ it "wraps segments with start and end" $ do+ let segments = between (string "[") (string "]") [string "a", string "b"]+ output <-+ renderSegment Colour.WithoutColours $+ row mapM Isolating "wrapped" segments+ builderToText output `shouldBe` "[ab]"++ it "works with empty inner list" $ do+ let segments = between (string "<") (string ">") []+ output <-+ renderSegment Colour.WithoutColours $+ row mapM Isolating "empty-wrapped" segments+ builderToText output `shouldBe` "<>"++ describe "sh" $ do+ it "captures stdout" $ do+ output <- renderSegment Colour.WithoutColours (sh "test" "echo -n hello" Nothing)+ builderToText output `shouldBe` "hello"++ it "displays error on failure" $ do+ output <- renderSegment Colour.WithoutColours (sh "test-cmd" "false" Nothing)+ builderToText output `shouldBe` "Error on test-cmd"++ it "passes environment variables" $ do+ output <-+ renderSegment Colour.WithoutColours $+ sh "env-test" "echo -n $MY_VAR" (Just [("MY_VAR", "works")])+ builderToText output `shouldBe` "works"++ describe "time" $ do+ it "renders time with format" $ do+ output <- renderSegment Colour.WithoutColours (time "clock" "%H")+ let txt = builderToText output+ T.length txt `shouldBe` 2++ describe "explainSegment" $ do+ it "produces explanation for string" $ do+ output <- explainSegment Colour.WithoutColours (string "test")+ let txt = builderToText output+ txt `shouldSatisfy` T.isInfixOf "Type: string"++ it "renders reformat bindings as dot paths, not nested JSON" $ do+ output <- explainSegment Colour.WithoutColours (reformat PropagateInner "[{{ _inner.raw }}]" (string "hello"))+ let txt = builderToText output+ txt `shouldSatisfy` T.isInfixOf "_inner.raw = hello"+ txt `shouldNotSatisfy` T.isInfixOf "{\"raw\""++ describe "reformat" $ do+ it "reformats output using EDE template" $ do+ output <- renderSegment Colour.WithoutColours (reformat PropagateInner "[{{ _inner.raw }}]" (string "hello"))+ builderToText output `shouldBe` "[hello]"++ it "has access to bound variables" $ do+ let seg = Segment $ do+ inner <- runSegment (string "hello" :: Segment IO)+ pure $ do+ _ <- appendBindings (HashMap.singleton "my_var" (Aeson.String "world"))+ inner+ output <- renderSegment Colour.WithoutColours (reformat PropagateInner "{{ my_var }} - {{ _inner.raw }}" seg)+ builderToText output `shouldBe` "world - hello"++builderToText :: B.Builder -> T.Text+builderToText = T.decodeUtf8 . BSL.toStrict . B.toLazyByteString
+ test/Data/Sectile/StyleSpec.hs view
@@ -0,0 +1,76 @@+module Data.Sectile.StyleSpec (spec) where++import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Lazy as BSL+import Data.Sectile+import Data.Sectile.Tmux (Brightness (..), TerminalColour (..))+import qualified Data.Sectile.Tmux as Colour+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Optics.Core as Optics+import Test.Hspec++spec :: Spec+spec = do+ describe "between" $ do+ it "prepends start and appends end" $ do+ let result = between (string "[") (string "]") [string "a"]+ output <-+ renderSegment Colour.WithoutColours $+ row mapM Isolating "test" result+ builderToText output `shouldBe` "[a]"++ describe "changeStyle" $ do+ it "modifies incoming style" $ do+ output <-+ renderSegment Colour.WithoutColours $+ changeStyle resetStyle (string "hello")+ builderToText output `shouldBe` "hello"++ describe "forceStyle" $ do+ it "applies style to output" $ do+ output <-+ renderSegment Colour.WithoutColours $+ forceStyle resetStyle (string "hello")+ builderToText output `shouldBe` "hello"++ describe "resetStyle" $ do+ it "produces noStyle" $ do+ let result = resetStyle Colour.noStyle+ result `shouldBe` Colour.noStyle++ it "clears any existing style" $ do+ let styled = Colour.noStyle {Colour.chunkStyleItalic = Just True}+ resetStyle styled `shouldBe` Colour.noStyle++ describe "swapForegroundBackgroundStyle" $ do+ it "swaps foreground and background" $ do+ let original =+ Colour.noStyle+ { Colour.chunkStyleForeground = Just (Colour.Colour8 Dull Red),+ Colour.chunkStyleBackground = Just (Colour.Colour8 Bright Blue)+ }+ swapped = swapForegroundBackgroundStyle original+ Colour.chunkStyleForeground swapped `shouldBe` Just (Colour.Colour8 Bright Blue)+ Colour.chunkStyleBackground swapped `shouldBe` Just (Colour.Colour8 Dull Red)++ it "handles noStyle" $ do+ swapForegroundBackgroundStyle Colour.noStyle `shouldBe` Colour.noStyle++ describe "style optics" $ do+ it "styleItalic gets and sets" $ do+ let s = Optics.set styleItalic (Just True) Colour.noStyle+ Optics.view styleItalic s `shouldBe` Just True++ it "styleForeground gets and sets" $ do+ let colour = Colour.Colour8 Dull Green+ s = Optics.set styleForeground (Just colour) Colour.noStyle+ Optics.view styleForeground s `shouldBe` Just colour++ it "styleBackground gets and sets" $ do+ let colour = Colour.Colour8 Bright Yellow+ s = Optics.set styleBackground (Just colour) Colour.noStyle+ Optics.view styleBackground s `shouldBe` Just colour++builderToText :: B.Builder -> T.Text+builderToText = T.decodeUtf8 . BSL.toStrict . B.toLazyByteString
+ test/Data/Sectile/System/LinuxSpec.hs view
@@ -0,0 +1,64 @@+module Data.Sectile.System.LinuxSpec (spec) where++import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Lazy as BSL+import Data.Sectile+import Data.Sectile.System.Linux+import qualified Data.Sectile.Tmux as Colour+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Test.Hspec++spec :: Spec+spec = do+ describe "uptime" $ do+ it "renders uptime from /proc/uptime" $ do+ output <- renderSegment Colour.WithoutColours (uptime "uptime")+ let txt = builderToText output+ -- Should contain "d", "h", "m" formatting+ txt `shouldSatisfy` T.isInfixOf "d "+ txt `shouldSatisfy` T.isInfixOf "h "+ txt `shouldSatisfy` T.isInfixOf "m"++ describe "memory" $ do+ it "renders memory usage from /proc/meminfo" $ do+ output <- renderSegment Colour.WithoutColours (memory "mem")+ let txt = builderToText output+ -- Should contain percentage and size units+ txt `shouldSatisfy` T.isInfixOf "%"+ txt `shouldSatisfy` (\t -> any (`T.isInfixOf` t) ["EiB", "TiB", "GiB", "MiB", "KiB"])++ describe "load" $ do+ it "renders load averages from /proc/loadavg" $ do+ output <- renderSegment Colour.WithoutColours (load "load")+ let txt = builderToText output+ -- Load averages are space-separated decimals+ length (T.words txt) `shouldBe` 3++ describe "cpu" $ do+ it "renders CPU usage percentage" $ do+ output <- renderSegment Colour.WithoutColours (cpu "cpu")+ let txt = builderToText output+ txt `shouldSatisfy` T.isInfixOf "%"++ describe "disk" $ do+ it "renders disk info for root mount" $ do+ output <- renderSegment Colour.WithoutColours (disk "disk" "/")+ let txt = builderToText output+ txt `shouldSatisfy` T.isInfixOf "iB ("++ describe "networkDown" $ do+ it "renders network receive bytes for lo" $ do+ output <- renderSegment Colour.WithoutColours (networkDown "net" ["lo"])+ let txt = builderToText output+ -- Should be a formatted string with B/s or error+ txt `shouldSatisfy` (\t -> T.isSuffixOf "B/s" t || T.isInfixOf "Error" t)++ describe "networkUp" $ do+ it "renders network transmit bytes for lo" $ do+ output <- renderSegment Colour.WithoutColours (networkUp "net" ["lo"])+ let txt = builderToText output+ txt `shouldSatisfy` (\t -> T.isSuffixOf "B/s" t || T.isInfixOf "Error" t)++builderToText :: B.Builder -> T.Text+builderToText = T.decodeUtf8 . BSL.toStrict . B.toLazyByteString
+ test/Data/Sectile/TmuxSpec.hs view
@@ -0,0 +1,38 @@+module Data.Sectile.TmuxSpec (spec) where++import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Lazy as BL+import Data.Sectile.Tmux+import Test.Hspec++spec :: Spec+spec = do+ describe "Tmux rendering" $ do+ it "renders unstyled chunk as plain text" $ do+ let chunk = Chunk "hello" noStyle+ res = renderChunksUtf8BSBuilder With24BitColours [chunk]+ BL.toStrict (B.toLazyByteString res) `shouldBe` "hello"++ it "renders fg colour" $ do+ let style = noStyle {chunkStyleForeground = Just (Colour8 Bright Red)}+ chunk = Chunk "hello" style+ res = renderChunksUtf8BSBuilder With24BitColours [chunk]+ BL.toStrict (B.toLazyByteString res) `shouldBe` "#[fg=red]hello#[default]"++ it "renders bg colour and bold" $ do+ let style = noStyle {chunkStyleBackground = Just (Colour24Bit 255 0 255), chunkStyleConsoleIntensity = Just BoldIntensity}+ chunk = Chunk "hello" style+ res = renderChunksUtf8BSBuilder With24BitColours [chunk]+ BL.toStrict (B.toLazyByteString res) `shouldBe` "#[bg=#ff00ff,bold]hello#[default]"++ it "renders multiple chunks" $ do+ let chunk1 = Chunk "hello " (noStyle {chunkStyleForeground = Just (Colour8 Dull Blue)})+ chunk2 = Chunk "world" noStyle+ res = renderChunksUtf8BSBuilder With24BitColours [chunk1, chunk2]+ BL.toStrict (B.toLazyByteString res) `shouldBe` "#[fg=blue]hello #[default]world"++ it "handles WithoutColours capability" $ do+ let style = noStyle {chunkStyleForeground = Just (Colour8 Bright Red)}+ chunk = Chunk "hello" style+ res = renderChunksUtf8BSBuilder WithoutColours [chunk]+ BL.toStrict (B.toLazyByteString res) `shouldBe` "hello"
+ test/Data/Sectile/TypesSpec.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.Sectile.TypesSpec (spec) where++import Control.Monad.State (evalState, execState)+import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Lazy as BSL+import qualified Data.HashMap.Strict as HashMap+import Data.Sectile.Tmux (ChunkStyle (..), noStyle)+import Data.Sectile.Types+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Test.Hspec++spec :: Spec+spec = do+ describe "Env state helpers" $ do+ let emptyEnv = Env noStyle HashMap.empty++ it "currentStyle gets style" $ do+ evalState currentStyle emptyEnv `shouldBe` noStyle++ it "updateStyle modifies and returns new style" $ do+ let newStyle = noStyle {chunkStyleItalic = Just True}+ let res = evalState (updateStyle (const newStyle)) emptyEnv+ res `shouldBe` newStyle++ it "currentBindings gets bindings" $ do+ evalState currentBindings emptyEnv `shouldBe` HashMap.empty++ it "updateBindings modifies and returns new bindings" $ do+ let newBindings = HashMap.singleton "key" (Aeson.String "value")+ let res = evalState (updateBindings (const newBindings)) emptyEnv+ res `shouldBe` newBindings++ it "appendBindings adds bindings" $ do+ let initialEnv = Env noStyle (HashMap.singleton "k1" (Aeson.String "v1"))+ let newBindings = HashMap.singleton "k2" (Aeson.String "v2")+ let res = evalState (appendBindings newBindings) initialEnv+ res `shouldBe` HashMap.fromList [("k1", Aeson.String "v1"), ("k2", Aeson.String "v2")]++ it "scopeBindings prefixes child bindings and preserves parent bindings" $ do+ let initialEnv = Env noStyle (HashMap.singleton "parent" (Aeson.String "pv"))+ let action = do+ _ <- appendBindings (HashMap.singleton "child" (Aeson.String "cv"))+ pure ("result" :: String)+ let finalEnv = execState (scopeBindings "test" action) initialEnv+ bindings finalEnv+ `shouldBe` HashMap.fromList+ [ ("parent", Aeson.String "pv"),+ ("test.child", Aeson.String "cv")+ ]++ describe "Binding helpers" $ do+ it "unitBindings generates correctly for KB" $ do+ let bnds = unitBindings "B" "disk" 2048+ bnds+ `shouldBe` HashMap.fromList+ [ ("disk", Aeson.String "2.0KiB"),+ ("disk.raw", Aeson.Number 2048),+ ("disk.value.full", Aeson.String "2.0"),+ ("disk.value.round", Aeson.String "2"),+ ("disk.unit.full", Aeson.String "KiB"),+ ("disk.unit.base", Aeson.String "B"),+ ("disk.unit.prefix", Aeson.String "Ki")+ ]++ it "percentBindings generates correctly" $ do+ let bnds = percentBindings "usage" 0.426+ bnds+ `shouldBe` HashMap.fromList+ [ ("usage", Aeson.String "42.6%"),+ ("usage.raw", Aeson.Number (realToFrac (0.426 :: Double))),+ ("usage.absolute", Aeson.String "0.43"),+ ("usage.percent.full", Aeson.String "42.6"),+ ("usage.percent.round", Aeson.String "43")+ ]++ describe "bindingsDetail" $ do+ it "renders nothing for empty bindings" $ do+ renderDetail (bindingsDetail HashMap.empty) `shouldBe` []++ it "flattens nested objects into sorted dot paths" $ do+ let bnds =+ HashMap.fromList+ [ ("_inner", Aeson.toJSON (HashMap.fromList [("raw" :: T.Text, Aeson.String "hello"), ("style", Aeson.toJSON (HashMap.fromList [("raw" :: T.Text, Aeson.String "")]))])),+ ("top", Aeson.String "v")+ ]+ renderDetail (bindingsDetail bnds)+ `shouldBe` [ "Bindings:",+ " _inner.raw = hello",+ " _inner.style.raw = ",+ " top = v"+ ]++ it "renders JSON scalar bindings via Aeson encoding" $ do+ let bnds = HashMap.singleton "clock.raw" (Aeson.Number 85)+ renderDetail (bindingsDetail bnds) `shouldBe` ["Bindings:", " clock.raw = 85"]++renderDetail :: [Detail B.Builder] -> [T.Text]+renderDetail = concatMap (go 0)+ where+ go lvl (DetailPlain b) = [T.replicate (2 * lvl) " " <> T.decodeUtf8 (BSL.toStrict (B.toLazyByteString b))]+ go lvl (DetailNested d) = go (lvl + 1) d+ go lvl (DetailList ds) = concatMap (go lvl) ds
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}