summaryrefslogtreecommitdiff
path: root/Biz/Lint.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Biz/Lint.hs')
-rw-r--r--Biz/Lint.hs137
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-01 07:29:08 +0000