{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-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.Either.Extra
import Data.Foldable
import Data.List
import Data.Maybe
import System.Directory
import System.FilePath
import Data.Functor
import Prelude
import Config.Type
import Config.Read
import CmdLine
import Refact
import Hint.All
import Test.Annotations
import Test.InputOutput
import Test.Summary
import Test.Translate
import Test.Util
import System.IO.Extra
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
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
Either String String
rpath <- Maybe String -> IO (Either String String)
refactorPath (if String
cmdWithRefactor String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "" then Maybe String
forall a. Maybe a
Nothing else String -> Maybe String
forall a. a -> Maybe a
Just String
cmdWithRefactor)
(failures :: Int
failures, (ideas :: [Idea]
ideas, builtins :: BuiltinSummary
builtins)) <- Handle
-> BufferMode
-> IO (Int, ([Idea], BuiltinSummary))
-> IO (Int, ([Idea], BuiltinSummary))
forall a. Handle -> BufferMode -> IO a -> IO a
withBuffering Handle
stdout BufferMode
NoBuffering (IO (Int, ([Idea], BuiltinSummary))
-> IO (Int, ([Idea], BuiltinSummary)))
-> IO (Int, ([Idea], BuiltinSummary))
-> IO (Int, ([Idea], BuiltinSummary))
forall a b. (a -> b) -> a -> b
$ Test ([Idea], BuiltinSummary) -> IO (Int, ([Idea], BuiltinSummary))
forall a. Test a -> IO (Int, a)
withTests (Test ([Idea], BuiltinSummary)
-> IO (Int, ([Idea], BuiltinSummary)))
-> Test ([Idea], BuiltinSummary)
-> IO (Int, ([Idea], BuiltinSummary))
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"
let useSrc :: Bool
useSrc = 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 (f :: * -> *) a. Applicative f => a -> f a
pure [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 (f :: * -> *) a. Applicative f => a -> f a
pure [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` [".yml",".yaml"]]
[(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),("CommandLine.yaml", String -> Maybe String
forall a. a -> Maybe a
Just "- group: {name: testing, enabled: true}")]
(String, [Setting]) -> IO (String, [Setting])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 -> Maybe 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 [])
("src/Hint" String -> String -> String
</> String
name String -> String -> String
<.> "hs")
(Either String String -> Maybe String
forall a b. Either a b -> Maybe b
eitherToMaybe Either String String
rpath)
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 -> Maybe String -> Test ()
testAnnotations [Setting]
h String
file (Either String String -> Maybe String
forall a b. Either a b -> Maybe b
eitherToMaybe Either String String
rpath)
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"
(,) ([Idea] -> BuiltinSummary -> ([Idea], BuiltinSummary))
-> Test [Idea] -> Test (BuiltinSummary -> ([Idea], BuiltinSummary))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Test [Idea]
getIdeas Test (BuiltinSummary -> ([Idea], BuiltinSummary))
-> Test BuiltinSummary -> Test ([Idea], BuiltinSummary)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Test BuiltinSummary
getBuiltins
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
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
cmdGenerateSummary (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
writeFile "builtin.md" (BuiltinSummary -> String
genBuiltinSummaryMd BuiltinSummary
builtins)
case Either String String
rpath of
Left refactorNotFound :: String
refactorNotFound -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
refactorNotFound, "Refactoring tests skipped"]
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Int -> IO Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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]
++ HsExtendInstances (LHsExpr GhcPs) -> String
forall a. Outputable a => a -> String
unsafePrettyPrint HsExtendInstances (LHsExpr GhcPs)
hintRuleLHS String -> String -> String
forall a. [a] -> [a] -> [a]
++ " ==> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ HsExtendInstances (LHsExpr GhcPs) -> String
forall a. Outputable a => a -> String
unsafePrettyPrint HsExtendInstances (LHsExpr GhcPs)
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