ghc-exactprint-0.6.3: tests/Roundtrip.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where

import Control.Exception
import Control.Monad
import Data.Time.Clock
import Data.Time.Format
import Debug.Trace
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.IO
-- import System.IO.Temp
import Test.Common
import Test.CommonUtils
import Test.HUnit
import qualified Data.Set as S

-- ---------------------------------------------------------------------

data Verbosity = Debug | Status | None deriving (Eq, Show, Ord, Enum)

verb :: Verbosity
verb = Debug

-- ---------------------------------------------------------------------

writeCPP :: FilePath -> IO ()
writeCPP fp = appendFileFlush cppFile (('\n' : fp))

writeError :: FilePath -> IO ()
writeError = writeCPP

writeParseFail :: FilePath -> String -> IO ()
writeParseFail fp _s = appendFileFlush parseFailFile (('\n' : fp))
-- writeParseFail fp s = appendFileFlush parseFailFile (('\n' : (fp ++ " " ++ s)))

writeProcessed :: FilePath -> IO ()
writeProcessed fp = appendFileFlush processed (('\n' : fp))

writeFailed :: FilePath -> IO ()
writeFailed fp = appendFileFlush processedFailFile (('\n' : fp))

writeLog :: String -> IO ()
writeLog msg = appendFileFlush logFile (('\n' : msg))

getTimeStamp :: IO String
getTimeStamp = do
  t <- getCurrentTime
  return $ formatTime defaultTimeLocale (iso8601DateFormat (Just "%H%M%S")) t

writeFailure :: FilePath -> String -> IO ()
writeFailure fp db = do
  ts <- getTimeStamp
  let outname = failuresDir </> takeFileName fp <.> ts <.> "out"
  writeFile outname db

appendFileFlush      :: FilePath -> String -> IO ()
appendFileFlush f txt = withFile f AppendMode (\ hdl -> hPutStr hdl txt >> hFlush hdl)

-- ---------------------------------------------------------------------

readFileIfPresent :: FilePath -> IO [String]
readFileIfPresent fileName = do
  isPresent <- doesFileExist fileName
  if isPresent
    then lines <$> readFile fileName
    else return []

-- ---------------------------------------------------------------------

main :: IO ()
main = do
  createDirectoryIfMissing True workDir
  createDirectoryIfMissing True configDir
  createDirectoryIfMissing True failuresDir
  as <- getArgs
  case as of
    [] -> putStrLn "Must enter directory to process"
    ["failures"] -> do
      fs <- lines <$> readFile origFailuresFile
      () <$ runTests (TestList (map mkParserTest fs))
    ["clean"] -> do
      putStrLn "Cleaning..."
      writeFile processed ""
      writeFile parseFailFile ""
      writeFile cppFile ""
      writeFile logFile ""
      writeFile processedFailFile ""
      removeDirectoryRecursive failuresDir
      createDirectory failuresDir
      putStrLn "Done."
    -- ds -> () <$ (runTests =<< (TestList <$> mapM tests ds))
    ds -> do
      !blackList     <- readFileIfPresent blackListed
      !knownFailures <- readFileIfPresent knownFailuresFile
      !processedList <- lines <$> readFile processed
      !cppList       <- lines <$> readFile cppFile
      !parseFailList <- lines <$> readFile parseFailFile
      let done = S.fromList (processedList ++ cppList ++ blackList ++ knownFailures ++ parseFailList)
      tsts <- TestList <$> mapM (tests done) ds
      _ <- runTests tsts
      return ()

runTests :: Test -> IO Counts
runTests t = do
  let n = testCaseCount t
  putStrLn $ "Running " ++ show n ++ " tests."
  putStrLn $ "Verbosity: " ++ show verb
  runTestTT t

tests :: S.Set String ->  FilePath -> IO Test
tests done dir = do
  roundTripHackage done dir

-- Selection:

-- Hackage dir
roundTripHackage :: S.Set String -> FilePath -> IO Test
roundTripHackage done hackageDir = do
  packageDirs <- drop 2 <$> getDirectoryContents hackageDir
  when (verb <= Debug) (traceShowM hackageDir)
  when (verb <= Debug) (traceShowM packageDirs)
  TestList <$> mapM (roundTripPackage done) (zip [0..] (map (hackageDir </>) packageDirs))


roundTripPackage :: S.Set String -> (Int, FilePath) -> IO Test
roundTripPackage done (n, dir) = do
  putStrLn (show n)
  when (verb <= Status) (traceM dir)
  hsFiles <- filter (flip S.notMember done)  <$> findSrcFiles dir

  return (TestLabel (dropFileName dir) (TestList $ map mkParserTest hsFiles))

mkParserTest :: FilePath -> Test
mkParserTest fp =
    TestLabel fp $
    TestCase (do writeLog $ "starting:" ++ fp
                 r1 <- catchAny (roundTripTest fp) $ \e -> do
                   writeError fp
                   throwIO e
                 case r1 of
                   Left (ParseFailure s) -> do
                     writeParseFail fp s
                     exitFailure
                   Right r -> do
                     writeProcessed fp
                     unless (status r == Success) (writeFailure fp (debugTxt r) >> writeFailed fp)
                     assertBool fp (status r == Success))

catchAny :: IO a -> (SomeException -> IO a) -> IO a
catchAny = Control.Exception.catch