{-# 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
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
cmdSARIF :: 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]
cmdIgnoreSuggestions :: Cmd -> Bool
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]
..} [String] -> IO ()
main String
dataDir [String]
files = do
    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)

    (failures, ideas) <- withBuffering stdout NoBuffering $ withTests $ do
        hasSrc <- liftIO $ doesFileExist "hlint.cabal"
        let useSrc = Bool
hasSrc Bool -> Bool -> Bool
&& [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
files
        testFiles <- if files /= [] then pure files else do
            xs <- liftIO $ getDirectoryContents dataDir
            pure [dataDir </> x | x <- xs, takeExtension x `elem` [".yml",".yaml"]]
        testFiles <- liftIO $ forM testFiles $ \String
file -> do
            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}")]
            pure (file, hints ++ (if takeBaseName file /= "Test" then [] else map (Builtin . fst) builtinHints))
        let 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
""

        liftIO $ putStrLn $ "Testing (" ++ (if isRight rpath then "with" else "WITHOUT") ++ " refactoring)"
        liftIO $ checkCommentedYaml $ dataDir </> "default.yaml"
        when useSrc $ wrap "Source annotations" $ do
            config <- liftIO $ readFilesConfig [(".hlint.yaml",Nothing)]
            forM_ builtinHints $ \(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)
        when useSrc $ wrap "Input/outputs" $ testInputOutput main

        wrap "Hint names" $ 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) testFiles
        wrap "Hint annotations" $ forM_ testFiles $ \(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)

        when (null files && not hasSrc) $ liftIO $ putStrLn "Warning, couldn't find source code, so non-hint tests skipped"

    case 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 ()
    pure 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))
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
..} <- [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
    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
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]
    e <- readFilesConfig [(file, Just $ unlines src2)]
    void $ evaluate $ length e