{-# 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 Test.Util


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

        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 :: [String]
run = String -> [String]
splitArgs String
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 :: Maybe ExitCode
exit = ExitCode -> Maybe ExitCode
forall a. a -> Maybe a
Just (ExitCode -> Maybe ExitCode) -> ExitCode -> Maybe ExitCode
forall a b. (a -> b) -> a -> b
$ let i :: Int
i = String -> Int
forall a. Read a => String -> a
read String
code in if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then ExitCode
ExitSuccess else Int -> ExitCode
ExitFailure Int
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 :: [(String, String)]
files = InputOutput -> [(String, String)]
files InputOutput
io [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ [(String
file,[String] -> String
unlines [String]
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 :: String
output = [String] -> String
unlines [String]
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]
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 (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
exit :: Maybe ExitCode
output :: String
run :: [String]
files :: [(String, String)]
name :: String
exit :: InputOutput -> Maybe ExitCode
output :: InputOutput -> String
run :: InputOutput -> [String]
files :: InputOutput -> [(String, String)]
name :: InputOutput -> String
..} = do
    IORef ExitCode
code <- IO (IORef ExitCode) -> Test (IORef ExitCode)
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
    [String]
got <- 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, ()) -> [String]) -> IO (String, ()) -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([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 (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]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
trimEnd ([String] -> [String])
-> ((String, ()) -> [String]) -> (String, ()) -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> [String])
-> ((String, ()) -> String) -> (String, ()) -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, ()) -> String
forall a b. (a, b) -> a
fst) (IO (String, ()) -> IO [String]) -> IO (String, ()) -> IO [String]
forall a b. (a -> b) -> a -> b
$ IO () -> IO (String, ())
forall a. IO a -> IO (String, a)
captureOutput (IO () -> IO (String, ())) -> IO () -> IO (String, ())
forall a b. (a -> b) -> a -> b
$
        (SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\(SomeException
e::SomeException) -> SomeException -> IO ()
forall a. Show a => a -> IO ()
print SomeException
e) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        (ExitCode -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\(ExitCode
e::ExitCode) -> IORef ExitCode -> ExitCode -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ExitCode
code ExitCode
e) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        IO Verbosity
-> (Verbosity -> IO ()) -> (Verbosity -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO Verbosity
getVerbosity Verbosity -> IO ()
setVerbosity ((Verbosity -> IO ()) -> IO ()) -> (Verbosity -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> Verbosity -> IO ()
forall a b. a -> b -> a
const (IO () -> Verbosity -> IO ()) -> IO () -> Verbosity -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> IO ()
setVerbosity Verbosity
Normal IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [String] -> IO ()
main [String]
run
    ExitCode
code <- IO ExitCode -> Test ExitCode
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExitCode -> Test ExitCode) -> IO ExitCode -> Test ExitCode
forall a b. (a -> b) -> a -> b
$ IORef ExitCode -> IO ExitCode
forall a. IORef a -> IO a
readIORef IORef ExitCode
code
    ([String]
want,[String]
got) <- ([String], [String]) -> Test ([String], [String])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([String], [String]) -> Test ([String], [String]))
-> ([String], [String]) -> Test ([String], [String])
forall a b. (a -> b) -> a -> b
$ [String] -> [String] -> ([String], [String])
matchStarStar (String -> [String]
lines String
output) [String]
got

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