{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
module Test.All(test) where
import Control.Exception
import System.Console.CmdArgs
import Control.Monad
import Control.Monad.IO.Class
import Data.Char
import Data.List
import System.Directory
import System.FilePath
import Data.Functor
import Prelude
import Config.Type
import Config.Read
import CmdLine
import HSE.All
import Hint.All
import Test.Util
import Test.InputOutput
import Test.Annotations
import Test.Translate
import System.IO.Extra
test :: Cmd -> ([String] -> IO ()) -> FilePath -> [FilePath] -> IO Int
test :: Cmd -> ([String] -> IO ()) -> String -> [String] -> IO Int
test CmdTest{..} main :: [String] -> IO ()
main dataDir :: String
dataDir files :: [String]
files = do
(failures :: Int
failures, ideas :: [Idea]
ideas) <- Handle -> BufferMode -> IO (Int, [Idea]) -> IO (Int, [Idea])
forall a. Handle -> BufferMode -> IO a -> IO a
withBuffering Handle
stdout BufferMode
NoBuffering (IO (Int, [Idea]) -> IO (Int, [Idea]))
-> IO (Int, [Idea]) -> IO (Int, [Idea])
forall a b. (a -> b) -> a -> b
$ Test [Idea] -> IO (Int, [Idea])
forall a. Test a -> IO (Int, a)
withTests (Test [Idea] -> IO (Int, [Idea]))
-> Test [Idea] -> IO (Int, [Idea])
forall a b. (a -> b) -> a -> b
$ do
Bool
hasSrc <- IO Bool -> Test Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Test Bool) -> IO Bool -> Test Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist "hlint.cabal"
Bool
useSrc <- Bool -> Test Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Test Bool) -> Bool -> Test Bool
forall a b. (a -> b) -> a -> b
$ Bool
hasSrc Bool -> Bool -> Bool
&& [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
files
[String]
testFiles <- if [String]
files [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
/= [] then [String] -> Test [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
files else do
[String]
xs <- IO [String] -> Test [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> Test [String]) -> IO [String] -> Test [String]
forall a b. (a -> b) -> a -> b
$ String -> IO [String]
getDirectoryContents String
dataDir
[String] -> Test [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
dataDir String -> String -> String
</> String
x | String
x <- [String]
xs, String -> String
takeExtension String
x String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [".hs",".yml",".yaml"]
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ "HLint_" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String -> String
takeBaseName String
x]
[(String, [Setting])]
testFiles <- IO [(String, [Setting])] -> Test [(String, [Setting])]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(String, [Setting])] -> Test [(String, [Setting])])
-> IO [(String, [Setting])] -> Test [(String, [Setting])]
forall a b. (a -> b) -> a -> b
$ [String]
-> (String -> IO (String, [Setting])) -> IO [(String, [Setting])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
testFiles ((String -> IO (String, [Setting])) -> IO [(String, [Setting])])
-> (String -> IO (String, [Setting])) -> IO [(String, [Setting])]
forall a b. (a -> b) -> a -> b
$ \file :: String
file -> do
[Setting]
hints <- [(String, Maybe String)] -> IO [Setting]
readFilesConfig [(String
file, Maybe String
forall a. Maybe a
Nothing)]
(String, [Setting]) -> IO (String, [Setting])
forall (m :: * -> *) a. Monad m => a -> m a
return (String
file, [Setting]
hints [Setting] -> [Setting] -> [Setting]
forall a. [a] -> [a] -> [a]
++ (if String -> String
takeBaseName String
file String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= "Test" then [] else ((String, Hint) -> Setting) -> [(String, Hint)] -> [Setting]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Setting
Builtin (String -> Setting)
-> ((String, Hint) -> String) -> (String, Hint) -> Setting
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Hint) -> String
forall a b. (a, b) -> a
fst) [(String, Hint)]
builtinHints))
let wrap :: String -> m a -> m ()
wrap msg :: String
msg act :: m a
act = do IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr (String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ " "); m a
act; IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn ""
IO () -> Test ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Test ()) -> IO () -> Test ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn "Testing"
IO () -> Test ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Test ()) -> IO () -> Test ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
checkCommentedYaml (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
dataDir String -> String -> String
</> "default.yaml"
Bool -> Test () -> Test ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
useSrc (Test () -> Test ()) -> Test () -> Test ()
forall a b. (a -> b) -> a -> b
$ String -> Test () -> Test ()
forall (m :: * -> *) a. MonadIO m => String -> m a -> m ()
wrap "Source annotations" (Test () -> Test ()) -> Test () -> Test ()
forall a b. (a -> b) -> a -> b
$ do
[Setting]
config <- IO [Setting] -> Test [Setting]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Setting] -> Test [Setting]) -> IO [Setting] -> Test [Setting]
forall a b. (a -> b) -> a -> b
$ [(String, Maybe String)] -> IO [Setting]
readFilesConfig [(".hlint.yaml",Maybe String
forall a. Maybe a
Nothing)]
[(String, Hint)] -> ((String, Hint) -> Test ()) -> Test ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, Hint)]
builtinHints (((String, Hint) -> Test ()) -> Test ())
-> ((String, Hint) -> Test ()) -> Test ()
forall a b. (a -> b) -> a -> b
$ \(name :: String
name,_) -> do
Test ()
progress
[Setting] -> String -> Test ()
testAnnotations (String -> Setting
Builtin String
name Setting -> [Setting] -> [Setting]
forall a. a -> [a] -> [a]
: if String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "Restrict" then [Setting]
config else []) (String -> Test ()) -> String -> Test ()
forall a b. (a -> b) -> a -> b
$ "src/Hint" String -> String -> String
</> String
name String -> String -> String
<.> "hs"
Bool -> Test () -> Test ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
useSrc (Test () -> Test ()) -> Test () -> Test ()
forall a b. (a -> b) -> a -> b
$ String -> Test () -> Test ()
forall (m :: * -> *) a. MonadIO m => String -> m a -> m ()
wrap "Input/outputs" (Test () -> Test ()) -> Test () -> Test ()
forall a b. (a -> b) -> a -> b
$ ([String] -> IO ()) -> Test ()
testInputOutput [String] -> IO ()
main
String -> Test () -> Test ()
forall (m :: * -> *) a. MonadIO m => String -> m a -> m ()
wrap "Hint names" (Test () -> Test ()) -> Test () -> Test ()
forall a b. (a -> b) -> a -> b
$ ((String, [Setting]) -> Test ())
-> [(String, [Setting])] -> Test ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\x :: (String, [Setting])
x -> do Test ()
progress; [Setting] -> Test ()
testNames ([Setting] -> Test ()) -> [Setting] -> Test ()
forall a b. (a -> b) -> a -> b
$ (String, [Setting]) -> [Setting]
forall a b. (a, b) -> b
snd (String, [Setting])
x) [(String, [Setting])]
testFiles
String -> Test () -> Test ()
forall (m :: * -> *) a. MonadIO m => String -> m a -> m ()
wrap "Hint annotations" (Test () -> Test ()) -> Test () -> Test ()
forall a b. (a -> b) -> a -> b
$ [(String, [Setting])]
-> ((String, [Setting]) -> Test ()) -> Test ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, [Setting])]
testFiles (((String, [Setting]) -> Test ()) -> Test ())
-> ((String, [Setting]) -> Test ()) -> Test ()
forall a b. (a -> b) -> a -> b
$ \(file :: String
file,h :: [Setting]
h) -> do Test ()
progress; [Setting] -> String -> Test ()
testAnnotations [Setting]
h String
file
let hs :: [[Setting]]
hs = [[Setting]
h | (file :: String
file, h :: [Setting]
h) <- [(String, [Setting])]
testFiles, String -> String
takeFileName String
file String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= "Test.hs"]
Bool -> Test () -> Test ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
cmdTypeCheck (Test () -> Test ()) -> Test () -> Test ()
forall a b. (a -> b) -> a -> b
$ String -> Test () -> Test ()
forall (m :: * -> *) a. MonadIO m => String -> m a -> m ()
wrap "Hint typechecking" (Test () -> Test ()) -> Test () -> Test ()
forall a b. (a -> b) -> a -> b
$
Test ()
progress Test () -> Test () -> Test ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> String -> [[Setting]] -> Test ()
testTypeCheck String
cmdDataDir String
cmdTempDir [[Setting]]
hs
Bool -> Test () -> Test ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
cmdQuickCheck (Test () -> Test ()) -> Test () -> Test ()
forall a b. (a -> b) -> a -> b
$ String -> Test () -> Test ()
forall (m :: * -> *) a. MonadIO m => String -> m a -> m ()
wrap "Hint QuickChecking" (Test () -> Test ()) -> Test () -> Test ()
forall a b. (a -> b) -> a -> b
$
Test ()
progress Test () -> Test () -> Test ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> String -> [[Setting]] -> Test ()
testQuickCheck String
cmdDataDir String
cmdTempDir [[Setting]]
hs
Bool -> Test () -> Test ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
files Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
hasSrc) (Test () -> Test ()) -> Test () -> Test ()
forall a b. (a -> b) -> a -> b
$ IO () -> Test ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Test ()) -> IO () -> Test ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn "Warning, couldn't find source code, so non-hint tests skipped"
Test [Idea]
getIdeas
IO () -> IO ()
whenLoud (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Idea -> IO ()) -> [Idea] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Idea -> IO ()
forall a. Show a => a -> IO ()
print [Idea]
ideas
Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
failures
testNames :: [Setting] -> Test ()
testNames :: [Setting] -> Test ()
testNames hints :: [Setting]
hints = [Test ()] -> Test ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
[ [String] -> Test ()
failed ["No name for the hint " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Exp SrcSpanInfo -> String
forall a. Pretty a => a -> String
prettyPrint Exp SrcSpanInfo
hintRuleLHS String -> String -> String
forall a. [a] -> [a] -> [a]
++ " ==> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Exp SrcSpanInfo -> String
forall a. Pretty a => a -> String
prettyPrint Exp SrcSpanInfo
hintRuleRHS]
| SettingMatchExp x :: HintRule
x@HintRule{..} <- [Setting]
hints, String
hintRuleName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
defaultHintName]
checkCommentedYaml :: FilePath -> IO ()
file :: String
file = do
[String]
src <- String -> [String]
lines (String -> [String]) -> IO String -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile' String
file
let src2 :: [String]
src2 = [String
x | String
x <- [String]
src, Just x :: String
x <- [String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix "# " String
x], Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\x :: Char
x -> Char -> Bool
isAlpha Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '$') (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
take 1 String
x]
[Setting]
e <- [(String, Maybe String)] -> IO [Setting]
readFilesConfig [(String
file, String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
src2)]
IO Int -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int -> IO ()) -> IO Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO Int
forall a. a -> IO a
evaluate (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ [Setting] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Setting]
e