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
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
-- : out lint
-- : dep async
-- : dep regex-applicative
module Biz.Lint (main) where
import Alpha
import qualified Biz.Cli as Cli
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 =
(return <| Cli.getAllArgs args (Cli.argument "file"))
>>= \case
[] -> changedFiles >>= run >>= mapM printResult >>= exit
files -> run (filter notcab files) >>= mapM printResult >>= exit
test :: Test.Tree
test = Test.group "Biz.Bild" [Test.unit "id" <| 1 @=? 1]
notcab :: FilePath -> Bool
notcab ('_' : _) = False
notcab _ = True
help :: Cli.Docopt
help =
[Cli.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 _) = 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
|
