From b782cc34f76fa295026b7e6d5c14930769ba5773 Mon Sep 17 00:00:00 2001
From: "J. Konrad Tegtmeier-Rottach" <jktr@0x16.de>
Date: Wed, 3 May 2023 00:12:37 +0200
Subject: [PATCH] Add type signatures where ghc complains about them
---
qbar/src/QBar/BlockHelper.hs | 4 +++-
qbar/src/QBar/Blocks/Date.hs | 2 +-
qbar/src/QBar/Blocks/NetworkManager.hs | 7 ++++++-
qbar/src/QBar/Blocks/Qubes.hs | 23 +++++++++++++++++++----
qbar/src/QBar/Blocks/Script.hs | 11 +++++++++--
qbar/src/QBar/Color.hs | 11 +++++++----
qbar/src/QBar/Host.hs | 9 ++++++---
qbar/src/QBar/Qubes/AdminAPI.hs | 12 +++++++++++-
qbar/src/QBar/Server.hs | 11 ++++++++++-
qbar/src/QBar/Theme.hs | 4 +---
qbar/src/QBar/Time.hs | 2 +-
11 files changed, 74 insertions(+), 22 deletions(-)
diff --git a/qbar/src/QBar/BlockHelper.hs b/qbar/src/QBar/BlockHelper.hs
index 6366bf8..8d51274 100644
--- a/qbar/src/QBar/BlockHelper.hs
+++ b/qbar/src/QBar/BlockHelper.hs
@@ -195,7 +195,9 @@ runSignalBlockConfiguration SignalBlockConfiguration{aquire, release, signalThre
sendSignal signal = do
maybeOutput <- request signal
- let updateInvalidatedState = if isEventSignal signal then (_2 .~ False) else id
+ let
+ updateInvalidatedState :: (Maybe BlockUpdate, Bool) -> (Maybe BlockUpdate, Bool)
+ updateInvalidatedState = if isEventSignal signal then _2 .~ False else id
let blockUpdate = (mkBlockStateWithHandler maybeOutput, signalToReason signal)
liftIO . atomically $ modifyTVar renderStateVar ((_1 . _Just .~ blockUpdate) . updateInvalidatedState)
diff --git a/qbar/src/QBar/Blocks/Date.hs b/qbar/src/QBar/Blocks/Date.hs
index 9194dac..dcafa7e 100644
--- a/qbar/src/QBar/Blocks/Date.hs
+++ b/qbar/src/QBar/Blocks/Date.hs
@@ -16,7 +16,7 @@ import Data.Time.LocalTime
dateBlock :: Block
dateBlock = runPollBlock' (everyNSeconds 60) $ forever $ do
zonedTime <- liftIO getZonedTime
- let logo = "📅\xFE0E "
+ let logo :: Text = "📅\xFE0E "
let date = T.pack (formatTime defaultTimeLocale "%a %F" zonedTime)
let time = T.pack (formatTime defaultTimeLocale "%R" zonedTime)
let text = normalText (logo <> date <> " ") <> activeText time
diff --git a/qbar/src/QBar/Blocks/NetworkManager.hs b/qbar/src/QBar/Blocks/NetworkManager.hs
index 6c84053..6aa7c15 100644
--- a/qbar/src/QBar/Blocks/NetworkManager.hs
+++ b/qbar/src/QBar/Blocks/NetworkManager.hs
@@ -74,8 +74,13 @@ networkManagerBlock = runSignalBlockConfiguration $ SignalBlockConfiguration {
return client
release :: DBus.Client -> BarIO ()
release = liftIO . DBus.disconnect
+
networkManagerBlock' :: DBus.Client -> SignalBlock ()
- networkManagerBlock' client = (liftBarIO . networkManagerBlock'' client) >=> respondBlockUpdate >=> networkManagerBlock' client
+ networkManagerBlock' client
+ = (liftBarIO . networkManagerBlock'' client)
+ >=> (\x -> respondBlockUpdate x) -- why doesn't this type check without \->?
+ >=> networkManagerBlock' client
+
networkManagerBlock'' :: DBus.Client -> Signal () -> BarIO BlockOutput
networkManagerBlock'' client _ = do
primaryConnection <- runExceptT_ $ getPrimaryConnectionPath client
diff --git a/qbar/src/QBar/Blocks/Qubes.hs b/qbar/src/QBar/Blocks/Qubes.hs
index f0e0ede..14dd6d4 100644
--- a/qbar/src/QBar/Blocks/Qubes.hs
+++ b/qbar/src/QBar/Blocks/Qubes.hs
@@ -30,12 +30,17 @@ diskUsageQubesBlock = runPollBlock $ forever $ do
action = liftIO qubesUsageOfDefaultPool >>= \case
(Just usage, Just size) -> return $ createBlockOutput $ size - usage
_ -> return $ mkErrorOutput "unknown"
+
createBlockOutput :: Int -> BlockOutput
createBlockOutput free =
mkBlockOutput $ chooseColor free $ formatSize free
+
+ chooseColor :: Int -> Text -> BlockText
chooseColor free = if free < 40 * 1024*1024*1024
then activeText
else normalText
+
+ sizeUnits :: [(Text, Int)]
sizeUnits = [
("T", 1024*1024*1024*1024),
("G", 1024*1024*1024),
@@ -52,8 +57,10 @@ pipeBlockWithEvents prod block = runSignalBlock Nothing (Just produce) sblock
where
produce :: (a -> IO ()) -> BarIO ()
produce yield' = runEffect $ prod >-> forever (await >>= liftIO . yield')
+
sblock :: Signal a -> P.Server (Signal a) (Maybe BlockOutput) BarIO ExitBlock
sblock = lift . sblock' >=> respond >=> sblock
+
sblock' :: Signal a -> BarIO (Maybe BlockOutput)
sblock' RegularSignal = return Nothing -- ignore timer
sblock' (UserSignal x) = block $ Right x
@@ -62,12 +69,20 @@ pipeBlockWithEvents prod block = runSignalBlock Nothing (Just produce) sblock
qubesMonitorPropertyBlock :: BL.ByteString -> Block
qubesMonitorPropertyBlock name = pipeBlockWithEvents (qubesMonitorProperty qubesEvents name) handle
where
+ handle :: Either a QubesPropertyInfo -> BarIO (Maybe BlockOutput)
handle = fmap handle' . either (const $ liftIO $ qubesGetProperty name) return
+
handle' QubesPropertyInfo {propValue, propIsDefault} = Just $ mkBlockOutput $ normalText $ decode propValue <> (if propIsDefault then " (D)" else "")
decode = decodeUtf8With lenientDecode
qubesVMCountBlock :: Block
-qubesVMCountBlock = pipeBlockWithEvents qubesListVMsP $ fmap countVMs . either (const $ liftIO $ qubesListVMs) return where
- countVMs = Just . format . M.size . M.filterWithKey isRunningVM
- isRunningVM name x = vmState x == VMRunning && name /= "dom0"
- format n = mkBlockOutput $ normalText $ T.pack (show n) <> " Qube" <> (if n /= 1 then "s" else "")
+qubesVMCountBlock = pipeBlockWithEvents qubesListVMsP $ fmap countVMs . either (const $ liftIO qubesListVMs) return
+ where
+ countVMs :: M.Map BL.ByteString QubesVMInfo -> Maybe BlockOutput
+ countVMs = Just . format . M.size . M.filterWithKey isRunningVM
+
+ isRunningVM :: BL.ByteString -> QubesVMInfo -> Bool
+ isRunningVM name x = vmState x == VMRunning && name /= "dom0"
+
+ format :: Int -> BlockOutput
+ format n = mkBlockOutput $ normalText $ T.pack (show n) <> " Qube" <> (if n /= 1 then "s" else "")
diff --git a/qbar/src/QBar/Blocks/Script.hs b/qbar/src/QBar/Blocks/Script.hs
index 352a964..37b799e 100644
--- a/qbar/src/QBar/Blocks/Script.hs
+++ b/qbar/src/QBar/Blocks/Script.hs
@@ -28,7 +28,11 @@ import System.Process.Typed (Process, shell, setStdin, setStdout,
pollScriptBlock :: Interval -> FilePath -> Block
-pollScriptBlock interval path = runPollBlock' interval $ forever $ yieldBlockUpdate =<< (lift blockScriptAction)
+pollScriptBlock interval path = runPollBlock' interval $ forever $ do
+ -- Why doesn't this typecheck when using >>= instead?
+ x <- lift blockScriptAction
+ yieldBlockUpdate x
+
where
blockScriptAction :: BarIO BlockOutput
blockScriptAction = do
@@ -58,6 +62,7 @@ scriptBlock clickEvents path = startScriptProcess
startScriptProcess
Right x -> x
where
+ result :: Either Text Block
result = case (isEOFError exc, exitCode) of
(True, Just ExitSuccess) -> Right exitBlock
(True, Just (ExitFailure nr)) ->
@@ -92,7 +97,9 @@ scriptBlock clickEvents path = startScriptProcess
else startScriptProcessNoEvents
startScriptProcessNoEvents :: Block
startScriptProcessNoEvents = do
- let processConfig = setStdin closed $ setStdout createPipe $ shell path
+ let
+ processConfig :: ProcessConfig () Handle ()
+ processConfig = setStdin closed $ setStdout createPipe $ shell path
process <- startProcess processConfig
-- The inner catchP catches errors that happen after the process has been created
-- This handler will also make sure the process is stopped
diff --git a/qbar/src/QBar/Color.hs b/qbar/src/QBar/Color.hs
index be259fe..fa45c54 100644
--- a/qbar/src/QBar/Color.hs
+++ b/qbar/src/QBar/Color.hs
@@ -16,8 +16,11 @@ import Numeric (showHex)
data Color = ColorRGB (RGB Double) | ColorRGBA (RGB Double) Double
deriving (Eq, Show)
+
instance FromJSON Color where
- parseJSON = withText "Color" $ either fail pure . parseOnly (colorParser <* endOfInput)
+ parseJSON :: Value -> AT.Parser Color
+ parseJSON = withText "Color" $ either fail pure . A.parseOnly (colorParser <* endOfInput) . T.fromStrict
+
instance ToJSON Color where
toJSON = String . T.toStrict . hexColorText
@@ -39,17 +42,17 @@ hexColorText = hexColor'
paddedHexComponent :: Text -> Text
paddedHexComponent hex =
let len = 2 - T.length hex
- padding = if len == 1 then "0" else ""
+ padding :: Text = if len == 1 then "0" else ""
in padding <> hex
-colorParser :: Parser Color
+colorParser :: A.Parser Color
colorParser = do
void $ char '#'
rgb <- RGB <$> doubleFromHex2 <*> doubleFromHex2 <*> doubleFromHex2
option (ColorRGB rgb) (ColorRGBA rgb <$> doubleFromHex2)
where
- doubleFromHex2 :: Parser Double
+ doubleFromHex2 :: A.Parser Double
doubleFromHex2 = (/ 256) . fromIntegral <$> hexadecimal'' 2
-- Variant of 'Data.Attoparsec.Text.hexadecimal' that parses a fixed amount of digits.
diff --git a/qbar/src/QBar/Host.hs b/qbar/src/QBar/Host.hs
index 50e2aee..75f01fd 100644
--- a/qbar/src/QBar/Host.hs
+++ b/qbar/src/QBar/Host.hs
@@ -240,11 +240,14 @@ runBarHost' initializeBarAction = do
attachBarOutputImpl :: MVar ExitCode -> Producer [BlockOutput] IO () -> Consumer BlockEvent IO () -> (Consumer [BlockOutput] IO (), Producer BlockEvent IO ()) -> IO ()
attachBarOutputImpl exitMVar blockOutputProducer eventConsumer (barOutputConsumer, barEventProducer) = do
-
- let handleBarEventInput = liftIO $ runEffect $ barEventProducer >-> eventConsumer
+ let
+ handleBarEventInput :: IO ()
+ handleBarEventInput = liftIO $ runEffect $ barEventProducer >-> eventConsumer
liftIO $ void $ forkFinally handleBarEventInput $ handleOnExitCodeException (\result -> hPutStrLn stderr $ "An event input handler failed: " <> show result)
- let handleBarOutput = liftIO $ runEffect $ blockOutputProducer >-> filterDuplicates >-> barOutputConsumer
+ let
+ handleBarOutput :: IO ()
+ handleBarOutput = liftIO $ runEffect $ blockOutputProducer >-> filterDuplicates >-> barOutputConsumer
liftIO $ void $ forkFinally handleBarOutput $ handleOnExitCodeException (\result -> hPutStrLn stderr $ "A bar output handler failed: " <> show result)
where
diff --git a/qbar/src/QBar/Qubes/AdminAPI.hs b/qbar/src/QBar/Qubes/AdminAPI.hs
index 73a7146..649779d 100644
--- a/qbar/src/QBar/Qubes/AdminAPI.hs
+++ b/qbar/src/QBar/Qubes/AdminAPI.hs
@@ -79,6 +79,8 @@ instance Binary QubesAdminReturn where
where
getPairs = untilZeroByte $ (,) <$> getLazyByteStringNul <*> getLazyByteStringNul
getFields = untilZeroByte getLazyByteStringNul
+
+ untilZeroByte :: Get a -> Get [a]
untilZeroByte inner = lookAhead getWord8 >>= \case
0x00 -> getWord8 >> return []
_ -> inner >>= \x -> (x:) <$> untilZeroByte inner
@@ -110,6 +112,7 @@ qubesTryAdminCall serviceName args = do
qubesAdminCall :: BL.ByteString -> [BL.ByteString] -> IO BL.ByteString
qubesAdminCall serviceName args = qubesTryAdminCall serviceName args >>= extract where
+ extract :: QubesAdminReturn -> IO BLC.ByteString
extract Ok {okContent} = return okContent
extract x@Exception {} = fail $ "service has returned an exception: " <> show x
extract Event {} = fail "service has returned events instead of a reply"
@@ -164,7 +167,9 @@ qubesVMStats = qubesVMStatsRaw >-> P.mapFoldable parse where
| otherwise = Nothing -- shouldn't happen -> report error?
parse _ = Nothing -- shouldn't happen -> report error?
- absent = (-1)
+ absent :: Int = -1
+
+ readBL :: BLC.ByteString -> Int
readBL = read . BLC.unpack
addProperties :: [(BL.ByteString, BL.ByteString)] -> QubesVMStats -> QubesVMStats
@@ -313,6 +318,7 @@ qubesGetPoolInfo name = map parseLine <$> qubesAdminCallLines "admin.pool.Info"
qubesUsageOfDefaultPool :: IO (Maybe Int, Maybe Int)
qubesUsageOfDefaultPool = qubesGetDefaultPool >>= qubesGetPoolInfo >>= extract
where
+ extract :: [(BLC.ByteString, BLC.ByteString)] -> IO (Maybe Int, Maybe Int)
extract props = return (tryReadProp "usage" props, tryReadProp "size" props)
tryReadProp :: Read a => BL.ByteString -> [(BL.ByteString, BL.ByteString)] -> Maybe a
tryReadProp name props = readMaybe . BLC.unpack =<< lookup name props
@@ -348,7 +354,10 @@ qubesMonitorProperty :: forall m. MonadIO m
=> Producer QubesEvent m () -> BL.ByteString -> Producer QubesPropertyInfo m ()
qubesMonitorProperty events name = events >-> P.filter isRelevant >-> fetchValue
where
+ fetchValue :: Proxy () QubesEvent () QubesPropertyInfo m b
fetchValue = liftIO (qubesGetProperty name) >>= go
+
+ go :: QubesPropertyInfo -> Proxy () QubesEvent () QubesPropertyInfo m b
go x = do
yield x
ev <- await
@@ -356,6 +365,7 @@ qubesMonitorProperty events name = events >-> P.filter isRelevant >-> fetchValue
PropertySet {newValue} -> go $ x { propIsDefault = False, propValue = newValue }
PropertyDel {} -> fetchValue
_ -> go x
+
isRelevant PropertySet {changedProperty} = name == changedProperty
isRelevant PropertyDel {changedProperty} = name == changedProperty
isRelevant _ = False
diff --git a/qbar/src/QBar/Server.hs b/qbar/src/QBar/Server.hs
index 3737c9c..bd18213 100644
--- a/qbar/src/QBar/Server.hs
+++ b/qbar/src/QBar/Server.hs
@@ -44,9 +44,16 @@ instance ToJSON PangoBlock where
toJSON PangoBlock{pangoBlockFullText, pangoBlockShortText, pangoBlockName} = object $
fullText' <> shortText' <> blockName' <> pango'
where
+ fullText' :: [AT.Pair]
fullText' = [ "full_text" .= pangoBlockFullText ]
+
+ shortText' :: [AT.Pair]
shortText' = fromMaybe (\s -> ["short_text" .= s]) mempty pangoBlockShortText
+
+ blockName' :: [AT.Pair]
blockName' = fromMaybe (\s -> ["name" .= s]) mempty pangoBlockName
+
+ pango' :: [AT.Pair]
pango' = [ "markup" .= ("pango" :: T.Text) ]
@@ -64,7 +71,9 @@ swayBarInput MainOptions{verbose} = swayBarInput'
liftIO $ BSSC8.hPutStrLn stderr line
hFlush stderr
- let maybeBlockEvent = decode $ removeComma $ BS.fromStrict line
+ let
+ maybeBlockEvent :: Maybe BlockEvent
+ maybeBlockEvent = decode $ removeComma $ BS.fromStrict line
forM_ maybeBlockEvent yield
swayBarInput'
diff --git a/qbar/src/QBar/Theme.hs b/qbar/src/QBar/Theme.hs
index 3c92f85..d1c20a9 100644
--- a/qbar/src/QBar/Theme.hs
+++ b/qbar/src/QBar/Theme.hs
@@ -50,7 +50,6 @@ data ThemedBlockTextSegment = ThemedBlockTextSegment {
}
deriving (Eq, Show)
-
data Theme = StaticTheme StaticTheme | AnimatedTheme AnimatedTheme
type StaticTheme = [BlockOutput] -> [ThemedBlockOutput]
@@ -78,6 +77,7 @@ themes = HM.fromList themesList
findTheme :: Text -> Either Text Theme
findTheme themeName = maybe invalidThemeName Right $ HM.lookup themeName themes
where
+ invalidThemeName :: Either Text Theme
invalidThemeName = Left $ "Invalid theme: " <> themeName
mkTheme :: SimplifiedTheme -> Theme
@@ -122,7 +122,6 @@ mkThemedSegment (color, backgroundColor) text = ThemedBlockTextSegment{themedSeg
whiteThemedBlockOutput :: Text -> ThemedBlockOutput
whiteThemedBlockOutput = mkThemedBlockOutput (ColorRGB (RGB 1 1 1), Nothing)
-
invalidColor :: Color
invalidColor = ColorRGBA (RGB (0x96 / 255) (0x98 / 255) (0x96 / 255)) (0x77 / 255)
@@ -142,7 +141,6 @@ defaultTheme = mkTheme defaultTheme'
defaultTheme' True (NormalImportant _) = (ColorRGB (RGB 1 1 1), Nothing)
defaultTheme' False (NormalImportant _) = (ColorRGB (RGB (0x96 / 255) (0x98 / 255) (0x96 / 255)), Nothing)
-
rainbowTheme :: Theme
rainbowTheme = AnimatedTheme rainbowThemePipe
where
diff --git a/qbar/src/QBar/Time.hs b/qbar/src/QBar/Time.hs
index 15a2121..af315a2 100644
--- a/qbar/src/QBar/Time.hs
+++ b/qbar/src/QBar/Time.hs
@@ -39,7 +39,7 @@ nextIntervalTime :: MonadIO m => Interval -> m UTCTime
nextIntervalTime (IntervalSeconds intervalSeconds) = liftIO $ do
now <- getCurrentTime
let dayTime = utctDayTime now
- let daySeconds = floor dayTime
+ let daySeconds :: Integer = floor dayTime
let intervalId = daySeconds `div` intervalSeconds
return now {
utctDayTime = fromInteger $ (intervalId + 1) * intervalSeconds
--
GitLab