{-# LANGUAGE PatternGuards, RecordWildCards, ViewPatterns #-}
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
data TestCase = TestCase SrcLoc String (Maybe String) [Setting] deriving (Show)
testAnnotations :: [Setting] -> FilePath -> Test ()
testAnnotations setting file = do
tests <- liftIO $ parseTestFile file
mapM_ f tests
where
f (TestCase loc inp out additionalSettings) = do
ideas <- liftIO $ try_ $ do
res <- applyHintFile defaultParseFlags (setting ++ additionalSettings) file $ Just inp
evaluate $ length $ show res
return res
when (takeFileName file /= "Test.hs") $
either (const $ return ()) addIdeas ideas
let good = case (out, ideas) of
(Nothing, Right []) -> True
(Just x, Right [idea]) | match x idea -> True
_ -> False
let bad =
[failed $
["TEST FAILURE (" ++ show (either (const 1) length ideas) ++ " hints generated)"
,"SRC: " ++ showSrcLoc loc
,"INPUT: " ++ inp] ++
map ("OUTPUT: " ++) (either (return . show) (map show) ideas) ++
["WANTED: " ++ fromMaybe "<failure>" out]
| not good] ++
[failed
["TEST FAILURE (BAD LOCATION)"
,"SRC: " ++ showSrcLoc loc
,"INPUT: " ++ inp
,"OUTPUT: " ++ show i]
| i@Idea{..} <- fromRight [] ideas, let SrcLoc{..} = getPointLoc ideaSpan, srcFilename == "" || srcLine == 0 || srcColumn == 0]
if null bad then passed else sequence_ bad
match "???" _ = True
match (word1 -> ("@Message",msg)) i = ideaHint i == msg
match (word1 -> ("@Note",note)) i = map show (ideaNote i) == [note]
match "@NoNote" i = null (ideaNote i)
match (word1 -> ('@':sev, msg)) i = sev == show (ideaSeverity i) && match msg i
match msg i = on (==) norm (fromMaybe "" $ ideaTo i) msg
norm = filter $ \x -> not (isSpace x) && x /= ';'
parseTestFile :: FilePath -> IO [TestCase]
parseTestFile file =
f Nothing . zip [1..] . map (\x -> fromMaybe x $ stripPrefix "# " x) . lines <$> readFile file
where
open :: String -> Maybe [Setting]
open line
| "<TEST>" `isPrefixOf` line =
let suffix = dropPrefix "<TEST>" line
config = decodeEither' $ BS.pack suffix
in case config of
Left err -> Just []
Right config -> Just $ settingsFromConfigYaml [config]
| otherwise = Nothing
shut :: String -> Bool
shut = isPrefixOf "</TEST>"
f :: Maybe [Setting] -> [(Int, String)] -> [TestCase]
f Nothing ((i,x):xs) = f (open x) xs
f (Just s) ((i,x):xs)
| shut x = f Nothing xs
| null x || "-- " `isPrefixOf` x = f (Just s) xs
| "\\" `isSuffixOf` x, (_,y):ys <- xs = f (Just s) $ (i,init x++"\n"++y):ys
| otherwise = parseTest file i x s : f (Just s) xs
f _ [] = []
parseTest :: String -> Int -> String -> [Setting] -> TestCase
parseTest file i x = uncurry (TestCase (SrcLoc file i 0)) $ f x
where
f x | Just x <- stripPrefix "<COMMENT>" x = first ("--"++) $ f x
f (' ':'-':'-':xs) | null xs || " " `isPrefixOf` xs = ("", Just $ dropWhile isSpace xs)
f (x:xs) = first (x:) $ f xs
f [] = ([], Nothing)