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
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
-- : out lint
--
-- these are actually runtime deps, but bild doesn't (yet) distinguish between
-- rundeps and sysdeps:
--
-- : sys ormolu
-- : sys hlint
-- : sys black
-- : sys ruff
-- : sys deadnix
-- : sys shellcheck
-- : sys indent
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.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 "BIZ_ROOT" +> \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 [--fix] [<file>...]
lint -h, --help
|]
exit :: [Result] -> IO ()
exit results = Exit.exitWith <| if n > 0 then Exit.ExitFailure n else Exit.ExitSuccess
where
n = length <| filter bad results
bad = \case
(Warn _) -> False
Done {status = Bad _} -> True
_ -> False
printResult :: Result -> IO Result
printResult r@(Warn err) = Log.warn ["lint", err] >> Log.br >> pure r
printResult r@(Done Linter {..} (Bad err)) =
Log.fail ["lint", exe]
>> Log.br
>> if err == "" then pure r else putText (Text.pack err) >> pure r
printResult r@(Done Linter {..} Good) =
Log.good ["lint", exe]
>> Log.br
>> pure r
printResult r@(NoOp ext) =
Log.info ["lint", "noop", show ext]
>> pure r
changedFiles :: IO [FilePath]
changedFiles =
git ["merge-base", "HEAD", "origin/master"]
/> 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]
}
deriving (Show)
ormolu :: Linter
ormolu =
Linter
{ exe = "ormolu",
checkArgs = ["--mode", "check", "--no-cabal"],
fixArgs = Just ["--mode", "inplace", "--no-cabal"]
}
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
}
black :: Linter
black =
Linter
{ exe = "black",
checkArgs = ["--check"],
fixArgs = Just []
}
ruff :: Linter
ruff =
Linter
{ exe = "ruff",
checkArgs = ["check"],
fixArgs = Just ["check", "--fix"]
}
deadnix :: Linter
deadnix =
Linter
{ exe = "deadnix",
checkArgs = "--fail" : commonArgs,
fixArgs = Just <| "--edit" : commonArgs
}
where
commonArgs = ["--no-underscore", "--no-lambda-pattern-names"]
shellcheck :: Linter
shellcheck = Linter {exe = "shellcheck", checkArgs = [], fixArgs = Nothing}
indent :: Linter
indent = Linter {exe = "indent", checkArgs = [], fixArgs = Nothing}
data Status = Good | Bad String
deriving (Show)
data Result
= Done {linter :: Linter, status :: Status}
| Warn Text
| NoOp Namespace.Ext
deriving (Show)
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 >> results
where
results =
sequence <| case ext of
Namespace.Hs ->
[ lint mode ormolu ns's,
lint mode hlint ns's
]
Namespace.Py ->
[ lint mode black ns's,
lint mode ruff ns's
]
Namespace.Sh -> [lint mode shellcheck ns's]
Namespace.Nix -> [lint mode deadnix ns's]
Namespace.C -> [lint mode indent ns's]
_ -> [pure <. Warn <| "no linter for " <> show ext]
lint :: Mode -> Linter -> [Namespace] -> IO Result
lint mode linter@Linter {..} ns's =
Process.readProcessWithExitCode (Text.unpack exe) args "" /> \case
(Exit.ExitSuccess, _, _) ->
Done linter Good
(Exit.ExitFailure _, msg, _) ->
Done linter <| Bad msg
where
args = case (mode, fixArgs) of
(Fix, Just args_) -> map Text.unpack args_ ++ map Namespace.toPath ns's
(Fix, Nothing) -> map Namespace.toPath ns's
(Check, _) -> map Text.unpack checkArgs ++ map Namespace.toPath ns's
|
