Lint.hs 7.15 KB
Newer Older
uxrog's avatar
uxrog committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
-- 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
16
import System.FilePath.Posix
uxrog's avatar
uxrog committed
17
18
19
20
21
22
23
24
25
26
27
28
29
30
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

31
32
33
34
35
36
37
38
39
40
allChecks :: [(String, LintCheck)]
allChecks =
    [ ("no other files are present" , noOtherFiles)
    , ("filenames are CamelCase", camelCaseFileNames)
    , ("valid input files are ASCII", validsAreAscii)
    , ("nonempty files have a trailing newline", haveTrailingNewline)
    , ("a valid test file exists for every .out file", outsHaveValids)
    , (".out files have no trailing whitespace at the end of each line", haveTrailingWhitespace)
    ]

uxrog's avatar
uxrog committed
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
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)"
uxrog's avatar
uxrog committed
68
            mapM_ putStrLn $ Set.toList otherPaths
uxrog's avatar
uxrog committed
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91

            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]

data Problem
    = ShouldNotExist FilePath
    | NotAnAsciiFile FilePath
    | MissingTrailingNewLine FilePath
    | MissingInFile FilePath
    | TrailingWhitespace FilePath Int
92
    | FilenameNotCamelCase FilePath
uxrog's avatar
uxrog committed
93
94
95
96
97
98
99

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 (MissingInFile path) = path ++ " does not have an input file"
    show (TrailingWhitespace path line) = path ++ " has trailing whitespace at the end of line " ++ show line
100
    show (FilenameNotCamelCase path) = path ++ " is not CamelCase"
uxrog's avatar
uxrog committed
101
102
103
104
105
106
107
108
109
110

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)
uxrog's avatar
uxrog committed
111
112
    | Set.null otherFiles = pure []
    | otherwise           = pure $ map ShouldNotExist $ Set.toList otherFiles
uxrog's avatar
uxrog committed
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136

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]

uxrog's avatar
uxrog committed
137
138
139
-- Checks whether each .out file has a valid file
outsHaveValids (validPaths, _, outPaths, _) =
    pure $ catMaybes $ map go $ Set.toList outPaths
uxrog's avatar
uxrog committed
140
    where
uxrog's avatar
uxrog committed
141
142
143
144
145
146
        go outPath
            | expectedInFile `Set.member` validPaths = Nothing
            | otherwise                              = Just $ MissingInFile outPath
            where expectedInFile = dropEnd 4 outPath -- Hacky oof

        dropEnd n xs = take (length xs - n) xs
uxrog's avatar
uxrog committed
147
148
149
150
151
152
153
154
155
156
157
158

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                                            = []

159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
camelCaseFileNames (validPaths, invalidPaths, outPaths, _) =
    pure $ concat $ map (catMaybes . map checkCamelCase . Set.toList)
        [validPaths, invalidPaths, outPaths]
    where
        checkCamelCase path = toMaybe
            (not $ isUpper (head str) && all isCamelCaseChar str)
            (FilenameNotCamelCase path)
            where str = dropExtensions $ takeBaseName path

        toMaybe True  x = Just x
        toMaybe False x = Nothing

        isUpper         c = c `elem` ['A'..'Z']
        isLower         c = c `elem` ['a'..'z']
        isDigit         c = c `elem` ['0'..'9']
        isCamelCaseChar c = isUpper c || isLower c || isDigit c

uxrog's avatar
uxrog committed
176
177
178
179
180
181
182
183
184
185
186
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