content: {-# LANGUAGE ImportQualifiedPost #-}
  {-# LANGUAGE CPP, PatternGuards, RecordWildCards, ViewPatterns #-}
  
  -- | Check the <TEST> annotations within source and hint files.
  module Test.Annotations(testAnnotations, parseTestFile, TestCase(..)) 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 Data.ByteString.Char8 qualified as BS
  
  import Config.Type
  import Idea
  import Apply
  import Extension
  import Refact
  import Test.Util
  import Prelude
  import Config.Yaml
  import GHC.Data.FastString
  
  import GHC.Util
  import GHC.Types.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 (Show)
  
  data Refactor = TestRefactor | SkipRefactor deriving (Eq, Show)
  
  testAnnotations :: [Setting] -> FilePath -> Maybe FilePath -> Test ()
  testAnnotations setting file rpath = do
      tests <- liftIO $ parseTestFile file
      mapM_ f tests
      where
          f (TestCase loc refact inp out additionalSettings) = do
              ideas <- liftIO $ try_ $ do
                  res <- applyHintFile defaultParseFlags (setting ++ additionalSettings) file $ Just inp
                  evaluate $ length $ show res
                  pure res
  
              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: " ++ unsafePrettyPrint loc
                          ,"INPUT: " ++ inp] ++
                          map ("OUTPUT: " ++) (either (pure . show) (map show) ideas) ++
                          ["WANTED: " ++ fromMaybe "<failure>" out]
                          | not good] ++
                      [failed
                          ["TEST FAILURE (BAD LOCATION)"
                          ,"SRC: " ++ unsafePrettyPrint loc
                          ,"INPUT: " ++ inp
                          ,"OUTPUT: " ++ show i]
                          | i@Idea{..} <- fromRight [] ideas, let SrcLoc{..} = srcSpanStart ideaSpan, srcFilename == "" || srcLine == 0 || srcColumn == 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 = notNull bad || refact == SkipRefactor
              badRefactor <- if skipRefactor then pure [] else liftIO $ do
                  refactorErr <- case ideas of
                      Right [] -> testRefactor rpath Nothing inp
                      Right [idea] -> testRefactor rpath (Just idea) inp
                      -- Skip refactoring test if there are multiple hints
                      _ -> pure []
                  pure $ [failed $
                             ["TEST FAILURE (BAD REFACTORING)"
                             ,"SRC: " ++ unsafePrettyPrint loc
                             ,"INPUT: " ++ inp] ++ refactorErr
                             | notNull refactorErr]
  
              if null bad && null badRefactor then passed else sequence_ (bad ++ badRefactor)
  
          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
  
          -- FIXME: Should use a better check for expected results
          norm = filter $ \x -> not (isSpace x) && x /= ';'
  
  
  parseTestFile :: FilePath -> IO [TestCase]
  parseTestFile file =
      -- we remove all leading # symbols since Yaml only lets us do comments that way
      f Nothing TestRefactor . zipFrom 1 . map (dropPrefix "# ") . lines <$> readFile file
      where
          open :: String -> Maybe [Setting]
          open line
            |  "<TEST>" `isPrefixOf` line =
               let suffix = dropPrefix "<TEST>" line
                   config =
                     if isBuiltinYaml file
                       then mapRight getConfigYamlBuiltin $ decodeEither' $ BS.pack suffix
                       else mapRight getConfigYamlUser $ 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] -> Refactor -> [(Int, String)] -> [TestCase]
          f Nothing _ ((i,x):xs) = f (open x) TestRefactor xs
          f (Just s) refact ((i,x):xs)
              | shut x = f Nothing TestRefactor xs
              | Just (x',_) <- stripInfix "@NoRefactor" x =
                  f (Just s) SkipRefactor ((i, trimEnd x' ++ ['\\' | "\\" `isSuffixOf` x]) : xs)
              | null x || "-- " `isPrefixOf` x = f (Just s) refact xs
              | Just x <- stripSuffix "\\" x, (_,y):ys <- xs = f (Just s) refact $ (i,x++"\n"++y):ys
              | otherwise = parseTest refact file i x s : f (Just s) TestRefactor xs
          f _ _ [] = []
  
  
  parseTest :: Refactor -> String -> Int -> String -> [Setting] -> TestCase
  parseTest refact file i x = uncurry (TestCase (mkSrcLoc (mkFastString file) i 0) refact) $ f x
      where
          f x | Just x <- stripPrefix "<COMMENT>" x = first ("--"++) $ f x
          f (' ':'-':'-':xs) | null xs || " " `isPrefixOf` xs = ("", Just $ trimStart xs)
          f (x:xs) = first (x:) $ f xs
          f [] = ([], 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 Nothing _ _ = pure []
  -- Skip refactoring test if there is no hint.
  testRefactor _ Nothing _ = pure []
  -- Skip refactoring test if the hint has no suggestion (such as "Parse error" or "Avoid restricted function").
  testRefactor _ (Just idea) _ | isNothing (ideaTo idea) = pure []
  -- Skip refactoring test if the hint does not support refactoring.
  testRefactor _ (Just idea) _ | null (ideaRefactoring idea) = pure []
  testRefactor (Just rpath) (Just idea) inp = withTempFile $ \tempInp -> withTempFile $ \tempHints -> do
      let refact = (show idea, ideaRefactoring idea)
          -- Ignores spaces and semicolons since unsafePrettyPrint may differ from apply-refact.
          process = filter (\c -> not (isSpace c) && c /= ';')
          matched expected g actual = process expected `g` process actual
          x `isProperSubsequenceOf` y = x /= y && x `isSubsequenceOf` y
      writeFile tempInp inp
      writeFile tempHints (show [refact])
      exitCode <- runRefactoring rpath tempInp tempHints defaultExtensions [] "--inplace"
      refactored <- readFile tempInp
      pure $ case exitCode of
          ExitFailure ec -> ["Refactoring failed: exit code " ++ show ec]
          ExitSuccess -> case ideaTo idea of
              -- 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 "" | not (matched refactored isProperSubsequenceOf inp) ->
                  ["Refactor output is expected to be a proper subsequence of: " ++ inp, "Actual: " ++ refactored]
              -- The hint has a suggested replacement. The suggested replacement
              -- should be a substring of the refactoring output.
              Just to | not (matched to isInfixOf refactored) ->
                  ["Refactor output is expected to contain: " ++ to, "Actual: " ++ refactored]
              _ -> []
  