retrie-1.2.0.0: tests/Golden.hs

-- Copyright (c) Facebook, Inc. and its affiliates.
--
-- This source code is licensed under the MIT license found in the
-- LICENSE file in the root directory of this source tree.
--
{-# LANGUAGE RecordWildCards #-}
module Golden
  ( RetrieTest(..)
  , runQueryTest
  , runTest
  , displayAndAssertEqual
  , withTmpCopyOfInputs
  , listDir
  ) where

import Control.DeepSeq (force)
import Control.Exception (evaluate)
import Control.Monad
import qualified Control.Monad.Catch as MC
import Control.Monad.IO.Class
import Data.Bifunctor (second)
import Data.Char (isSpace)
import Data.List (intersperse)
import Options.Applicative
import Retrie
import Retrie.CPP
import Retrie.ExactPrint.Annotated
import Retrie.Options hiding (parseOptions)
import Retrie.Run
import System.Directory
import System.FilePath
import System.IO.Temp
import System.Process
import Test.HUnit

data RetrieTest a = RetrieTest
  { rtDir :: FilePath
  , rtName :: String
  , rtTest :: FilePath
  , rtVerbosity :: Verbosity
  , rtRetrie :: Options -> IO (Retrie a)
  }

parseOptions
  :: LibDir
  -> Parser ProtoOptions
  -> FilePath
  -> RetrieTest a
  -> IO Options
parseOptions libdir p dir RetrieTest{..} = do
  flags <- takeFlags <$> readFileNoComments (rtDir </> rtTest)
  case runParserOnString p flags of
    Nothing   ->
      fail $ unwords [rtName, " options did not parse: ", flags]
    Just opts -> do
      resolveOptions libdir opts { targetDir = dir, verbosity = rtVerbosity }

runParserOnString :: Parser a -> String -> Maybe a
runParserOnString p args = getParseResult $
  execParserPure (prefs mempty) (info p fullDesc) (quotedWords args)
  where
    recurse (w,s) = w : quotedWords s
    -- Mimic shell's ability to group tokens with double quotes.
    quotedWords s =
      case dropWhile isSpace s of
        "" -> []
        ('"':cs) -> recurse . second tail $ break (=='"') cs
        s' -> recurse $ break isSpace s'

runTestWrapper
  :: LibDir
  -> Parser ProtoOptions
  -> RetrieTest a
  -> (Options -> IO b)
  -> IO b
runTestWrapper libdir p t@RetrieTest{..} f =
  withTmpCopyOfInputs KeepDir rtDir $ \dir -> do
    -- Make the Rewrites from the temp file, to get correct SrcSpan's
    opts <- parseOptions libdir p dir t
    f opts { targetFiles = [dir </> replaceExtension rtTest ".hs"] }

runQueryTest
  :: Monoid a
  => LibDir
  -> Parser ProtoOptions
  -> RetrieTest a
  -> IO a
runQueryTest libdir p t@RetrieTest{..} =
  runTestWrapper libdir p t $ \opts -> do
    let writeFn _fp _locs _cpp _res = return
    retrie <- rtRetrie opts
    -- A 'writeFn' is only executed if the module changes, so add empty imports
    -- to trip the Changed flag.
    fmap mconcat $ run libdir writeFn id opts $ do
      r <- retrie
      addImports mempty
      return r

runTest :: LibDir -> Parser ProtoOptions -> RetrieTest () -> IO ()
runTest libdir p t@RetrieTest{..} =
  runTestWrapper libdir p t $ \opts@Options{..} -> do
    let
      writeFn fp _locs res _ _ = writeFile fp res
      [tmpFile] = targetFiles
    before <- evaluate . force =<< readFile tmpFile
    retrie <- rtRetrie opts
    -- void $ run libdir writeFn id opts $ iterateR iterateN retrie
    void $ run libdir writeFileDumpAst id opts $ iterateR iterateN retrie
    res <- readFile tmpFile
    expected <- readFile $ targetDir </> replaceExtension rtTest ".expected"
    displayAndAssertEqual before expected res

writeFileDumpAst :: FilePath -> WriteFn a ()
writeFileDumpAst fp _locs res cpp _ = do
  case cpp of
    NoCPP m -> do
      let outname = fp <.> "out"
      writeFile outname res
      appendFile outname "\n===============================================\n"
      appendFile outname (showAstA m)
    _ -> return ()
  writeFile fp res


displayAndAssertEqual :: String -> String -> String -> IO ()
displayAndAssertEqual before expected res
  | expected == res = return ()
  | otherwise = do
      let bars = replicate 60 '='
      d <- diff expected res
      putStrLn $ unlines $ intersperse bars
        [ ""
        , "Original:", before
        , "Expected:", expected
        , "Got:", res
        , "Diff:", d
        , ""
        ]
      assertFailure "file contents differ"

diff :: String -> String -> IO String
diff s1 s2 = withSystemTempDirectory "diff" $ \dir -> do
  let
    aFile = dir </> "a.txt"
    bFile = dir </> "b.txt"
  writeFile aFile s1
  writeFile bFile s2
  (_ec, so, _) <- readProcessWithExitCode "diff" [aFile, bFile] ""
  return so

data KeepDir = KeepDir | DeleteDir deriving Eq

-- Copies input dir, mapping *.test to *.hs,
-- and provides a filepath to the root
-- of the copy. Deletes the copy when done.
withTmpCopyOfInputs :: KeepDir -> FilePath -> (FilePath -> IO a) -> IO a
withTmpCopyOfInputs keep inputsDir comp = do
  fs <- listDir inputsDir
  withSystemTempDirectory' keep "inputs" $ \dir -> do
    forM_ fs $ \f -> do
      if takeExtension f `elem` [".test", ".custom"]
        then splitAndCopyTest inputsDir f dir
        else copyFile (inputsDir </> f) (dir </> f)
    comp dir

withSystemTempDirectory' :: (MonadIO m, MC.MonadMask m)
                        => KeepDir -- ^ Keep the contents when done
                        -> String   -- ^ Directory name template
                        -> (FilePath -> m a) -- ^ Callback that can use the directory
                        -> m a
withSystemTempDirectory' keep template act
  = case keep of
      DeleteDir -> withSystemTempDirectory template act
      KeepDir -> do
        tmpDir <- liftIO getCanonicalTemporaryDirectory
        dir <- liftIO $ createTempDirectory tmpDir template
        act dir


splitAndCopyTest :: FilePath -> FilePath -> FilePath -> IO ()
splitAndCopyTest inputsDir testFile dstDir = do
  (hs, expected) <- splitTest <$> readFileNoComments (inputsDir </> testFile)
  writeFile (dstDir </> replaceExtension testFile ".hs") hs
  writeFile (dstDir </> replaceExtension testFile ".expected") expected

splitTest :: String -> (String, String)
splitTest = go ([],[]) . takeWhile (/="===") . reverse . lines
  where
    go (hs,ex) [] = (unlines hs, unlines ex)
    go (hs,ex) ([]:ls) = go ([]:hs,[]:ex) ls
    go (hs,ex) ((' ':ln):ls) = go (ln:hs,ln:ex) ls
    go (hs,ex) (('-':ln):ls) = go (ln:hs,ex) ls
    go (hs,ex) (('+':ln):ls) = go (hs,ln:ex) ls
    go _ (ln:_) = error $
      "Malformed test file. " ++
      "Each line must start with a space, +, -, #, or be empty.\n" ++ ln

takeFlags :: String -> String
takeFlags = unwords . takeWhile (/="===") . lines

readFileNoComments :: FilePath -> IO String
readFileNoComments path =
  unlines . filter notComment . lines <$> readFile path
  where
    notComment ('#':_) = False
    notComment _ = True

-- This is 'listDirectory' in 'directory >= 1.2.5.0'
listDir :: FilePath -> IO [FilePath]
listDir path =
  filter f <$> getDirectoryContents path
  where f filename = filename /= "." && filename /= ".."