From 6513755670892983db88a6633b8c1ea6019c03d1 Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Fri, 15 Nov 2024 14:55:37 -0500 Subject: Re-namespace some stuff to Omni I was getting confused about what is a product and what is internal infrastructure; I think it is good to keep those things separate. So I moved a bunch of stuff to an Omni namespace, actually most stuff went there. Only things that are explicitly external products are still in the Biz namespace. --- Omni/Lint.hs | 310 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 310 insertions(+) create mode 100644 Omni/Lint.hs (limited to 'Omni/Lint.hs') diff --git a/Omni/Lint.hs b/Omni/Lint.hs new file mode 100644 index 0000000..45d1523 --- /dev/null +++ b/Omni/Lint.hs @@ -0,0 +1,310 @@ +{-# 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 Omni.Lint (main) where + +import Alpha +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 Omni.Cli as Cli +import qualified Omni.Log as Log +import Omni.Namespace (Ext (..), Namespace (..)) +import qualified Omni.Namespace as Namespace +import Omni.Test ((@=?)) +import qualified Omni.Test as Test +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 + "Omni.Lint" + [ Test.unit "haskell files return two Results" <| do + results <- run Check <| Map.singleton Hs <| [Namespace ["Omni", "Lint"] Hs] + length results @=? 2 + ] + +help :: Cli.Docopt +help = + [Cli.docopt| +all your lint are belong to us + +Usage: + lint test + lint [options] [...] + +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 -- cgit v1.2.3