Formatting in sectile

In the previous log, we introduced sectile, a composable tmux status bar.

Unlike existing libraries and tools, it aims to be both flexible and simple.

newtype Segment m = Segment
  { runSegment :: m (Colour.ChunkStyle -> Formatted)
  }

data Formatted = Formatted
  { rendered :: [Colour.Chunk],
    finalStyle :: Colour.ChunkStyle
  }

The showcase is string which enables the insertion of literal elements and is defined as follows:

string :: (Applicative m) => T.Text -> Segment m
string txt =
  Segment $
    pure $
      \style ->
        let (finalStyle, rendered) = Colour.parseAnsiChunks style txt
         in Formatted {..}

However, when we have to define more complex segments such as memory defined as follows:

memory :: Name -> Segment IO
memory name@(Name nameB) =
  Segment $ do
    result <- tryReadFile "/proc/meminfo"
    let txt = case result of
          Right content ->
            case parseMeminfo name content of
              Just formatted -> formatted
              Nothing -> errMsg nameB
          Left _ -> errMsg nameB
    pure $ mkFormatted nameB "memory" txt []

-- | Parse /proc/meminfo to extract MemTotal, MemAvailable.
parseMeminfo :: Name -> T.Text -> Maybe T.Text
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
              txt =
                T.pack (show (round (used / (1024 * 1024 * 1024)) :: Int))
                  <> " GiB ("
                  <> T.pack (show (round (pct * 100) :: Int))
                  <> "%)"
           in Just txt
        _ -> Nothing

It forces a format here, something like 8.2GiB / 15.6GiB (52%).

A way to handle it would be to give a format to segment, which is tedious.

Instead, we can propagate values and format them a posteriori.

To do so, we need to have an environment; to do so, we can leverage State and rework our types as follows:

newtype Segment m = Segment
  { runSegment :: m (State Env Formatted)
  }

newtype Formatted = Formatted
  { rendered :: [Colour.Chunk]
  }

-- | Segment environment.
data Env = Env
  { style :: Colour.ChunkStyle,
    bindings :: HashMap Text Aeson.Value
  }

Note: we did not put StateT IO as mapConcurrently is not defined on StateT, we can make sense, but is pointless for us as it is a two steps processes (first run the effects then “concatenate” the results.

Note: We will use ede as our template engine; unlike zinza, it supports dynamic values.

We have also added some wrappers, defined as follows:

currentStyle :: State Env Colour.ChunkStyle
currentStyle = gets style

updateStyle :: (Colour.ChunkStyle -> Colour.ChunkStyle) -> State Env Colour.ChunkStyle
updateStyle f = do
  modify (\env -> env {style = f (style env)})
  gets style

currentBindings :: State Env (HashMap Text Aeson.Value)
currentBindings = gets bindings

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

appendBindings :: HashMap Text Aeson.Value -> State Env (HashMap Text Aeson.Value)
appendBindings newBindings = updateBindings (HashMap.union newBindings)

We have also added a scoping mechanism to avoid confusions, defined as follows:

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

It will prefix all bindings to avoid overriding.We more or less aim to have a framework about values; for example, let's define units as follows:

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)

Note: ede does not support functions, which forces us to give numerous details.

In actual segments, it gives the following code:

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

It gives us the opportunity to implement reformat, as follows:

reformat :: (Functor m) => T.Text -> Segment m -> Segment m
reformat format (Segment s) = Segment $ transform <$> s
  where
    transform action = do
      incomingStyle <- currentStyle
      formatted <- action
      bnds <- currentBindings

      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})
        EDE.Success tmpl -> case EDE.render tmpl (nestify bnds) of
          EDE.Failure err -> do
            let (_errStyle, errRendered) = Colour.parseAnsiChunks Colour.noStyle (T.pack $ show err)
            pure (formatted {rendered = errRendered})
          EDE.Success renderedText -> do
            let (newStyle, newRendered) = Colour.parseAnsiChunks incomingStyle (TL.toStrict renderedText)
            _ <- updateStyle (const newStyle)
            pure (formatted {rendered = newRendered})

    nestify :: HashMap.HashMap T.Text Aeson.Value -> HashMap.HashMap T.Text Aeson.Value
    nestify flatMap = HashMap.fromList $ map (\(k, v) -> (Key.toText k, v)) $ 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

The idea is to parse the format with ede, injecting the accumulated bindings, which requires a bit of heavy lifting.