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

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

        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Testing (" forall a. [a] -> [a] -> [a]
++ (if forall a b. Either a b -> Bool
isRight Either String String
rpath then String
"with" else String
"WITHOUT") forall a. [a] -> [a] -> [a]
++ String
" refactoring)"
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
checkCommentedYaml forall a b. (a -> b) -> a -> b
$ String
dataDir String -> String -> String
</> String
"default.yaml"
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
useSrc forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {a}. MonadIO m => String -> m a -> m ()
wrap String
"Source annotations" forall a b. (a -> b) -> a -> b
$ do
            [Setting]
config <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [(String, Maybe String)] -> IO [Setting]
readFilesConfig [(String
".hlint.yaml",forall a. Maybe a
Nothing)]
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, Hint)]
builtinHints forall a b. (a -> b) -> a -> b
$ \(String
name,Hint
_) -> do
                Test ()
progress
                [Setting] -> String -> Maybe String -> Test ()
testAnnotations (String -> Setting
Builtin String
name forall a. a -> [a] -> [a]
: if String
name 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")
                                (forall a b. Either a b -> Maybe b
eitherToMaybe Either String String
rpath)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
useSrc forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {a}. MonadIO m => String -> m a -> m ()
wrap String
"Input/outputs" forall a b. (a -> b) -> a -> b
$ ([String] -> IO ()) -> Test ()
testInputOutput [String] -> IO ()
main

        forall {m :: * -> *} {a}. MonadIO m => String -> m a -> m ()
wrap String
"Hint names" forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd (String, [Setting])
x) [(String, [Setting])]
testFiles
        forall {m :: * -> *} {a}. MonadIO m => String -> m a -> m ()
wrap String
"Hint annotations" forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, [Setting])]
testFiles forall a b. (a -> b) -> a -> b
$ \(String
file,[Setting]
h) -> do Test ()
progress; [Setting] -> String -> Maybe String -> Test ()
testAnnotations [Setting]
h String
file (forall a b. Either a b -> Maybe b
eitherToMaybe Either String String
rpath)

        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
files Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
hasSrc) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
refactorNotFound, String
"Refactoring tests skipped"]
        Either String String
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    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 = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
    [ [String] -> Test ()
failed [String
"No name for the hint " forall a. [a] -> [a] -> [a]
++ forall a. Outputable a => a -> String
unsafePrettyPrint HsExtendInstances (LHsExpr GhcPs)
hintRuleLHS forall a. [a] -> [a] -> [a]
++ String
" ==> " forall a. [a] -> [a] -> [a]
++ forall a. Outputable a => a -> String
unsafePrettyPrint HsExtendInstances (LHsExpr GhcPs)
hintRuleRHS]
    | SettingMatchExp x :: HintRule
x@HintRule{String
[Note]
Maybe (HsExtendInstances (LHsExpr GhcPs))
HsExtendInstances (LHsExpr GhcPs)
Scope
Severity
hintRuleSide :: HintRule -> Maybe (HsExtendInstances (LHsExpr GhcPs))
hintRuleRHS :: HintRule -> HsExtendInstances (LHsExpr GhcPs)
hintRuleLHS :: HintRule -> HsExtendInstances (LHsExpr GhcPs)
hintRuleScope :: HintRule -> Scope
hintRuleNotes :: HintRule -> [Note]
hintRuleName :: HintRule -> String
hintRuleSeverity :: HintRule -> Severity
hintRuleSide :: Maybe (HsExtendInstances (LHsExpr GhcPs))
hintRuleScope :: Scope
hintRuleNotes :: [Note]
hintRuleName :: String
hintRuleSeverity :: Severity
hintRuleRHS :: HsExtendInstances (LHsExpr GhcPs)
hintRuleLHS :: HsExtendInstances (LHsExpr GhcPs)
..} <- [Setting]
hints, String
hintRuleName 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 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 <- [forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"# " String
x], Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Char
x -> Char -> Bool
isAlpha Char
x Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
'$') forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
1 String
x]
    [Setting]
e <- [(String, Maybe String)] -> IO [Setting]
readFilesConfig [(String
file, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
src2)]
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Setting]
e