1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
-- : out lint
-- : dep async
-- : dep rainbow
-- : dep regex-applicative
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 Control.Concurrent.Async as Async
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
move :: Cli.Arguments -> IO ()
move args = case Cli.getAllArgs args (Cli.argument "file") of
[] -> changedFiles >>= run >>= mapM printResult >>= exit
files -> run (filter notcab files) >>= mapM printResult >>= exit
test :: Test.Tree
test =
Test.group
"Biz.Lint"
[ Test.unit "haskell files return two Results" <| do
results <- run ["Biz/Lint.hs"]
length results @=? 2
]
notcab :: FilePath -> Bool
notcab ('_' : _) = False
notcab _ = True
help :: Cli.Docopt
help =
[Cli.docopt|
lint
Usage:
lint test
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
-- we print errors in red, but don't count them as "bad"
bad (Warn _) = False
bad Ok {status = Bad _} = True
bad _ = 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", linter_, Text.pack path_]
>> Log.br
>> if err == "" then pure r else putText (Text.pack err) >> pure r
printResult r@(Ok path_ linter_ Good) =
Log.good ["lint", linter_, Text.pack path_]
>> Log.br
>> pure r
printResult r@(NoOp path_) =
Log.info ["lint", "noop", Text.pack path_]
>> Log.br
>> 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 = Text
data Status = Good | Bad String
deriving (Show)
data Result
= Ok {path :: FilePath, linter :: Linter, status :: Status}
| Warn 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 <. Warn <| "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 <. Warn <| "no linter for " <> Text.pack path_]
lint :: Linter -> [String] -> FilePath -> IO Result
lint bin args path_ =
Process.readProcessWithExitCode (Text.unpack bin) (args ++ [path_]) "" >>= \case
(Exit.ExitSuccess, _, _) -> pure <| Ok path_ bin Good
(Exit.ExitFailure _, msg, _) ->
pure <| Ok path_ bin <| Bad msg
|
