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

-- | Check the <TEST> annotations within source and hint files.
module Test.Annotations(testAnnotations) where

import Control.Exception.Extra
import Data.Tuple.Extra
import Data.Char
import Data.Either.Extra
import Data.List.Extra
import Data.Maybe
import Control.Monad
import System.FilePath
import Control.Monad.IO.Class
import Data.Function
import Data.Yaml
import qualified Data.ByteString.Char8 as BS

import Config.Type
import Idea
import Apply
import HSE.All
import Test.Util
import Data.Functor
import Prelude
import Config.Yaml


-- Input, Output
-- Output = Nothing, should not match
-- Output = Just xs, should match xs
data TestCase = TestCase SrcLoc String (Maybe String) [Setting] deriving (Int -> TestCase -> ShowS
[TestCase] -> ShowS
TestCase -> String
(Int -> TestCase -> ShowS)
-> (TestCase -> String) -> ([TestCase] -> ShowS) -> Show TestCase
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TestCase] -> ShowS
$cshowList :: [TestCase] -> ShowS
show :: TestCase -> String
$cshow :: TestCase -> String
showsPrec :: Int -> TestCase -> ShowS
$cshowsPrec :: Int -> TestCase -> ShowS
Show)

testAnnotations :: [Setting] -> FilePath -> Test ()
testAnnotations :: [Setting] -> String -> Test ()
testAnnotations setting :: [Setting]
setting file :: String
file = do
    [TestCase]
tests <- IO [TestCase] -> Test [TestCase]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [TestCase] -> Test [TestCase])
-> IO [TestCase] -> Test [TestCase]
forall a b. (a -> b) -> a -> b
$ String -> IO [TestCase]
parseTestFile String
file
    (TestCase -> Test ()) -> [TestCase] -> Test ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TestCase -> Test ()
f [TestCase]
tests
    where
        f :: TestCase -> Test ()
f (TestCase loc :: SrcLoc
loc inp :: String
inp out :: Maybe String
out additionalSettings :: [Setting]
additionalSettings) = do
            Either SomeException [Idea]
ideas <- IO (Either SomeException [Idea])
-> Test (Either SomeException [Idea])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException [Idea])
 -> Test (Either SomeException [Idea]))
-> IO (Either SomeException [Idea])
-> Test (Either SomeException [Idea])
forall a b. (a -> b) -> a -> b
$ IO [Idea] -> IO (Either SomeException [Idea])
forall a. IO a -> IO (Either SomeException a)
try_ (IO [Idea] -> IO (Either SomeException [Idea]))
-> IO [Idea] -> IO (Either SomeException [Idea])
forall a b. (a -> b) -> a -> b
$ do
                [Idea]
res <- ParseFlags -> [Setting] -> String -> Maybe String -> IO [Idea]
applyHintFile ParseFlags
defaultParseFlags ([Setting]
setting [Setting] -> [Setting] -> [Setting]
forall a. [a] -> [a] -> [a]
++ [Setting]
additionalSettings) String
file (Maybe String -> IO [Idea]) -> Maybe String -> IO [Idea]
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
inp
                Int -> IO Int
forall a. a -> IO a
evaluate (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ [Idea] -> String
forall a. Show a => a -> String
show [Idea]
res
                [Idea] -> IO [Idea]
forall (m :: * -> *) a. Monad m => a -> m a
return [Idea]
res

            -- the hints from data/Test.hs are really fake hints we don't actually deploy
            -- so don't record them
            Bool -> Test () -> Test ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ShowS
takeFileName String
file String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= "Test.hs") (Test () -> Test ()) -> Test () -> Test ()
forall a b. (a -> b) -> a -> b
$
                (SomeException -> Test ())
-> ([Idea] -> Test ()) -> Either SomeException [Idea] -> Test ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Test () -> SomeException -> Test ()
forall a b. a -> b -> a
const (Test () -> SomeException -> Test ())
-> Test () -> SomeException -> Test ()
forall a b. (a -> b) -> a -> b
$ () -> Test ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) [Idea] -> Test ()
addIdeas Either SomeException [Idea]
ideas

            let good :: Bool
good = case (Maybe String
out, Either SomeException [Idea]
ideas) of
                    (Nothing, Right []) -> Bool
True
                    (Just x :: String
x, Right [idea :: Idea
idea]) | String -> Idea -> Bool
match String
x Idea
idea -> Bool
True
                    _ -> Bool
False
            let bad :: [Test ()]
bad =
                    [[String] -> Test ()
failed ([String] -> Test ()) -> [String] -> Test ()
forall a b. (a -> b) -> a -> b
$
                        ["TEST FAILURE (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ((SomeException -> Int)
-> ([Idea] -> Int) -> Either SomeException [Idea] -> Int
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Int -> SomeException -> Int
forall a b. a -> b -> a
const 1) [Idea] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Either SomeException [Idea]
ideas) String -> ShowS
forall a. [a] -> [a] -> [a]
++ " hints generated)"
                        ,"SRC: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SrcLoc -> String
showSrcLoc SrcLoc
loc
                        ,"INPUT: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
inp] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                        ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ("OUTPUT: " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ((SomeException -> [String])
-> ([Idea] -> [String]) -> Either SomeException [Idea] -> [String]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> [String]
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> [String])
-> (SomeException -> String) -> SomeException -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show) ((Idea -> String) -> [Idea] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Idea -> String
forall a. Show a => a -> String
show) Either SomeException [Idea]
ideas) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                        ["WANTED: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "<failure>" Maybe String
out]
                        | Bool -> Bool
not Bool
good] [Test ()] -> [Test ()] -> [Test ()]
forall a. [a] -> [a] -> [a]
++
                    [[String] -> Test ()
failed
                        ["TEST FAILURE (BAD LOCATION)"
                        ,"SRC: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SrcLoc -> String
showSrcLoc SrcLoc
loc
                        ,"INPUT: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
inp
                        ,"OUTPUT: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Idea -> String
forall a. Show a => a -> String
show Idea
i]
                        | i :: Idea
i@Idea{..} <- [Idea] -> Either SomeException [Idea] -> [Idea]
forall b a. b -> Either a b -> b
fromRight [] Either SomeException [Idea]
ideas, let SrcLoc{..} = SrcSpan -> SrcLoc
forall si. SrcInfo si => si -> SrcLoc
getPointLoc SrcSpan
ideaSpan, String
srcFilename String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "" Bool -> Bool -> Bool
|| Int
srcLine Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
|| Int
srcColumn Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0]
            if [Test ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Test ()]
bad then Test ()
passed else [Test ()] -> Test ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [Test ()]
bad

        match :: String -> Idea -> Bool
match "???" _ = Bool
True
        match (String -> (String, String)
word1 -> ("@Message",msg :: String
msg)) i :: Idea
i = Idea -> String
ideaHint Idea
i String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
msg
        match (String -> (String, String)
word1 -> ("@Note",note :: String
note)) i :: Idea
i = (Note -> String) -> [Note] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Note -> String
forall a. Show a => a -> String
show (Idea -> [Note]
ideaNote Idea
i) [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
== [String
note]
        match "@NoNote" i :: Idea
i = [Note] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Idea -> [Note]
ideaNote Idea
i)
        match (String -> (String, String)
word1 -> ('@':sev :: String
sev, msg :: String
msg)) i :: Idea
i = String
sev String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Severity -> String
forall a. Show a => a -> String
show (Idea -> Severity
ideaSeverity Idea
i) Bool -> Bool -> Bool
&& String -> Idea -> Bool
match String
msg Idea
i
        match msg :: String
msg i :: Idea
i = (String -> String -> Bool) -> ShowS -> String -> String -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(==) ShowS
norm (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ Idea -> Maybe String
ideaTo Idea
i) String
msg

        -- FIXME: Should use a better check for expected results
        norm :: ShowS
norm = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter ((Char -> Bool) -> ShowS) -> (Char -> Bool) -> ShowS
forall a b. (a -> b) -> a -> b
$ \x :: Char
x -> Bool -> Bool
not (Char -> Bool
isSpace Char
x) Bool -> Bool -> Bool
&& Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= ';'


parseTestFile :: FilePath -> IO [TestCase]
parseTestFile :: String -> IO [TestCase]
parseTestFile file :: String
file =
    -- we remove all leading # symbols since Yaml only lets us do comments that way
    Maybe [Setting] -> [(Int, String)] -> [TestCase]
f Maybe [Setting]
forall a. Maybe a
Nothing ([(Int, String)] -> [TestCase])
-> (String -> [(Int, String)]) -> String -> [TestCase]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [1..] ([String] -> [(Int, String)])
-> (String -> [String]) -> String -> [(Int, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\x :: String
x -> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
x (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix "# " String
x) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> [TestCase]) -> IO String -> IO [TestCase]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
file
    where
        open :: String -> Maybe [Setting]
        open :: String -> Maybe [Setting]
open line :: String
line
          |  "<TEST>" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
line =
             let suffix :: String
suffix = String -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
dropPrefix "<TEST>" String
line
                 config :: Either ParseException ConfigYaml
config = ByteString -> Either ParseException ConfigYaml
forall a. FromJSON a => ByteString -> Either ParseException a
decodeEither'  (ByteString -> Either ParseException ConfigYaml)
-> ByteString -> Either ParseException ConfigYaml
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BS.pack String
suffix
             in case Either ParseException ConfigYaml
config of
                  Left err :: ParseException
err -> [Setting] -> Maybe [Setting]
forall a. a -> Maybe a
Just []
                  Right config :: ConfigYaml
config -> [Setting] -> Maybe [Setting]
forall a. a -> Maybe a
Just ([Setting] -> Maybe [Setting]) -> [Setting] -> Maybe [Setting]
forall a b. (a -> b) -> a -> b
$ [ConfigYaml] -> [Setting]
settingsFromConfigYaml [ConfigYaml
config]
          | Bool
otherwise = Maybe [Setting]
forall a. Maybe a
Nothing

        shut :: String -> Bool
        shut :: String -> Bool
shut = String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf "</TEST>"

        f :: Maybe [Setting] -> [(Int, String)] -> [TestCase]
        f :: Maybe [Setting] -> [(Int, String)] -> [TestCase]
f Nothing ((i :: Int
i,x :: String
x):xs :: [(Int, String)]
xs) = Maybe [Setting] -> [(Int, String)] -> [TestCase]
f (String -> Maybe [Setting]
open String
x) [(Int, String)]
xs
        f (Just s :: [Setting]
s)  ((i :: Int
i,x :: String
x):xs :: [(Int, String)]
xs)
            | String -> Bool
shut String
x = Maybe [Setting] -> [(Int, String)] -> [TestCase]
f Maybe [Setting]
forall a. Maybe a
Nothing [(Int, String)]
xs
            | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
x Bool -> Bool -> Bool
|| "-- " String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
x = Maybe [Setting] -> [(Int, String)] -> [TestCase]
f ([Setting] -> Maybe [Setting]
forall a. a -> Maybe a
Just [Setting]
s) [(Int, String)]
xs
            | "\\" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
x, (_,y :: String
y):ys :: [(Int, String)]
ys <- [(Int, String)]
xs = Maybe [Setting] -> [(Int, String)] -> [TestCase]
f ([Setting] -> Maybe [Setting]
forall a. a -> Maybe a
Just [Setting]
s) ([(Int, String)] -> [TestCase]) -> [(Int, String)] -> [TestCase]
forall a b. (a -> b) -> a -> b
$ (Int
i,ShowS
forall a. [a] -> [a]
init String
xString -> ShowS
forall a. [a] -> [a] -> [a]
++"\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++String
y)(Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
:[(Int, String)]
ys
            | Bool
otherwise = String -> Int -> String -> [Setting] -> TestCase
parseTest String
file Int
i String
x [Setting]
s TestCase -> [TestCase] -> [TestCase]
forall a. a -> [a] -> [a]
: Maybe [Setting] -> [(Int, String)] -> [TestCase]
f ([Setting] -> Maybe [Setting]
forall a. a -> Maybe a
Just [Setting]
s) [(Int, String)]
xs
        f _ [] = []


parseTest :: String -> Int -> String -> [Setting] -> TestCase
parseTest :: String -> Int -> String -> [Setting] -> TestCase
parseTest file :: String
file i :: Int
i x :: String
x = (String -> Maybe String -> [Setting] -> TestCase)
-> (String, Maybe String) -> [Setting] -> TestCase
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (SrcLoc -> String -> Maybe String -> [Setting] -> TestCase
TestCase (String -> Int -> Int -> SrcLoc
SrcLoc String
file Int
i 0)) ((String, Maybe String) -> [Setting] -> TestCase)
-> (String, Maybe String) -> [Setting] -> TestCase
forall a b. (a -> b) -> a -> b
$ String -> (String, Maybe String)
f String
x
    where
        f :: String -> (String, Maybe String)
f x :: String
x | Just x :: String
x <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix "<COMMENT>" String
x = ShowS -> (String, Maybe String) -> (String, Maybe String)
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first ("--"String -> ShowS
forall a. [a] -> [a] -> [a]
++) ((String, Maybe String) -> (String, Maybe String))
-> (String, Maybe String) -> (String, Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> (String, Maybe String)
f String
x
        f (' ':'-':'-':xs :: String
xs) | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
xs Bool -> Bool -> Bool
|| " " String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
xs = ("", String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
xs)
        f (x :: Char
x:xs :: String
xs) = ShowS -> (String, Maybe String) -> (String, Maybe String)
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first (Char
xChar -> ShowS
forall a. a -> [a] -> [a]
:) ((String, Maybe String) -> (String, Maybe String))
-> (String, Maybe String) -> (String, Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> (String, Maybe String)
f String
xs
        f [] = ([], Maybe String
forall a. Maybe a
Nothing)