{-# LANGUAGE PatternGuards, ScopedTypeVariables, RecordWildCards, ViewPatterns #-}

-- | Check the input/output pairs in the tests/ directory
module Test.InputOutput(testInputOutput) where

import Control.Applicative
import Data.Tuple.Extra
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Data.List.Extra
import Data.IORef
import System.Directory
import System.FilePath
import System.Console.CmdArgs.Explicit
import System.Console.CmdArgs.Verbosity
import System.Exit
import System.IO.Extra
import Prelude
import Data.Version (showVersion)
import Paths_hlint (version)

import Test.Util


testInputOutput :: ([String] -> IO ()) -> Test ()
testInputOutput :: ([String] -> IO ()) -> Test ()
testInputOutput [String] -> IO ()
main = do
    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
"tests"
    xs <- pure $ filter ((==) ".test" . takeExtension) xs
    forM_ xs $ \String
file -> do
        ios <- IO [InputOutput] -> Test [InputOutput]
forall a. IO a -> Test a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [InputOutput] -> Test [InputOutput])
-> IO [InputOutput] -> Test [InputOutput]
forall a b. (a -> b) -> a -> b
$ String -> [InputOutput]
parseInputOutputs (String -> [InputOutput]) -> IO String -> IO [InputOutput]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile (String
"tests" String -> String -> String
</> String
file)
        forM_ (zipFrom 1 ios) $ \(Integer
i,io :: InputOutput
io@InputOutput{String
[String]
[(String, String)]
Maybe ExitCode
name :: String
files :: [(String, String)]
run :: [String]
output :: String
exit :: Maybe ExitCode
name :: InputOutput -> String
files :: InputOutput -> [(String, String)]
run :: InputOutput -> [String]
output :: InputOutput -> String
exit :: InputOutput -> Maybe ExitCode
..}) -> do
            Test ()
progress
            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, String)] -> ((String, String) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, String)]
files (((String, String) -> IO ()) -> IO ())
-> ((String, String) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(String
name,String
contents) -> do
                Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
takeDirectory String
name
                String -> String -> IO ()
writeFile String
name String
contents
            ([String] -> IO ()) -> InputOutput -> Test ()
checkInputOutput [String] -> IO ()
main InputOutput
io{name= "_" ++ takeBaseName file ++ "_" ++ show i}
        liftIO $ mapM_ (removeFile . fst) $ concatMap files ios

data InputOutput = InputOutput
    {InputOutput -> String
name :: String
    ,InputOutput -> [(String, String)]
files :: [(FilePath, String)]
    ,InputOutput -> [String]
run :: [String]
    ,InputOutput -> String
output :: String
    ,InputOutput -> Maybe ExitCode
exit :: Maybe ExitCode
    } deriving InputOutput -> InputOutput -> Bool
(InputOutput -> InputOutput -> Bool)
-> (InputOutput -> InputOutput -> Bool) -> Eq InputOutput
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InputOutput -> InputOutput -> Bool
== :: InputOutput -> InputOutput -> Bool
$c/= :: InputOutput -> InputOutput -> Bool
/= :: InputOutput -> InputOutput -> Bool
Eq

parseInputOutputs :: String -> [InputOutput]
parseInputOutputs :: String -> [InputOutput]
parseInputOutputs = InputOutput -> [String] -> [InputOutput]
f InputOutput
z ([String] -> [InputOutput])
-> (String -> [String]) -> String -> [InputOutput]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
    where
        z :: InputOutput
z = String
-> [(String, String)]
-> [String]
-> String
-> Maybe ExitCode
-> InputOutput
InputOutput String
"unknown" [] [] String
"" Maybe ExitCode
forall a. Maybe a
Nothing
        interest :: String -> Bool
interest String
x = (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
x) [String
"----",String
"FILE",String
"RUN",String
"OUTPUT",String
"EXIT"]
        outputTemplateVars :: [(String, String)]
outputTemplateVars = [ (String
"__VERSION__", Version -> String
showVersion Version
version) ]
        substituteTemplateVars :: String -> String
substituteTemplateVars = ((String, String) -> String -> String)
-> [(String, String)] -> String -> String
forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap ((String -> String -> String -> String)
-> (String, String) -> String -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> String -> String -> String
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace) [(String, String)]
outputTemplateVars

        f :: InputOutput -> [String] -> [InputOutput]
f InputOutput
io ((String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"RUN " -> Just String
flags):[String]
xs) = InputOutput -> [String] -> [InputOutput]
f InputOutput
io{run = splitArgs flags} [String]
xs
        f InputOutput
io ((String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"EXIT " -> Just String
code):[String]
xs) = InputOutput -> [String] -> [InputOutput]
f InputOutput
io{exit = Just $ let i = String -> Int
forall a. Read a => String -> a
read String
code in if i == 0 then ExitSuccess else ExitFailure i} [String]
xs
        f InputOutput
io ((String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"FILE " -> Just String
file):[String]
xs) | ([String]
str,[String]
xs) <- [String] -> ([String], [String])
g [String]
xs = InputOutput -> [String] -> [InputOutput]
f InputOutput
io{files = files io ++ [(file,unlines str)]} [String]
xs
        f InputOutput
io (String
"OUTPUT":[String]
xs) | ([String]
str,[String]
xs) <- [String] -> ([String], [String])
g [String]
xs = InputOutput -> [String] -> [InputOutput]
f InputOutput
io{output = unlines str} [String]
xs
        f InputOutput
io ((String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
"----" -> Bool
True):[String]
xs) = [InputOutput
io | InputOutput
io InputOutput -> InputOutput -> Bool
forall a. Eq a => a -> a -> Bool
/= InputOutput
z] [InputOutput] -> [InputOutput] -> [InputOutput]
forall a. [a] -> [a] -> [a]
++ InputOutput -> [String] -> [InputOutput]
f InputOutput
z [String]
xs
        f InputOutput
io [] = [InputOutput
io | InputOutput
io InputOutput -> InputOutput -> Bool
forall a. Eq a => a -> a -> Bool
/= InputOutput
z]
        f InputOutput
io (String
x:[String]
xs) = String -> [InputOutput]
forall a. HasCallStack => String -> a
error (String -> [InputOutput]) -> String -> [InputOutput]
forall a b. (a -> b) -> a -> b
$ String
"Unknown test item, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x

        g :: [String] -> ([String], [String])
g = ([String] -> [String])
-> ([String], [String]) -> ([String], [String])
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
substituteTemplateVars ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. [a] -> [a]
reverse) (([String], [String]) -> ([String], [String]))
-> ([String] -> ([String], [String]))
-> [String]
-> ([String], [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break String -> Bool
interest


---------------------------------------------------------------------
-- CHECK INPUT/OUTPUT PAIRS

checkInputOutput :: ([String] -> IO ()) -> InputOutput -> Test ()
checkInputOutput :: ([String] -> IO ()) -> InputOutput -> Test ()
checkInputOutput [String] -> IO ()
main InputOutput{String
[String]
[(String, String)]
Maybe ExitCode
name :: InputOutput -> String
files :: InputOutput -> [(String, String)]
run :: InputOutput -> [String]
output :: InputOutput -> String
exit :: InputOutput -> Maybe ExitCode
name :: String
files :: [(String, String)]
run :: [String]
output :: String
exit :: Maybe ExitCode
..} = do
    code <- IO (IORef ExitCode) -> Test (IORef ExitCode)
forall a. IO a -> Test a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef ExitCode) -> Test (IORef ExitCode))
-> IO (IORef ExitCode) -> Test (IORef ExitCode)
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO (IORef ExitCode)
forall a. a -> IO (IORef a)
newIORef ExitCode
ExitSuccess
    got <- liftIO $ fmap (reverse . dropWhile null . reverse . map trimEnd . lines . fst) $ captureOutput $
        handle (\(SomeException
e::SomeException) -> SomeException -> IO ()
forall a. Show a => a -> IO ()
print SomeException
e) $
        handle (\(ExitCode
e::ExitCode) -> IORef ExitCode -> ExitCode -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ExitCode
code ExitCode
e) $
        bracket getVerbosity setVerbosity $ const $ setVerbosity Normal >> main run
    code <- liftIO $ readIORef code
    (want,got) <- pure $ matchStarStar (lines output) got

    if maybe False (/= code) exit then
        failed
            ["TEST FAILURE IN tests/" ++ name
            ,"WRONG EXIT CODE"
            ,"GOT : " ++ show code
            ,"WANT: " ++ show exit
            ]
     else if length got == length want && and (zipWith matchStar want got) then
        passed
     else do
        let trail = Int -> String -> [String]
forall a. Int -> a -> [a]
replicate (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
got) ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
want)) String
"<EOF>"
        let (i,g,w):_ = [(i,g,w) | (i,g,w) <- zip3 [1..] (got++trail) (want++trail), not $ matchStar w g]
        failed $
            ["TEST FAILURE IN tests/" ++ name
            ,"DIFFER ON LINE: " ++ show i
            ,"GOT : " ++ g
            ,"WANT: " ++ w
            ,"FULL OUTPUT FOR GOT:"] ++ got


-- | First string may have stars in it (the want)
matchStar :: String -> String -> Bool
matchStar :: String -> String -> Bool
matchStar (Char
'*':String
xs) String
ys = (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
matchStar String
xs) ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ String -> [String]
forall a. [a] -> [[a]]
tails String
ys
matchStar (Char
'/':Char
x:String
xs) (Char
'\\':Char
'\\':String
ys) | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/' = String -> String -> Bool
matchStar (Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs) String
ys -- JSON escaped newlines
matchStar (Char
x:String
xs) (Char
y:String
ys) = Char -> Char -> Bool
eq Char
x Char
y Bool -> Bool -> Bool
&& String -> String -> Bool
matchStar String
xs String
ys
    where
        -- allow path differences between Windows and Linux
        eq :: Char -> Char -> Bool
eq Char
'/' Char
y = Char -> Bool
isPathSeparator Char
y
        eq Char
x Char
y = Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
y
matchStar [] [] = Bool
True
matchStar String
_ String
_ = Bool
False


matchStarStar :: [String] -> [String] -> ([String], [String])
matchStarStar :: [String] -> [String] -> ([String], [String])
matchStarStar [String]
want [String]
got = case (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"**") [String]
want of
    ([String]
_, []) -> ([String]
want, [String]
got)
    ([String]
w1,String
_:[String]
w2) -> ([String]
w1[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++[String]
w2, [String]
g1 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
takeEnd ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
w2) [String]
g2)
        where ([String]
g1,[String]
g2) = Int -> [String] -> ([String], [String])
forall a. Int -> [a] -> ([a], [a])
splitAt ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
w1) [String]
got