ghc-exactprint-0.5.6.0: tests/Test.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
-- | Use "runhaskell Setup.hs test" or "cabal test" to run these tests.
module Main where

-- import Language.Haskell.GHC.ExactPrint.Utils ( showGhc )

import Control.Monad
import System.Directory
import System.FilePath
import System.IO
import System.Exit

import Data.List
import qualified Data.Set as Set
import System.IO.Silently

import Test.Common
import Test.NoAnnotations
import Test.Transform

import Test.HUnit


-- import Debug.Trace

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

data GHCVersion = GHC710 | GHC80 | GHC82 | GHC84 deriving (Eq, Ord, Show)

ghcVersion :: GHCVersion
ghcVersion =
#if __GLASGOW_HASKELL__ > 802
  GHC84
#elif __GLASGOW_HASKELL__ > 800
  GHC82
#elif __GLASGOW_HASKELL__ >= 711
  GHC80
#else
  GHC710
#endif

-- | Directories to automatically find roundtrip tests
testDirs :: [FilePath]
testDirs =
  case ghcVersion of
    GHC710 -> ["ghc710-only","ghc710"]
    GHC80  -> ["ghc710", "ghc80"]
    GHC82  -> ["ghc710", "ghc80", "ghc82"]
    GHC84  -> ["ghc710", "ghc80", "ghc82", "ghc84" ]
    -- GHC84  -> ["ghc710", "ghc80", "ghc82", "ghc84", "ghc84-copied"]
    -- GHC84  -> ["ghc84-copied"]
    -- GHC84  -> ["ghc84"]

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

main :: IO ()
main = hSilence [stderr] $ do
  print ghcVersion
  tests <- mkTests
  cnts <- fst <$> runTestText (putTextToHandle stdout True) tests
  putStrLn $ show cnts
  if errors cnts > 0 || failures cnts > 0
     then exitFailure
     else return () -- exitSuccess

transform :: IO ()
transform = hSilence [stderr] $ do
  cnts <- fst <$> runTestText (putTextToHandle stdout True) transformTests
  putStrLn $ show cnts
  if errors cnts > 0 || failures cnts > 0
     then exitFailure
     else return () -- exitSuccess

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

findTests :: IO Test
findTests = testList "Round-trip tests" <$> mapM (findTestsDir id mkParserTest) testDirs

findPrettyTests :: IO Test
findPrettyTests =
  testList "Default Annotations round-trip tests"
           <$> mapM (findTestsDir filterPrettyRoundTrip mkPrettyRoundtrip) testDirs

-- | Filter out tests that are known to fail, for particular compilers
filterPrettyRoundTrip :: [FilePath] -> [FilePath]
filterPrettyRoundTrip fps = sort $ Set.toList $ Set.difference (Set.fromList fps) skipped
-- filterPrettyRoundTrip fps = error $ "filterPrettyRoundTrip:fps=" ++ show fps
  where
#if __GLASGOW_HASKELL__ > 800
  -- GHC 8.2
  skipped = Set.empty
#elif __GLASGOW_HASKELL__ >= 711
  -- GHC 8.0
  skipped = Set.fromList
    [
      -- testPrefix </> "ghc80" </> "MultiQuote.hs"
      "MultiQuote.hs"
    , "TestUtils.hs"
    , "T10689a.hs"
    , "Zwaluw.hs"
    , "determ004.hs"
    ]
#else
  -- GHC 7.10
  skipped = Set.empty
#endif

findTestsDir :: ([FilePath] -> [FilePath]) -> (FilePath -> FilePath -> Test) -> FilePath -> IO Test
findTestsDir filterFn mkTestFn dir = do
  let fp = testPrefix </> dir
  fs <- getDirectoryContents fp
  let testFiles = sort $ filter (".hs" `isSuffixOf`) fs
  return $ testList dir (map (\fn -> TestLabel fn (mkTestFn dir fn)) $ filterFn testFiles)

listTests :: IO ()
listTests = do
  let
    ftd dir = do
      let fp = testPrefix </> dir
      fs <- getDirectoryContents fp
      let testFiles = sort $ filter (".hs" `isSuffixOf`) fs
      return (zip [0::Integer ..] testFiles)
  files <- mapM ftd testDirs
  putStrLn $ "round trip tests:" ++ show (zip testDirs files)

mkTests :: IO Test
mkTests = do
  -- listTests
  roundTripTests <- findTests
  prettyRoundTripTests <- findPrettyTests
  return $ TestList [
                      internalTests,
                      roundTripTests
                    ,
                      transformTests
                    , failingTests
                    , noAnnotationTests
                    ,
                      prettyRoundTripTests
                    ]

-- Tests that will fail until https://phabricator.haskell.org/D907 lands in a
-- future GHC
failingTests :: Test
failingTests = testList "Failing tests"
  [
  -- Tests requiring future GHC modifications
    mkTestModBad "InfixOperator.hs"

#if __GLASGOW_HASKELL__ > 802
#elif __GLASGOW_HASKELL__ > 800
  , mkTestModBad "overloadedlabelsrun04.hs"
#elif __GLASGOW_HASKELL__ > 710
  , mkTestModBad "overloadedlabelsrun04.hs"
  , mkTestModBad "TensorTests.hs" -- Should be fixed in GHC 8.2
  , mkTestModBad "List2.hs"       -- Should be fixed in GHC 8.2
#else
  , mkTestModBad "CtorOp.hs" -- Should be fixed in GHC 8.4
  , mkTestModBad "UnicodeSyntax.hs"
  , mkTestModBad "UnicodeRules.hs"
  , mkTestModBad "Deprecation.hs"
  , mkTestModBad "MultiLineWarningPragma.hs"
#endif


  ]


mkParserTest :: FilePath -> FilePath -> Test
mkParserTest dir fp = mkParsingTest roundTripTest dir fp

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

formatTT :: ([([Char], Bool)], [([Char], Bool)]) -> IO ()
formatTT (ts, fs) = do
  when (not . null $ tail ts) (do
    putStrLn "Pass"
    mapM_ (putStrLn . fst) (tail ts)
    )
  when (not . null $ fs) (do
    putStrLn "Fail"
    mapM_ (putStrLn . fst) fs)

tr :: IO (Counts,Int)
tr = hSilence [stderr] $ do
  prettyRoundTripTests <- findPrettyTests
  runTestText (putTextToHandle stdout True) prettyRoundTripTests

tt' :: IO (Counts,Int)
tt' = runTestText (putTextToHandle stdout True) $ TestList [

      -- mkPrettyRoundtrip "ghc80" "Zwaluw.hs"
      -- mkPrettyRoundtrip "ghc80" "pmc007.hs"
      -- mkPrettyRoundtrip "ghc80" "MultiQuote.hs"
      -- mkPrettyRoundtrip "ghc80" "T10689a.hs"

      -- mkPrettyRoundtrip "ghc82" "TensorTests.hs"

   --    mkParserTest      "ghc84" "Main.hs"
      -- mkParserTest      "ghc84" "Types.hs"
    -- , mkPrettyRoundtrip "ghc80" "BundleExport.hs"
    -- , mkPrettyRoundtrip "ghc80" "ExportSyntax.hs"
    -- , mkPrettyRoundtrip "ghc80" "export-class.hs"
    -- , mkPrettyRoundtrip "ghc80" "export-syntax.hs"
    -- , mkPrettyRoundtrip "ghc80" "export-type.hs"

      -- mkPrettyRoundtrip "ghc84" "Main.hs"
      -- mkPrettyRoundtrip "ghc84" "Types.hs"

      mkPrettyRoundtrip "ghc80" "Vta1.hs"
    , mkPrettyRoundtrip "ghc80" "Vta2.hs"

      -- mkParserTest      "ghc80" "BundleExport.hs"

    -- , mkParserTest      "ghc710" "TypeOperators.hs"
    -- , mkParserTest      "ghc80" "TestUtils.hs"

     --   mkParserTest "ghc84" "Functors.hs"
     -- , mkParserTest "ghc80" "MonadT.hs"

      -- mkParserTest "ghc80" "SemicolonIf.hs"
      -- mkParserTest "ghc80" "T10689a.hs"
      -- mkParserTest "ghc80" "MonadT.hs"
      -- mkParserTest "ghc710" "Ann01.hs"

   -- Needs GHC changes
        -- mkParserTest "failing" "CtorOp.hs"
        -- mkParserTest "failing" "InfixOperator.hs"



    ]

testsTT :: Test
testsTT = TestList
  [
    mkParserTest "ghc710" "Cpp.hs"
  , mkParserTest "ghc710" "DroppedDoSpace.hs"
  ]

tt :: IO ()
-- tt = hSilence [stderr] $ do
tt = do
  cnts <- fst <$> runTestText (putTextToHandle stdout True) testsTT
  putStrLn $ show cnts
  if errors cnts > 0 || failures cnts > 0
     then exitFailure
     else return () -- exitSuccess

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

ii :: IO ()
ii = do
  cnts <- fst <$> runTestText (putTextToHandle stdout True) internalTests
  putStrLn $ show cnts
  if errors cnts > 0 || failures cnts > 0
     then exitFailure
     else return () -- exitSuccess

internalTests :: Test
internalTests = testList "Internal tests"
  [
    -- testCleanupOneLine
  ]

{-
testCleanupOneLine :: Test
testCleanupOneLine = do
  let
    makeCase n = (show n
                 ,(T.replicate n " ") <> "\t|" <> T.replicate n " " <> "\t"
                 ,(T.replicate 8 " " <> "|"))
    mkTest n = TestCase $ assertEqual name outp (cleanupOneLine inp)
      where (name,inp,outp) = makeCase n
  testList "cleanupOneLine" $ map mkTest [1..7]
-}

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

pwd :: IO FilePath
pwd = getCurrentDirectory

cd :: FilePath -> IO ()
cd = setCurrentDirectory