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

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

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

import Config.Type
import Idea
import Apply
import Extension
import Refact
import Test.Util
import Prelude
import Config.Yaml
import FastString

import GHC.Util
import SrcLoc
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable

#ifdef HS_YAML

import Data.YAML.Aeson (decode1Strict)
import Data.YAML (Pos)
import Data.ByteString (ByteString)

decodeEither' :: ByteString -> Either (Pos, String) ConfigYaml
decodeEither' = decode1Strict

#else

import Data.Yaml

#endif

-- Input, Output
-- Output = Nothing, should not match
-- Output = Just xs, should match xs
data TestCase = TestCase SrcLoc Refactor 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)

data Refactor = TestRefactor | SkipRefactor deriving (Refactor -> Refactor -> Bool
(Refactor -> Refactor -> Bool)
-> (Refactor -> Refactor -> Bool) -> Eq Refactor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Refactor -> Refactor -> Bool
$c/= :: Refactor -> Refactor -> Bool
== :: Refactor -> Refactor -> Bool
$c== :: Refactor -> Refactor -> Bool
Eq, Int -> Refactor -> ShowS
[Refactor] -> ShowS
Refactor -> String
(Int -> Refactor -> ShowS)
-> (Refactor -> String) -> ([Refactor] -> ShowS) -> Show Refactor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Refactor] -> ShowS
$cshowList :: [Refactor] -> ShowS
show :: Refactor -> String
$cshow :: Refactor -> String
showsPrec :: Int -> Refactor -> ShowS
$cshowsPrec :: Int -> Refactor -> ShowS
Show)

testAnnotations :: [Setting] -> FilePath -> Maybe FilePath -> Test ()
testAnnotations :: [Setting] -> String -> Maybe String -> Test ()
testAnnotations setting :: [Setting]
setting file :: String
file rpath :: Maybe String
rpath = 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 refact :: Refactor
refact 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 (f :: * -> *) a. Applicative f => a -> f a
pure [Idea]
res

            Bool -> Test () -> Test ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ("src/Hint" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
file) (Test () -> Test ()) -> Test () -> Test ()
forall a b. (a -> b) -> a -> b
$ ([Idea] -> Test ()) -> Either SomeException [Idea] -> Test ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Idea -> Test ()) -> [Idea] -> Test ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> Idea -> Test ()
addBuiltin String
inp)) Either SomeException [Idea]
ideas

            -- 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 (f :: * -> *) a. Applicative f => a -> f a
pure ()) [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
forall a. Outputable a => a -> String
unsafePrettyPrint 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 (f :: * -> *) a. Applicative f => a -> f a
pure (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
forall a. Outputable a => a -> String
unsafePrettyPrint 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
srcSpanStart 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]
                        -- TODO: shouldn't these checks be == -1 instead?

            -- Skip refactoring test if the hlint test failed, or if the
            -- test is annotated with @NoRefactor.
            let skipRefactor :: Bool
skipRefactor = [Test ()] -> Bool
forall a. [a] -> Bool
notNull [Test ()]
bad Bool -> Bool -> Bool
|| Refactor
refact Refactor -> Refactor -> Bool
forall a. Eq a => a -> a -> Bool
== Refactor
SkipRefactor
            [Test ()]
badRefactor <- if Bool
skipRefactor then [Test ()] -> Test [Test ()]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [] else IO [Test ()] -> Test [Test ()]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Test ()] -> Test [Test ()]) -> IO [Test ()] -> Test [Test ()]
forall a b. (a -> b) -> a -> b
$ do
                [String]
refactorErr <- case Either SomeException [Idea]
ideas of
                    Right [] -> Maybe String -> Maybe Idea -> String -> IO [String]
testRefactor Maybe String
rpath Maybe Idea
forall a. Maybe a
Nothing String
inp
                    Right [idea :: Idea
idea] -> Maybe String -> Maybe Idea -> String -> IO [String]
testRefactor Maybe String
rpath (Idea -> Maybe Idea
forall a. a -> Maybe a
Just Idea
idea) String
inp
                    -- Skip refactoring test if there are multiple hints
                    _ -> [String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                [Test ()] -> IO [Test ()]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Test ()] -> IO [Test ()]) -> [Test ()] -> IO [Test ()]
forall a b. (a -> b) -> a -> b
$ [[String] -> Test ()
failed ([String] -> Test ()) -> [String] -> Test ()
forall a b. (a -> b) -> a -> b
$
                           ["TEST FAILURE (BAD REFACTORING)"
                           ,"SRC: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SrcLoc -> String
forall a. Outputable a => a -> String
unsafePrettyPrint SrcLoc
loc
                           ,"INPUT: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
inp] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
refactorErr
                           | [String] -> Bool
forall a. [a] -> Bool
notNull [String]
refactorErr]

            if [Test ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Test ()]
bad Bool -> Bool -> Bool
&& [Test ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Test ()]
badRefactor then Test ()
passed else [Test ()] -> Test ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([Test ()]
bad [Test ()] -> [Test ()] -> [Test ()]
forall a. [a] -> [a] -> [a]
++ [Test ()]
badRefactor)

        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] -> Refactor -> [(Int, String)] -> [TestCase]
f Maybe [Setting]
forall a. Maybe a
Nothing Refactor
TestRefactor ([(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. Enum a => a -> [b] -> [(a, b)]
zipFrom 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 (String -> ShowS
forall a. Eq a => [a] -> [a] -> [a]
dropPrefix "# ") ([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] -> Refactor -> [(Int, String)] -> [TestCase]
        f :: Maybe [Setting] -> Refactor -> [(Int, String)] -> [TestCase]
f Nothing _ ((i :: Int
i,x :: String
x):xs :: [(Int, String)]
xs) = Maybe [Setting] -> Refactor -> [(Int, String)] -> [TestCase]
f (String -> Maybe [Setting]
open String
x) Refactor
TestRefactor [(Int, String)]
xs
        f (Just s :: [Setting]
s) refact :: Refactor
refact ((i :: Int
i,x :: String
x):xs :: [(Int, String)]
xs)
            | String -> Bool
shut String
x = Maybe [Setting] -> Refactor -> [(Int, String)] -> [TestCase]
f Maybe [Setting]
forall a. Maybe a
Nothing Refactor
TestRefactor [(Int, String)]
xs
            | Just (x' :: String
x',_) <- String -> String -> Maybe (String, String)
forall a. Eq a => [a] -> [a] -> Maybe ([a], [a])
stripInfix "@NoRefactor" String
x =
                Maybe [Setting] -> Refactor -> [(Int, String)] -> [TestCase]
f ([Setting] -> Maybe [Setting]
forall a. a -> Maybe a
Just [Setting]
s) Refactor
SkipRefactor ((Int
i, ShowS
trimEnd String
x' String -> ShowS
forall a. [a] -> [a] -> [a]
++ ['\\' | "\\" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
x]) (Int, String) -> [(Int, String)] -> [(Int, String)]
forall a. a -> [a] -> [a]
: [(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] -> Refactor -> [(Int, String)] -> [TestCase]
f ([Setting] -> Maybe [Setting]
forall a. a -> Maybe a
Just [Setting]
s) Refactor
refact [(Int, String)]
xs
            | Just x :: String
x <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix "\\" String
x, (_,y :: String
y):ys :: [(Int, String)]
ys <- [(Int, String)]
xs = Maybe [Setting] -> Refactor -> [(Int, String)] -> [TestCase]
f ([Setting] -> Maybe [Setting]
forall a. a -> Maybe a
Just [Setting]
s) Refactor
refact ([(Int, String)] -> [TestCase]) -> [(Int, String)] -> [TestCase]
forall a b. (a -> b) -> a -> b
$ (Int
i,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 = Refactor -> String -> Int -> String -> [Setting] -> TestCase
parseTest Refactor
refact String
file Int
i String
x [Setting]
s TestCase -> [TestCase] -> [TestCase]
forall a. a -> [a] -> [a]
: Maybe [Setting] -> Refactor -> [(Int, String)] -> [TestCase]
f ([Setting] -> Maybe [Setting]
forall a. a -> Maybe a
Just [Setting]
s) Refactor
TestRefactor [(Int, String)]
xs
        f _ _ [] = []


parseTest :: Refactor -> String -> Int -> String -> [Setting] -> TestCase
parseTest :: Refactor -> String -> Int -> String -> [Setting] -> TestCase
parseTest refact :: Refactor
refact 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
-> Refactor -> String -> Maybe String -> [Setting] -> TestCase
TestCase (FastString -> Int -> Int -> SrcLoc
mkSrcLoc (String -> FastString
mkFastString String
file) Int
i 0) Refactor
refact) ((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
$ ShowS
trimStart 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)


-- Returns an empty list if the refactoring test passes, otherwise
-- returns error messages.
testRefactor :: Maybe FilePath -> Maybe Idea -> String -> IO [String]
-- Skip refactoring test if the refactor binary is not found.
testRefactor :: Maybe String -> Maybe Idea -> String -> IO [String]
testRefactor Nothing _ _ = [String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
-- Skip refactoring test if the hint has no suggestion (i.e., a parse error).
testRefactor _ (Just idea :: Idea
idea) _ | Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing (Idea -> Maybe String
ideaTo Idea
idea) = [String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
testRefactor (Just rpath :: String
rpath) midea :: Maybe Idea
midea inp :: String
inp = (String -> IO [String]) -> IO [String]
forall a. (String -> IO a) -> IO a
withTempFile ((String -> IO [String]) -> IO [String])
-> (String -> IO [String]) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \tempInp :: String
tempInp -> (String -> IO [String]) -> IO [String]
forall a. (String -> IO a) -> IO a
withTempFile ((String -> IO [String]) -> IO [String])
-> (String -> IO [String]) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \tempHints :: String
tempHints -> do
    -- Note that we test the refactoring even if there are no suggestions,
    -- as an extra test of apply-refact, on which we rely.
    -- See https://github.com/ndmitchell/hlint/issues/958 for a discussion.
    let refacts :: [(String, [Refactoring SrcSpan])]
refacts = (Idea -> (String, [Refactoring SrcSpan]))
-> [Idea] -> [(String, [Refactoring SrcSpan])]
forall a b. (a -> b) -> [a] -> [b]
map (Idea -> String
forall a. Show a => a -> String
show (Idea -> String)
-> (Idea -> [Refactoring SrcSpan])
-> Idea
-> (String, [Refactoring SrcSpan])
forall a b c. (a -> b) -> (a -> c) -> a -> (b, c)
&&& Idea -> [Refactoring SrcSpan]
ideaRefactoring) (Maybe Idea -> [Idea]
forall a. Maybe a -> [a]
maybeToList Maybe Idea
midea)
        -- Ignores spaces and semicolons since apply-refact may change them.
        process :: ShowS
process = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (\c :: Char
c -> Bool -> Bool
not (Char -> Bool
isSpace Char
c) Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= ';')
        matched :: String -> (String -> String -> t) -> String -> t
matched expected :: String
expected g :: String -> String -> t
g actual :: String
actual = ShowS
process String
expected String -> String -> t
`g` ShowS
process String
actual
        x :: [a]
x isProperSubsequenceOf :: [a] -> [a] -> Bool
`isProperSubsequenceOf` y :: [a]
y = [a]
x [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
/= [a]
y Bool -> Bool -> Bool
&& [a]
x [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSubsequenceOf` [a]
y
    String -> String -> IO ()
writeFile String
tempInp String
inp
    String -> String -> IO ()
writeFile String
tempHints ([(String, [Refactoring SrcSpan])] -> String
forall a. Show a => a -> String
show [(String, [Refactoring SrcSpan])]
refacts)
    ExitCode
exitCode <- String
-> String
-> String
-> [Extension]
-> [Extension]
-> String
-> IO ExitCode
runRefactoring String
rpath String
tempInp String
tempHints [Extension]
defaultExtensions [] "--inplace"
    String
refactored <- String -> IO String
readFile String
tempInp
    [String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ case ExitCode
exitCode of
        ExitFailure ec :: Int
ec -> ["Refactoring failed: exit code " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ec]
        ExitSuccess -> case (Idea -> Maybe String) -> Maybe Idea -> Maybe (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Idea -> Maybe String
ideaTo Maybe Idea
midea of
            -- No hints. Refactoring should be a no-op.
            Nothing | Bool -> Bool
not (String -> (String -> String -> Bool) -> String -> Bool
forall t. String -> (String -> String -> t) -> String -> t
matched String
inp String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(==) String
refactored) ->
                ["Expected refactor output: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
inp, "Actual: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
refactored]
            -- The hint's suggested replacement is @Just ""@, which means the hint
            -- suggests removing something from the input. The refactoring output
            -- should be a proper subsequence of the input.
            Just (Just "") | Bool -> Bool
not (String -> (String -> String -> Bool) -> String -> Bool
forall t. String -> (String -> String -> t) -> String -> t
matched String
refactored String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isProperSubsequenceOf String
inp) ->
                ["Refactor output is expected to be a proper subsequence of: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
inp, "Actual: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
refactored]
            -- The hint has a suggested replacement. The suggested replacement
            -- should be a substring of the refactoring output.
            Just (Just to :: String
to) | Bool -> Bool
not (String -> (String -> String -> Bool) -> String -> Bool
forall t. String -> (String -> String -> t) -> String -> t
matched String
to String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInfixOf String
refactored) ->
                ["Refactor output is expected to contain: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
to, "Actual: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
refactored]
            _ -> []