Commit 295e2eec authored by uxrog's avatar uxrog
Browse files

Integrate linter into CI

Also change line endings from CRLF to LF
parent 21bbcd11
Pipeline #173938 failed with stage
in 7 minutes and 34 seconds
......@@ -8,6 +8,25 @@ variables:
GRADLE_USER_HOME: "gradle-cache"
FLAMMENWEHRFER_AUTH: "$FLAMMENWEHRFER_AUTH"
linter:
stage: run
only:
- merge_requests
- master
# Cache stack
cache:
key: "stack_cache"
paths:
- stack-cache
script:
- stack --stack-root "$PWD/stack-cache" ./Lint.hs lexer
tags:
- alive
gruppen:
stage: run
only:
......
#!/usr/bin/env stack
-- stack --resolver lts-18.14 script
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
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
\ No newline at end of file
-- 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
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment