From ffe3fd8a719be8d02b03bac6bc8232a7bc9fa692 Mon Sep 17 00:00:00 2001
From: Ben Sima <ben@bsima.me>
Date: Tue, 22 Aug 2023 17:15:50 -0400
Subject: Lint faster by grouping files by extension
Previously I would lint every file individually, in serial. This took
forever. Now I group the files by extension (by first getting the Namespace) and
run each linter on all relevant files at once. This is so much faster its
stupid.
Also I added formatters back into the dev env because my editor needs them to
autoformat.
---
Biz/Lint.hs | 104 ++++++++++++++++++++++++++++++++----------------------------
1 file changed, 56 insertions(+), 48 deletions(-)
(limited to 'Biz/Lint.hs')
diff --git a/Biz/Lint.hs b/Biz/Lint.hs
index 2742fae..1fb04b0 100644
--- a/Biz/Lint.hs
+++ b/Biz/Lint.hs
@@ -25,35 +25,48 @@ import Biz.Namespace (Ext (..), Namespace (..))
import qualified Biz.Namespace as Namespace
import Biz.Test ((@=?))
import qualified Biz.Test as Test
+import qualified Data.Map as Map
import qualified Data.String as String
import qualified Data.Text as Text
import qualified System.Directory as Directory
import qualified System.Environment as Environment
import qualified System.Exit as Exit
-import System.FilePath ((</>))
import qualified System.Process as Process
main :: IO ()
main = Cli.main <| Cli.Plan help move test pure
move :: Cli.Arguments -> IO ()
-move args = case Cli.getAllArgs args (Cli.argument "file") of
- [] -> changedFiles +> run mode +> exit
- files ->
- files
- |> filter (not <. Namespace.isCab)
- |> filterM Directory.doesFileExist
- +> run mode
- +> exit
+move args =
+ Environment.getEnv "BIZ_ROOT" +> \root ->
+ case Cli.getAllArgs args (Cli.argument "file") of
+ [] ->
+ changedFiles
+ +> traverse Directory.makeAbsolute
+ /> map (Namespace.fromPath root)
+ /> catMaybes
+ /> Namespace.groupByExt
+ +> run mode
+ +> exit
+ files ->
+ files
+ |> filter (not <. Namespace.isCab)
+ |> traverse Directory.makeAbsolute
+ +> filterM Directory.doesFileExist
+ /> map (Namespace.fromPath root)
+ /> catMaybes
+ /> Namespace.groupByExt
+ +> run mode
+ +> exit
where
- mode = if Cli.has args (Cli.longOption "fix") then Fix else Check
+ mode = args `Cli.has` Cli.longOption "fix" ?: (Fix, Check)
test :: Test.Tree
test =
Test.group
"Biz.Lint"
[ Test.unit "haskell files return two Results" <| do
- results <- run Check ["Biz/Lint.hs"]
+ results <- run Check <| Map.singleton Hs <| [Namespace ["Biz", "Lint"] Hs]
length results @=? 2
]
@@ -74,21 +87,21 @@ exit results = Exit.exitWith <| if n > 0 then Exit.ExitFailure n else Exit.ExitS
n = length <| filter bad results
bad = \case
(Warn _) -> False
- Ok {status = Bad _} -> True
+ Done {status = Bad _} -> True
_ -> False
printResult :: Result -> IO Result
printResult r@(Warn err) = Log.warn ["lint", err] >> Log.br >> pure r
-printResult r@(Ok path_ Linter {..} (Bad err)) =
- Log.fail ["lint", exe, Text.pack path_]
+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@(Ok path_ Linter {..} Good) =
- Log.good ["lint", exe, Text.pack path_]
+printResult r@(Done Linter {..} Good) =
+ Log.good ["lint", exe]
>> Log.br
>> pure r
-printResult r@(NoOp path_) =
- Log.info ["lint", "noop", Text.pack path_]
+printResult r@(NoOp ext) =
+ Log.info ["lint", "noop", show ext]
>> pure r
changedFiles :: IO [FilePath]
@@ -169,46 +182,41 @@ data Status = Good | Bad String
deriving (Show)
data Result
- = Ok {path :: FilePath, linter :: Linter, status :: Status}
+ = Done {linter :: Linter, status :: Status}
| Warn Text
- | NoOp FilePath
+ | NoOp Namespace.Ext
deriving (Show)
-run :: Mode -> [FilePath] -> IO [Result]
-run mode paths = do
- cwd <- Directory.getCurrentDirectory
- root <- Environment.getEnv "BIZ_ROOT"
- concat </ traverse (runOne mode root cwd) paths
+run :: Mode -> Map Namespace.Ext [Namespace] -> IO [Result]
+run mode nsmap = nsmap |> Map.assocs |> traverse (runOne mode) /> concat
-runOne :: Mode -> FilePath -> FilePath -> FilePath -> IO [Result]
-runOne mode root cwd path_ = results +> traverse_ printResult >> results
+runOne :: Mode -> (Ext, [Namespace]) -> IO [Result]
+runOne mode (ext, ns's) = results +> traverse_ printResult >> results
where
results =
- sequence <| case Namespace.fromPath root (cwd </> path_) of
- Nothing -> [pure <. Warn <| "could not get namespace for " <> Text.pack path_]
- Just (Namespace _ Hs) ->
- [ lint mode ormolu path_,
- lint mode hlint path_
+ sequence <| case ext of
+ Namespace.Hs ->
+ [ lint mode ormolu ns's,
+ lint mode hlint ns's
]
- Just (Namespace _ Py) ->
- [ lint mode black path_,
- lint mode ruff path_
+ Namespace.Py ->
+ [ lint mode black ns's,
+ lint mode ruff ns's
]
- Just (Namespace _ Sh) -> [lint mode shellcheck path_]
- Just (Namespace _ Nix) -> [lint mode deadnix path_]
- Just (Namespace _ Scm) -> [pure <| NoOp path_]
- Just (Namespace _ C) -> [lint mode indent path_]
- Just _ -> [pure <. Warn <| "no linter for " <> Text.pack path_]
-
-lint :: Mode -> Linter -> FilePath -> IO Result
-lint mode linter@Linter {..} path_ =
+ Namespace.Sh -> [lint mode shellcheck ns's]
+ Namespace.Nix -> [lint mode deadnix ns's]
+ Namespace.C -> [lint mode indent ns's]
+ _ -> [pure <. Warn <| "no linter for " <> show ext]
+
+lint :: Mode -> Linter -> [Namespace] -> IO Result
+lint mode linter@Linter {..} ns's =
Process.readProcessWithExitCode (Text.unpack exe) args "" /> \case
(Exit.ExitSuccess, _, _) ->
- Ok path_ linter Good
+ Done linter Good
(Exit.ExitFailure _, msg, _) ->
- Ok path_ linter <| Bad msg
+ Done linter <| Bad msg
where
args = case (mode, fixArgs) of
- (Fix, Just args_) -> map Text.unpack args_ ++ [path_]
- (Fix, Nothing) -> [path_]
- (Check, _) -> map Text.unpack checkArgs ++ [path_]
+ (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
--
cgit v1.2.3