Lint.hs 6.31 KB
Newer Older
uxrog's avatar
uxrog committed
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
-- stack script --install-ghc --resolver lts-18.14

module Lint where

import Control.Monad
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import Data.List
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as Set
import Options.Applicative
import System.Directory
import System.Environment
import System.Exit
import System.Process

data LintOptions = LintOptions
    { shouldFix   :: Bool
    , directories :: [FilePath]
    } deriving (Show)

lintOptions = LintOptions
    <$> switch (long "fix" <> short 'f' <> help "Fix problems if possible")
    <*> many (argument str (metavar "FILES..."))

main = lint =<< readArguments
    where readArguments = execParser $ info (lintOptions <**> helper) $ fullDesc

lint options = do
    putStrLn "# Starting linting process"
    allProblems <- concat <$> mapM lintDirectory (directories options)
    putStrLn "# Linting is done"
    when (not $ null allProblems) $ do
        putStrLn $ "[!] " ++ show (length allProblems) ++ " problems found! Reporting them using exit code."
        when (shouldFix options) $ do
            putStrLn "# Fixing found problems"
            mapM_ fix allProblems
        exitFailure

lintDirectory directory = do
    putStrLn $ "## Linting directory " ++ directory
    paths <- Set.fromList <$> listDirectory directory
    lintPathSet paths
    where
        lintPathSet :: Set FilePath -> IO [Problem]
        lintPathSet paths = do
            let validPaths   = Set.filter isValidPath paths
            let invalidPaths = Set.filter isInvalidPath paths
            let outPaths     = Set.filter isOutPath paths
            let otherPaths   = Set.filter (not . isHiddenPath) $ Set.difference paths $ foldl1 Set.union [validPaths, invalidPaths, outPaths]

            putStrLn $ "Found " ++ show (length validPaths) ++ " .mj/.valid.mj file(s)"
            putStrLn $ "Found " ++ show (length invalidPaths) ++ " .invalid.mj file(s)"
            putStrLn $ "Found " ++ show (length outPaths) ++ " .mj.out file(s)"
            putStrLn $ "Found " ++ show (length otherPaths) ++ " other file(s)"

            runChecks (Set.map prefixDir validPaths, Set.map prefixDir invalidPaths, Set.map prefixDir outPaths, Set.map prefixDir otherPaths) allChecks
        
        prefixDir = ((directory ++ "/") ++)

        runChecks :: (Set FilePath, Set FilePath, Set FilePath, Set FilePath) -> [(String, LintCheck)] -> IO [Problem]
        runChecks pathsets checks = concat <$> mapM (flip runCheck pathsets) checks

        isValidPath   path = ".mj" `isSuffixOf` path && not (".invalid.mj" `isSuffixOf` path)
        isInvalidPath path = ".invalid.mj" `isSuffixOf` path
        isOutPath     path = ".mj.out" `isSuffixOf` path
        isHiddenPath  path = head path == '.'

type Pathsets = (Set FilePath, Set FilePath, Set FilePath, Set FilePath)

type LintCheck = Pathsets -> IO [Problem]

allChecks :: [(String, LintCheck)]
allChecks =
    [ ("no other files are present" , noOtherFiles)
    , ("valid input files are ASCII", validsAreAscii)
    , ("nonempty files have a trailing newline", haveTrailingNewline)
    , ("valid input files have an .out file (and vice versa)", validsHaveOut)
    , (".out files have no trailing whitespace at the end of each line", haveTrailingWhitespace)
    ]

data Problem
    = ShouldNotExist FilePath
    | NotAnAsciiFile FilePath
    | MissingTrailingNewLine FilePath
    | MissingOutFile FilePath
    | MissingInFile FilePath
    | TrailingWhitespace FilePath Int

instance Show Problem where
    show (ShouldNotExist path) = path ++ " should not exist"
    show (NotAnAsciiFile path) = path ++ " is not ASCII"
    show (MissingTrailingNewLine path) = path ++ " does not have a trailing newline"
    show (MissingOutFile path) = path ++ " should exist because there is an input for it"
    show (MissingInFile path) = path ++ " does not have an input file"
    show (TrailingWhitespace path line) = path ++ " has trailing whitespace at the end of line " ++ show line

newline = 10

fix p@(MissingTrailingNewLine path) = do
    contents <- BS.readFile path
    BS.writeFile path $ BS.snoc contents newline
    putStrLn $ "Fixed " ++ show p
fix _ = pure ()

noOtherFiles (_, _, _, otherFiles)
    | Set.null otherFiles = pure $ map ShouldNotExist $ Set.toList otherFiles
    | otherwise           = pure []

validsAreAscii (validPaths, _, _, _) =
    concat <$> mapM checkAscii (Set.toList validPaths)
    where
        checkAscii path = do
            contents <- BS.readFile path
            if BS.all (<= 127) contents then
                pure []
            else
                pure [NotAnAsciiFile path]

haveTrailingNewline (validPaths, invalidPaths, outPaths, _) =
    concat <$> mapM go [validPaths, invalidPaths, outPaths]
    where
        go :: Set FilePath -> IO [Problem]
        go paths = concat <$> (mapM checkNewline $ Set.toList paths)

        checkNewline path = do
            contents <- BS.readFile path
            if BS.null contents || BS.last contents == newline then
                pure []
            else
                pure [MissingTrailingNewLine path]

validsHaveOut (validPaths, _, outPaths, _)
    | expectedOutPaths == outPaths = pure []
    | otherwise = pure $
           map MissingOutFile (Set.toList $ Set.difference expectedOutPaths outPaths)
        ++ map MissingInFile  (Set.toList $ Set.difference outPaths expectedOutPaths)
    where
        expectedOutPaths = Set.map (++ ".out") validPaths

haveTrailingWhitespace (_, _, outPaths, _) = concat <$> mapM go (Set.toList outPaths)
    where
        go path = do
            lines <- BS8.lines <$> BS.readFile path
            pure $ concat $ zipWith checkTrailingWhitespace [1..] lines
            where
                checkTrailingWhitespace :: Int -> BS8.ByteString -> [Problem]
                checkTrailingWhitespace i line
                    | not $ BS.null $ BS8.takeWhileEnd (`elem` " \t") line = [TrailingWhitespace path i]
                    | otherwise                                            = []

runCheck :: (String, LintCheck) -> Pathsets -> IO [Problem]
runCheck (label, check) pathsets = do
    putStr $ "### Checking whether " ++ label ++ "..."
    problems <- check pathsets
    if null problems then do
        putStrLn " passed"
    else do
        putStrLn ""
        putStrLn "[!] Problems found:"
        mapM_ (\p -> putStrLn $ "[*] " ++ show p) problems
    pure problems