summaryrefslogtreecommitdiff
path: root/Omni/Lint.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Omni/Lint.hs')
-rw-r--r--Omni/Lint.hs310
1 files changed, 310 insertions, 0 deletions
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] [<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
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-25 18:06:22 +0000