From 7bd0a652cbed604c1b46d1c96d8128ccf6eb1c6d Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Fri, 2 Oct 2026 15:03:45 +0300 Subject: [PATCH] Clean hlint and cabal warnings --- home-assistant-controller.cabal | 2 +- src/AFRP.hs | 10 ++++------ src/HomeAssistant/Controller/Ruuvi.hs | 1 - src/HomeAssistant/Runtime/Connection.hs | 3 +-- src/HomeAssistant/Runtime/Flags.hs | 2 +- src/HomeAssistant/Runtime/Graphing.hs | 6 +++--- src/HttpServer.hs | 2 +- test/AFRPLawsSpec.hs | 4 ++++ test/AFRPSpec.hs | 5 +++-- test/BusSpec.hs | 3 +-- test/ConnectionSpec.hs | 4 +--- test/ControllerSpec.hs | 1 - test/FlagsSpec.hs | 2 +- test/GraphingSpec.hs | 2 +- test/MetricsSpec.hs | 2 +- test/Support.hs | 3 ++- 16 files changed, 25 insertions(+), 27 deletions(-) diff --git a/home-assistant-controller.cabal b/home-assistant-controller.cabal index 188475a..d1b45ee 100644 --- a/home-assistant-controller.cabal +++ b/home-assistant-controller.cabal @@ -52,7 +52,7 @@ extra-doc-files: CHANGELOG.md -- extra-source-files: common warnings - ghc-options: -Wall + ghc-options: -Wall -Werror library -- Import common warning flags. diff --git a/src/AFRP.hs b/src/AFRP.hs index 9688f52..4fcb319 100644 --- a/src/AFRP.hs +++ b/src/AFRP.hs @@ -1,5 +1,4 @@ {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE Arrows #-} module AFRP ( Mealy(..) @@ -129,7 +128,7 @@ instance Monad m => Applicative (Auto m a) where pure a = Fun (\_req -> const a) fa <*> fb = case (fa,fb) of - (Fun af, Fun bf) -> Fun $ \req -> (af req <*> bf req) + (Fun af, Fun bf) -> Fun $ \req -> af req <*> bf req (Stateful codec s af, Fun bf) -> Stateful codec s (\s' req x -> do let a = bf req x @@ -179,7 +178,7 @@ instance (Monad m, Monoid b) => Monoid (Auto m a b) where instance Monad m => Category (Auto m) where - id = Fun $ \_ -> id + id = Fun $ const id af . ag = case (af, ag) of (Fun f, Fun g) -> Fun (\req -> f req . g req) @@ -272,8 +271,6 @@ instance Semigroup b => Semigroup (Mealy eff a b) where instance Monoid b => Monoid (Mealy eff a b) where mempty = Mealy mempty $ \_nt -> mempty - -- where - -- m = Mealy mempty $ \_ _ _ -> pure (Pair mempty m) eff :: (Request -> a -> eff b) -> Mealy eff a b eff f = Mealy mempty $ \nt -> do @@ -288,7 +285,8 @@ withEntities :: S.Set T.Text -> Mealy eff a b -> Mealy eff a b withEntities es (Mealy _ f) = Mealy es f instance Category (Mealy eff) where - id = Mealy mempty (\_ -> id) + {- HLINT ignore "Use const" -} + id = Mealy mempty $ \_nt -> id (Mealy ast f) . (Mealy bst g) = Mealy (ast <> bst) $ \nt -> do f nt . g nt diff --git a/src/HomeAssistant/Controller/Ruuvi.hs b/src/HomeAssistant/Controller/Ruuvi.hs index 52c8a14..39a49e6 100644 --- a/src/HomeAssistant/Controller/Ruuvi.hs +++ b/src/HomeAssistant/Controller/Ruuvi.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE Arrows #-} {-# LANGUAGE OverloadedStrings #-} module HomeAssistant.Controller.Ruuvi ( Ruuvi(..) diff --git a/src/HomeAssistant/Runtime/Connection.hs b/src/HomeAssistant/Runtime/Connection.hs index 4e62d10..f0403a7 100644 --- a/src/HomeAssistant/Runtime/Connection.hs +++ b/src/HomeAssistant/Runtime/Connection.hs @@ -36,10 +36,9 @@ import Data.UUID (toText) import AFRP (Request(..), Event(..)) import Control.Monad.IO.Class (liftIO, MonadIO) import HomeAssistant.Runtime.RateLimit (RateLimited, RateLimiter, runRateLimited) -import Control.Monad.Catch (MonadCatch) import GHC.Stack (HasCallStack) import UnliftIO (MonadUnliftIO, race, withRunInIO) -import Control.Monad.Catch (onException) +import Control.Monad.Catch (MonadCatch, onException) -- | Connect, authenticate, subscribe, then receive and broadcast forever. -- Restarting this action reconnects. All setup sends happen before the diff --git a/src/HomeAssistant/Runtime/Flags.hs b/src/HomeAssistant/Runtime/Flags.hs index 684055f..0bfb9c4 100644 --- a/src/HomeAssistant/Runtime/Flags.hs +++ b/src/HomeAssistant/Runtime/Flags.hs @@ -44,7 +44,7 @@ loadFlags rootPath allNames = do let path = rootPath "handlers.json" fileMap <- readFlagsFile path let defaults = M.fromList [(n, True) | n <- allNames] - initial = M.unionWith (\fileVal -> const fileVal) fileMap defaults + initial = M.unionWith const fileMap defaults tv <- liftIO $ newTVarIO initial lock <- liftIO $ newMVar () pure Flags diff --git a/src/HomeAssistant/Runtime/Graphing.hs b/src/HomeAssistant/Runtime/Graphing.hs index dfd8cb8..b34a95a 100644 --- a/src/HomeAssistant/Runtime/Graphing.hs +++ b/src/HomeAssistant/Runtime/Graphing.hs @@ -190,10 +190,10 @@ cfName = \case defArgs :: FilePath -> Series -> [String] defArgs rrdPath series = - [ "DEF:" ++ rawF ++ "=" ++ rrdPath ++ ":" + ( "DEF:" ++ rawF ++ "=" ++ rrdPath ++ ":" ++ srcDs source ++ ":" ++ cfName (srcCF source) - ] - ++ transformArgs + ) + : transformArgs where source = serSource series alias = serAlias series diff --git a/src/HttpServer.hs b/src/HttpServer.hs index 6d4f0a5..4ff3521 100644 --- a/src/HttpServer.hs +++ b/src/HttpServer.hs @@ -43,7 +43,7 @@ data API mode = API getFlagsHandler :: Flags -> LoggingHandler (Map Text Bool) -getFlagsHandler flags = allFlags flags +getFlagsHandler = allFlags putFlagHandler :: Flags -> Text -> Bool -> LoggingHandler (Map Text Bool) putFlagHandler flags name val diff --git a/test/AFRPLawsSpec.hs b/test/AFRPLawsSpec.hs index fa38617..8c15bc5 100644 --- a/test/AFRPLawsSpec.hs +++ b/test/AFRPLawsSpec.hs @@ -12,6 +12,10 @@ import Support (fakeRequest) import Test.Hspec (Spec, describe, it) import Test.Hspec.Hedgehog (forAll, forAllWith, hedgehog, (===)) +-- We are testing laws -> hlint warns about not using laws +{-# ANN module "Hlint: ignore" #-} + + -- | Law tests for the Mealy instances. Two machines count as equal when -- they emit equal outputs on every input sequence, so each law runs both -- sides on generated inputs. diff --git a/test/AFRPSpec.hs b/test/AFRPSpec.hs index f201dc3..c5074a5 100644 --- a/test/AFRPSpec.hs +++ b/test/AFRPSpec.hs @@ -19,6 +19,7 @@ import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Test.Hspec import Test.Hspec.Hedgehog +import Data.Maybe (listToMaybe) fakeRequest :: Request fakeRequest = Request (sec 0) utc nil "test" @@ -52,7 +53,7 @@ instance Functor St where fmap f (St g) = St $ \s -> let (a, s') = g s in (f a, s') instance Applicative St where - pure a = St (\s -> (a, s)) + pure a = St (a,) St f <*> St x = St $ \s -> let (f', s') = f s; (a, s'') = x s' in (f' a, s'') instance Monad St where @@ -165,7 +166,7 @@ lMergeSpec = describe "lMerge" $ do changesSpec :: Spec changesSpec = describe "changes" $ do it "first output is always Tick" $ - runPure changes "hello" !! 0 `shouldBe` Tick + listToMaybe (runPure changes "hello") `shouldBe` Just Tick it "outputs Event only on value change" $ runPure changes "aaaabbbcca" diff --git a/test/BusSpec.hs b/test/BusSpec.hs index 08d08c7..f5b32fc 100644 --- a/test/BusSpec.hs +++ b/test/BusSpec.hs @@ -6,7 +6,7 @@ import AFRP (Request (..), Event (..)) import Control.Concurrent.STM ( atomically , dupTChan - , isEmptyTChan + , readTChan , writeTChan ) @@ -18,7 +18,6 @@ import HomeAssistant.Controller (HASSEff (..), Service (..), Target(..)) import HomeAssistant.Runtime.Bus import HomeAssistant.Runtime.Flags (loadFlags, setEnabled) import HomeAssistant.Runtime.Metrics (registerAppMetrics) -import Control.Monad.IO.Class (liftIO) import Katip (Namespace (Namespace), runKatipContextT) import Katip.Monadic (runNoLoggingT) import Support (withTestLogEnv) diff --git a/test/ConnectionSpec.hs b/test/ConnectionSpec.hs index 0fb7df7..06915f1 100644 --- a/test/ConnectionSpec.hs +++ b/test/ConnectionSpec.hs @@ -80,7 +80,5 @@ req n = Request (UTCTime (toEnum 0) (fromIntegral (0 :: Int))) utc uuid = "00000000-0000-0000-0000-" <> pad n lightOn :: [Target] -> Service -lightOn targets = Service "light" "turn_on" Nothing targets +lightOn = Service "light" "turn_on" Nothing -lightOff :: [Target] -> Service -lightOff targets = Service "light" "turn_off" Nothing targets diff --git a/test/ControllerSpec.hs b/test/ControllerSpec.hs index aa9ec80..da470ac 100644 --- a/test/ControllerSpec.hs +++ b/test/ControllerSpec.hs @@ -4,7 +4,6 @@ import Test.Hspec import Data.Default (def) import HomeAssistant.Controller (Brightness(..), formatLightAttributes, LightAttributes(..)) import Data.Aeson (object, (.=)) -import HomeAssistant.Controller () spec :: Spec diff --git a/test/FlagsSpec.hs b/test/FlagsSpec.hs index a8dcd8d..11d23ef 100644 --- a/test/FlagsSpec.hs +++ b/test/FlagsSpec.hs @@ -70,7 +70,7 @@ spec = describe "Flags" $ do n <- forAll $ Gen.int (Range.linear 1 50) liftIO $ withTempDirectory "/tmp" "flags-spec" $ \dir -> do flags <- runNoLoggingT (loadFlags dir ["x"]) - mapConcurrently_ (\i -> setEnabled flags "x" (even i)) [1 .. n] + mapConcurrently_ (setEnabled flags "x" . even) [1 .. n] m <- allFlags flags decoded <- decodeFileStrict (dir <> "/handlers.json") (decoded :: Maybe (Map Text Bool)) `shouldBe` Just m diff --git a/test/GraphingSpec.hs b/test/GraphingSpec.hs index 1028a7f..f68500b 100644 --- a/test/GraphingSpec.hs +++ b/test/GraphingSpec.hs @@ -7,6 +7,7 @@ import qualified Data.ByteString as BS import HomeAssistant.Runtime.Graphing ( GraphSpec (..) , Range (..) + , Graph(..) , buildGraphArgs , graphs , lookupGraph @@ -21,7 +22,6 @@ import System.Exit (ExitCode (..)) import System.Process (readProcessWithExitCode) import Test.Hspec import Servant.API (FromHttpApiData(..), ToHttpApiData (..)) -import HomeAssistant.Runtime.Graphing (Graph(..)) traffic :: GraphSpec traffic = case lookupGraph graphs Traffic of diff --git a/test/MetricsSpec.hs b/test/MetricsSpec.hs index e648be5..0b026a6 100644 --- a/test/MetricsSpec.hs +++ b/test/MetricsSpec.hs @@ -147,7 +147,7 @@ spec = do parseInfoDs "step = 10\nrra[0].cf = \"AVERAGE\"\n" `shouldBe` [] describe "schemaMatches" $ do - let ds name ty = DsSpec (T.pack name) name ty + let ds name = DsSpec (T.pack name) name it "is true for identical schemas regardless of order" $ schemaMatches [ds "b" Gauge, ds "a" Derive] [("a", Derive), ("b", Gauge)] `shouldBe` True diff --git a/test/Support.hs b/test/Support.hs index eb621be..81e4340 100644 --- a/test/Support.hs +++ b/test/Support.hs @@ -36,7 +36,7 @@ instance Functor Acc where fmap f (Acc g) = Acc $ \s -> let (a, s') = g s in (f a, s') instance Applicative Acc where - pure a = Acc (\s -> (a, s)) + pure a = Acc (a,) Acc f <*> Acc x = Acc $ \s -> let (f', s') = f s; (a, s'') = x s' in (f' a, s'') instance Monad Acc where @@ -52,6 +52,7 @@ withTestLogEnv = bracket (initLogEnv "test" "test") closeScribes -- | Interpret `HASSEff` in `Acc`: record `CallService`, drop tracing/debug. interp :: HASSEff a -> Acc a interp (CallService _ svc) = Acc $ \s -> ((), s ++ [svc]) +interp (CallServices _ svc) = Acc $ \s -> ((), s ++ svc) interp (Debug _) = pure () interp (Trace _ _) = pure ()