Port lint to Haskell

1 files changed, 112 insertions, 0 deletions

diff --git a/Biz/Lint.hs b/Biz/Lint.hs
new file mode 100644
index 0000000..acf59c8
--- /dev/null
+++ b/Biz/Lint.hs
@@ -0,0 +1,112 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- : out lint
+-- : dep async
+-- : dep regex-applicative
+module Biz.Lint (main) where
+
+import Alpha
+import Biz.Namespace (Ext (..), Namespace (..))
+import qualified Biz.Namespace as Namespace
+import qualified Control.Concurrent.Async as Async
+import qualified Data.String as String
+import qualified Data.Text as Text
+import qualified System.Console.Docopt as Docopt
+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 =
+  Environment.getArgs
+    >>= Docopt.parseArgsOrExit help
+    >>= (\args -> return <| Docopt.getAllArgs args (Docopt.argument "file"))
+    >>= \case
+      [] -> changedFiles >>= run >>= mapM printResult >>= exit
+      files -> run (filter notcab files) >>= mapM printResult >>= exit
+
+notcab :: FilePath -> Bool
+notcab ('_' : _) = False
+notcab _ = True
+
+help :: Docopt.Docopt
+help =
+  [Docopt.docopt|
+lint
+
+Usage:
+  lint [<file>...]
+|]
+
+exit :: [Result] -> IO ()
+exit results = Exit.exitWith <| if n > 0 then Exit.ExitFailure n else Exit.ExitSuccess
+  where
+    n = length <| filter bad results
+    bad (Error _) = False
+    bad Ok {status = Bad _} = True
+    bad _ = False
+
+printResult :: Result -> IO Result
+-- printResult r@(Error err) = (putText <| "lint: error: " <> err) >> pure r
+printResult r@(Error err) = pure r
+printResult r@(Ok path_ linter_ (Bad err)) =
+  (putText <| "lint: badd: " <> Text.pack linter_ <> ": " <> Text.pack path_)
+    >> if err == "" then pure r else putText (Text.pack err) >> pure r
+printResult r@(Ok _ _ Good) = pure r
+printResult r@(NoOp path_) =
+  (putText <| "lint: noop: " <> Text.pack path_)
+    >> pure r
+
+changedFiles :: IO [FilePath]
+changedFiles = mergeBase >>= changed
+  where
+    git args = Process.readProcess "git" args ""
+    mergeBase = git ["merge-base", "HEAD", "origin/master"] /> filter (/= '\n')
+    changed mb =
+      String.lines
+        </ git ["diff", "--name-only", "--diff-filter=d", mb]
+
+type Linter = String
+
+data Status = Good | Bad String
+  deriving (Show)
+
+data Result
+  = Ok {path :: FilePath, linter :: Linter, status :: Status}
+  | Error Text
+  | NoOp FilePath
+  deriving (Show)
+
+run :: [FilePath] -> IO [Result]
+run paths = do
+  cwd <- Directory.getCurrentDirectory
+  root <- Environment.getEnv "BIZ_ROOT"
+  concat </ Async.mapConcurrently (runOne root cwd) paths
+
+runOne :: FilePath -> FilePath -> FilePath -> IO [Result]
+runOne root cwd path_ =
+  sequence <| case Namespace.fromPath root (cwd </> path_) of
+    Nothing -> [pure <. Error <| "could not get namespace for " <> Text.pack path_]
+    Just (Namespace _ Hs) ->
+      [ lint "ormolu" ["--mode", "check"] path_,
+        lint "hlint" [] path_
+      ]
+    Just (Namespace _ Py) ->
+      [ lint "pylint" ["--disable=invalid-name"] path_
+      ]
+    Just (Namespace _ Sh) -> [pure <| NoOp path_] -- [lint "shellcheck" [] path_]
+    Just (Namespace _ Nix) -> [pure <| NoOp path_]
+    Just (Namespace _ Scm) -> [pure <| NoOp path_]
+    Just _ -> [pure <. Error <| "no linter for " <> Text.pack path_]
+
+lint :: Linter -> [String] -> FilePath -> IO Result
+lint bin args path_ =
+  Process.readProcessWithExitCode bin (args ++ [path_]) "" >>= \case
+    (Exit.ExitSuccess, _, _) -> pure <| Ok path_ bin Good
+    (Exit.ExitFailure _, msg, _) ->
+      pure <| Ok path_ bin <| Bad msg