diff options
| -rw-r--r-- | Biz/Lint.hs | 137 |
1 files changed, 102 insertions, 35 deletions
diff --git a/Biz/Lint.hs b/Biz/Lint.hs index 1fb04b0..5c3bef3 100644 --- a/Biz/Lint.hs +++ b/Biz/Lint.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} @@ -25,6 +26,8 @@ import Biz.Namespace (Ext (..), Namespace (..)) import qualified Biz.Namespace as Namespace import Biz.Test ((@=?)) import qualified Biz.Test as Test +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Char8 as Char8 import qualified Data.Map as Map import qualified Data.String as String import qualified Data.Text as Text @@ -82,7 +85,7 @@ Usage: |] exit :: [Result] -> IO () -exit results = Exit.exitWith <| if n > 0 then Exit.ExitFailure n else Exit.ExitSuccess +exit results = Exit.exitWith <| (n > 0) ?: (Exit.ExitFailure n, Exit.ExitSuccess) where n = length <| filter bad results bad = \case @@ -91,18 +94,24 @@ exit results = Exit.exitWith <| if n > 0 then Exit.ExitFailure n else Exit.ExitS _ -> False printResult :: Result -> IO Result -printResult r@(Warn err) = Log.warn ["lint", err] >> Log.br >> pure r -printResult r@(Done Linter {..} (Bad err)) = - Log.fail ["lint", exe] - >> Log.br - >> if err == "" then pure r else putText (Text.pack err) >> pure r -printResult r@(Done Linter {..} Good) = - Log.good ["lint", exe] - >> Log.br - >> pure r -printResult r@(NoOp ext) = - Log.info ["lint", "noop", show ext] - >> pure r +printResult r = case r of + Warn err -> + Log.warn ["lint", err] + >> Log.br + >> pure r + Done (Linter {..}) (Bad err) -> + Log.fail ["lint", exe] + >> Log.br + >> (err /= "") + ?| (putText <| Text.pack err) + >> pure r + Done (Linter {..}) Good -> + Log.good ["lint", exe] + >> Log.br + >> pure r + NoOp ext -> + Log.info ["lint", "noop", show ext] + >> pure r changedFiles :: IO [FilePath] changedFiles = @@ -121,19 +130,24 @@ data Mode data Linter = Linter { exe :: Text, - -- | Arguments added when in the "check" mode. + -- | Arguments added when in the "check" mode checkArgs :: [Text], - -- | Arguments added when in the "fix" mode. - fixArgs :: Maybe [Text] + -- | Arguments added when in the "fix" mode + fixArgs :: Maybe [Text], + -- | An optional function to format the output of the linter as you want + -- it, perhaps decoding json or something + formatter :: Maybe (String -> String) } - deriving (Show) + +-- deriving (Show) ormolu :: Linter ormolu = Linter { exe = "ormolu", checkArgs = ["--mode", "check", "--no-cabal"], - fixArgs = Just ["--mode", "inplace", "--no-cabal"] + fixArgs = Just ["--mode", "inplace", "--no-cabal"], + formatter = Nothing } hlint :: Linter @@ -143,7 +157,8 @@ hlint = checkArgs = [], -- needs apply-refact >0.9.1.0, which needs ghc >9 -- fixArgs = Just ["--refactor", "--refactor-options=-i"] - fixArgs = Nothing + fixArgs = Nothing, + formatter = Nothing } black :: Linter @@ -151,7 +166,8 @@ black = Linter { exe = "black", checkArgs = ["--check"], - fixArgs = Just [] + fixArgs = Just [], + formatter = Nothing } ruff :: Linter @@ -159,24 +175,69 @@ ruff = Linter { exe = "ruff", checkArgs = ["check"], - fixArgs = Just ["check", "--fix"] + fixArgs = Just ["check", "--fix"], + formatter = Nothing } +data DeadnixOutput = DeadnixOutput + { file :: FilePath, + results :: [DeadnixResult] + } + deriving (Generic, Aeson.FromJSON) + +data DeadnixResult = DeadnixResult + { column :: Int, + endColumn :: Int, + line :: Int, + message :: String + } + deriving (Generic, Aeson.FromJSON) + deadnix :: Linter deadnix = Linter { exe = "deadnix", checkArgs = "--fail" : commonArgs, - fixArgs = Just <| "--edit" : commonArgs + fixArgs = Just <| "--edit" : commonArgs, + formatter = Just decodeDeadnixOutput } where - commonArgs = ["--no-underscore", "--no-lambda-pattern-names"] + commonArgs = + [ -- "--no-underscore", + -- "--no-lambda-pattern-names", + "--output-format", + "json" + ] + +decodeDeadnixOutput :: String -> String +decodeDeadnixOutput deadnixJson = + deadnixJson |> Char8.pack |> Aeson.decodeStrict |> \case + Nothing -> panic "could not decode deadnix output" + Just o -> formatDeadnixOutput o + where + formatDeadnixOutput DeadnixOutput {..} = + joinWith "\n" <| map formatDeadnixResult results + where + formatDeadnixResult DeadnixResult {..} = + file <> ":" <> show line <> ":" <> show column <> ": " <> message shellcheck :: Linter -shellcheck = Linter {exe = "shellcheck", checkArgs = [], fixArgs = Nothing} +shellcheck = + Linter + { exe = "shellcheck", + checkArgs = [], + fixArgs = Nothing, + formatter = Nothing + } indent :: Linter -indent = Linter {exe = "indent", checkArgs = [], fixArgs = Nothing} +indent = + Linter + { exe = "indent", + checkArgs = [], + fixArgs = Nothing, + formatter = Nothing + } data Status = Good | Bad String deriving (Show) @@ -185,15 +246,16 @@ data Result = Done {linter :: Linter, status :: Status} | Warn Text | NoOp Namespace.Ext - deriving (Show) run :: Mode -> Map Namespace.Ext [Namespace] -> IO [Result] run mode nsmap = nsmap |> Map.assocs |> traverse (runOne mode) /> concat runOne :: Mode -> (Ext, [Namespace]) -> IO [Result] -runOne mode (ext, ns's) = results +> traverse_ printResult >> results +runOne mode (ext, ns's) = results +> traverse printResult where results = + -- i would run these with mapConcurrently, but the output gets mangled. to + -- do it right i need a queue for the results. someday. sequence <| case ext of Namespace.Hs -> [ lint mode ormolu ns's, @@ -210,13 +272,18 @@ runOne mode (ext, ns's) = results +> traverse_ printResult >> results lint :: Mode -> Linter -> [Namespace] -> IO Result lint mode linter@Linter {..} ns's = - Process.readProcessWithExitCode (Text.unpack exe) args "" /> \case - (Exit.ExitSuccess, _, _) -> - Done linter Good - (Exit.ExitFailure _, msg, _) -> - Done linter <| Bad msg + Log.info ["lint", exe, (tshow <| length ns's) <> " files"] + >> Process.readProcessWithExitCode (str exe) args "" /> \case + (Exit.ExitSuccess, _, _) -> + Done linter Good + (Exit.ExitFailure _, msg, _) -> case formatter of + Nothing -> Done linter <| Bad msg + Just fmt -> Done linter <| Bad <| fmt msg where args = case (mode, fixArgs) of - (Fix, Just args_) -> map Text.unpack args_ ++ map Namespace.toPath ns's - (Fix, Nothing) -> map Namespace.toPath ns's - (Check, _) -> map Text.unpack checkArgs ++ map Namespace.toPath ns's + (Fix, Just args_) -> + map str args_ ++ map Namespace.toPath ns's + (Fix, Nothing) -> + map Namespace.toPath ns's + (Check, _) -> + map str checkArgs ++ map Namespace.toPath ns's |