{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}

module Test.All(test) where

import Control.Exception
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.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 CmdMain{Bool
Int
String
[String]
[Severity]
ColorMode
cmdFiles :: [String]
cmdReports :: [String]
cmdGivenHints :: [String]
cmdWithGroups :: [String]
cmdGit :: Bool
cmdColor :: ColorMode
cmdThreads :: Int
cmdIgnore :: [String]
cmdShowAll :: Bool
cmdIgnoreSuggestions :: Bool
cmdExtension :: [String]
cmdLanguage :: [String]
cmdCross :: Bool
cmdFindHints :: [String]
cmdDataDir :: String
cmdDefault :: Bool
cmdPath :: [String]
cmdCppDefine :: [String]
cmdCppInclude :: [String]
cmdCppFile :: [String]
cmdCppSimple :: Bool
cmdCppAnsi :: Bool
cmdJson :: Bool
cmdCC :: Bool
cmdSARIF :: Bool
cmdNoSummary :: Bool
cmdOnly :: [String]
cmdNoExitCode :: Bool
cmdTiming :: Bool
cmdSerialise :: Bool
cmdRefactor :: Bool
cmdRefactorOptions :: String
cmdWithRefactor :: String
cmdIgnoreGlob :: [String]
cmdGenerateMdSummary :: [String]
cmdGenerateJsonSummary :: [String]
cmdGenerateExhaustiveConf :: [Severity]
cmdTest :: Bool
cmdFiles :: Cmd -> [String]
cmdReports :: Cmd -> [String]
cmdGivenHints :: Cmd -> [String]
cmdWithGroups :: Cmd -> [String]
cmdGit :: Cmd -> Bool
cmdColor :: Cmd -> ColorMode
cmdThreads :: Cmd -> Int
cmdIgnore :: Cmd -> [String]
cmdShowAll :: Cmd -> Bool
cmdIgnoreSuggestions :: Cmd -> Bool
cmdExtension :: Cmd -> [String]
cmdLanguage :: Cmd -> [String]
cmdCross :: Cmd -> Bool
cmdFindHints :: Cmd -> [String]
cmdDataDir :: Cmd -> String
cmdDefault :: Cmd -> Bool
cmdPath :: Cmd -> [String]
cmdCppDefine :: Cmd -> [String]
cmdCppInclude :: Cmd -> [String]
cmdCppFile :: Cmd -> [String]
cmdCppSimple :: Cmd -> Bool
cmdCppAnsi :: Cmd -> Bool
cmdJson :: Cmd -> Bool
cmdCC :: Cmd -> Bool
cmdSARIF :: Cmd -> Bool
cmdNoSummary :: Cmd -> Bool
cmdOnly :: Cmd -> [String]
cmdNoExitCode :: Cmd -> Bool
cmdTiming :: Cmd -> Bool
cmdSerialise :: Cmd -> Bool
cmdRefactor :: Cmd -> Bool
cmdRefactorOptions :: Cmd -> String
cmdWithRefactor :: Cmd -> String
cmdIgnoreGlob :: Cmd -> [String]
cmdGenerateMdSummary :: Cmd -> [String]
cmdGenerateJsonSummary :: Cmd -> [String]
cmdGenerateExhaustiveConf :: Cmd -> [Severity]
cmdTest :: Cmd -> Bool
..} [String] -> IO ()
main String
dataDir [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
== String
"" then Maybe String
forall a. Maybe a
Nothing else String -> Maybe String
forall a. a -> Maybe a
Just String
cmdWithRefactor)

    (Int
failures, ()
ideas) <- Handle -> BufferMode -> IO (Int, ()) -> IO (Int, ())
forall a. Handle -> BufferMode -> IO a -> IO a
withBuffering Handle
stdout BufferMode
NoBuffering (IO (Int, ()) -> IO (Int, ())) -> IO (Int, ()) -> IO (Int, ())
forall a b. (a -> b) -> a -> b
$ Test () -> IO (Int, ())
forall a. Test a -> IO (Int, a)
withTests (Test () -> IO (Int, ())) -> Test () -> IO (Int, ())
forall a b. (a -> b) -> a -> b
$ do
        Bool
hasSrc <- IO Bool -> Test Bool
forall a. IO a -> Test a
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 String
"hlint.cabal"
        let useSrc :: Bool
useSrc = Bool
hasSrc Bool -> Bool -> Bool
&& [String] -> Bool
forall a. [a] -> 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 a. a -> Test a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String]
files else do
            [String]
xs <- IO [String] -> Test [String]
forall a. IO a -> Test a
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 a. a -> Test a
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 a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
".yml",String
".yaml"]]
        [(String, [Setting])]
testFiles <- IO [(String, [Setting])] -> Test [(String, [Setting])]
forall a. IO a -> Test a
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
$ \String
file -> do
            [Setting]
hints <- [(String, Maybe String)] -> IO [Setting]
readFilesConfig [(String
file, Maybe String
forall a. Maybe a
Nothing),(String
"CommandLine.yaml", String -> Maybe String
forall a. a -> Maybe a
Just String
"- group: {name: testing, enabled: true}")]
            (String, [Setting]) -> IO (String, [Setting])
forall a. a -> IO a
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
/= String
"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 String
msg m a
act = do IO () -> m ()
forall a. IO a -> m a
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]
++ String
" "); m a
act; IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
""

        IO () -> Test ()
forall a. IO a -> Test a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Test ()) -> IO () -> Test ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Testing (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Either String String -> Bool
forall a b. Either a b -> Bool
isRight Either String String
rpath then String
"with" else String
"WITHOUT") String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" refactoring)"
        IO () -> Test ()
forall a. IO a -> Test a
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
</> 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 String
"Source annotations" (Test () -> Test ()) -> Test () -> Test ()
forall a b. (a -> b) -> a -> b
$ do
            [Setting]
config <- IO [Setting] -> Test [Setting]
forall a. IO a -> Test a
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 [(String
".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
$ \(String
name,Hint
_) -> 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
== String
"Restrict" then [Setting]
config else [])
                                (String
"src/Hint" String -> String -> String
</> String
name String -> 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 String
"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 String
"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_ (\(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 String
"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
$ \(String
file,[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)

        Bool -> Test () -> Test ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([String] -> Bool
forall a. [a] -> 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 a. IO a -> Test a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Test ()) -> IO () -> Test ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Warning, couldn't find source code, so non-hint tests skipped"

    case Either String String
rpath of
        Left String
refactorNotFound -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
refactorNotFound, String
"Refactoring tests skipped"]
        Either String String
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
failures


---------------------------------------------------------------------
-- VARIOUS SMALL TESTS

-- Check all hints in the standard config files get sensible names
testNames :: [Setting] -> Test ()
testNames :: [Setting] -> Test ()
testNames [Setting]
hints = [Test ()] -> Test ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
    [ [String] -> Test ()
failed [String
"No name for the hint " String -> String -> String
forall a. [a] -> [a] -> [a]
++ HsExtendInstances (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> String
forall a. Outputable a => a -> String
unsafePrettyPrint HsExtendInstances (LHsExpr GhcPs)
HsExtendInstances (GenLocated SrcSpanAnnA (HsExpr GhcPs))
hintRuleLHS String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ==> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ HsExtendInstances (GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> String
forall a. Outputable a => a -> String
unsafePrettyPrint HsExtendInstances (LHsExpr GhcPs)
HsExtendInstances (GenLocated SrcSpanAnnA (HsExpr GhcPs))
hintRuleRHS]
    | SettingMatchExp x :: HintRule
x@HintRule{String
[Note]
Maybe (HsExtendInstances (LHsExpr GhcPs))
HsExtendInstances (LHsExpr GhcPs)
Scope
Severity
hintRuleLHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleRHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleSeverity :: Severity
hintRuleName :: String
hintRuleNotes :: [Note]
hintRuleScope :: Scope
hintRuleSide :: Maybe (HsExtendInstances (LHsExpr GhcPs))
hintRuleSeverity :: HintRule -> Severity
hintRuleName :: HintRule -> String
hintRuleNotes :: HintRule -> [Note]
hintRuleScope :: HintRule -> Scope
hintRuleLHS :: HintRule -> HsExtendInstances (LHsExpr GhcPs)
hintRuleRHS :: HintRule -> HsExtendInstances (LHsExpr GhcPs)
hintRuleSide :: HintRule -> Maybe (HsExtendInstances (LHsExpr GhcPs))
..} <- [Setting]
hints, String
hintRuleName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
defaultHintName]


-- Check that the default.yaml template I supply is valid when I strip off all the comments, since that's
-- what a user gets with --default
checkCommentedYaml :: FilePath -> IO ()
checkCommentedYaml :: String -> IO ()
checkCommentedYaml 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 String
x <- [String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"# " 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 (\Char
x -> Char -> Bool
isAlpha Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'$') (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Setting]
e