diff options
Diffstat (limited to 'Biz/Lint.hs')
| -rw-r--r-- | Biz/Lint.hs | 310 |
1 files changed, 0 insertions, 310 deletions
diff --git a/Biz/Lint.hs b/Biz/Lint.hs deleted file mode 100644 index c971c04..0000000 --- a/Biz/Lint.hs +++ /dev/null @@ -1,310 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Global linter. --- --- : out lint --- : run ormolu --- : run hlint --- : run ruff --- : run deadnix --- : run shellcheck --- : run indent --- : run nixfmt -module Biz.Lint (main) where - -import Alpha -import qualified Biz.Cli as Cli -import qualified Biz.Log as Log -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 -import qualified System.Directory as Directory -import qualified System.Environment as Environment -import qualified System.Exit as Exit -import qualified System.Process as Process - -main :: IO () -main = Cli.main <| Cli.Plan help move test pure - -move :: Cli.Arguments -> IO () -move args = - Environment.getEnv "CODEROOT" +> \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 = - 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 <| Map.singleton Hs <| [Namespace ["Biz", "Lint"] Hs] - length results @=? 2 - ] - -help :: Cli.Docopt -help = - [Cli.docopt| -all your lint are belong to us - -Usage: - lint test - lint [options] [<file>...] - -Options: - -f, --fix Apply fixes automatically - -h, --help Print this info -|] - -exit :: [Result] -> IO () -exit results = Exit.exitWith <| (n > 0) ?: (Exit.ExitFailure n, Exit.ExitSuccess) - where - n = length <| filter bad results - bad = \case - (Warn _) -> False - Done _ (Bad _) -> True - _ -> False - -printResult :: Result -> IO Result -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 = - git ["merge-base", "HEAD", "origin/live"] - /> filter (/= '\n') - +> (\mb -> git ["diff", "--name-only", "--diff-filter=d", mb]) - /> String.lines - where - git args = Process.readProcess "git" args "" - -data Mode - = -- | Just check the files and return an exit code. - Check - | -- | Fix the files in place, return 0 if successful, otherwise return 1. - Fix - -data Linter = Linter - { exe :: Text, - -- | Arguments added when in the "check" mode - checkArgs :: [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 - decoder :: Maybe (String -> String) - } - -ormolu :: Linter -ormolu = - Linter - { exe = "ormolu", - checkArgs = ["--mode", "check", "--no-cabal"], - fixArgs = Just ["--mode", "inplace", "--no-cabal"], - decoder = Nothing - } - -hlint :: Linter -hlint = - Linter - { exe = "hlint", - checkArgs = [], - -- needs apply-refact >0.9.1.0, which needs ghc >9 - -- fixArgs = Just ["--refactor", "--refactor-options=-i"] - fixArgs = Nothing, - decoder = Nothing - } - -ruffFormat :: Linter -ruffFormat = - Linter - { exe = "ruff", - checkArgs = ["format", "--check", "--silent"], - fixArgs = Just ["format", "--silent"], - decoder = Nothing - } - -ruff :: Linter -ruff = - Linter - { exe = "ruff", - checkArgs = ["check"], - fixArgs = Just ["check", "--fix"], - decoder = 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, - decoder = Just decodeDeadnixOutput - } - where - 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 - -nixfmt :: Linter -nixfmt = - Linter - { exe = "nixfmt", - checkArgs = ["--check"], - fixArgs = Nothing, - decoder = Nothing - } - -shellcheck :: Linter -shellcheck = - Linter - { exe = "shellcheck", - checkArgs = [], - fixArgs = Nothing, - decoder = Nothing - } - -indent :: Linter -indent = - Linter - { exe = "indent", - checkArgs = [], - fixArgs = Nothing, - decoder = Nothing - } - -data Status = Good | Bad String - deriving (Show) - -data Result - = Done Linter Status - | Warn Text - | NoOp Namespace.Ext - -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 - where - results :: IO [Result] - 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, - lint mode hlint ns's - ] - Namespace.Py -> - [ lint mode ruffFormat ns's, - lint mode ruff ns's - ] - Namespace.Sh -> [lint mode shellcheck ns's] - Namespace.Nix -> [lint mode deadnix ns's, lint mode nixfmt ns's] - Namespace.C -> [lint mode indent ns's] - _ -> - ns's - |> map Namespace.toPath - |> joinWith ", " - |> str - |> ("no linter for " <>) - |> Warn - |> (pure :: Result -> IO Result) - |> (pure :: IO Result -> [IO Result]) - -lint :: Mode -> Linter -> [Namespace] -> IO Result -lint mode linter@Linter {..} ns's = - Log.info ["lint", exe, (tshow <| length ns's) <> " files"] - >> Process.readProcessWithExitCode (str exe) args "" - /> \case - (Exit.ExitSuccess, _, _) -> - Done linter Good - (Exit.ExitFailure _, msg, _) -> case decoder of - Nothing -> Done linter <| Bad msg - Just fmt -> Done linter <| Bad <| fmt msg - where - args = case (mode, fixArgs) of - (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 |