{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Test.Common (
RoundtripReport (..)
, Report
, ParseFailure(..)
, ReportType(..)
, roundTripTest
, roundTripTestBC
, roundTripTestMD
, mkParsingTest
, getModSummaryForFile
, testList
, testPrefix
, Changer
, genTest
, noChange
, changeMakeDelta
, mkDebugOutput
, showErrorMessages
, LibDir
) where
import Language.Haskell.GHC.ExactPrint
import Language.Haskell.GHC.ExactPrint.ExactPrint
import Language.Haskell.GHC.ExactPrint.Utils
import Language.Haskell.GHC.ExactPrint.Parsers
import Language.Haskell.GHC.ExactPrint.Preprocess
import qualified Control.Monad.IO.Class as GHC
import qualified GHC as GHC hiding (parseModule)
import qualified GHC.Data.Bag as GHC
import qualified GHC.Driver.Session as GHC
import qualified GHC.Utils.Error as GHC
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Data.List hiding (find)
import System.Directory
import Test.HUnit
import System.FilePath
testPrefix :: FilePath
testPrefix = "." </> "tests" </> "examples"
testList :: String -> [Test] -> Test
testList s ts = TestLabel s (TestList ts)
-- ---------------------------------------------------------------------
-- Roundtrip machinery
type Report = Either ParseFailure RoundtripReport
data RoundtripReport =
Report
{ debugTxt :: String
, status :: ReportType
, cppStatus :: Maybe String -- Result of CPP if invoked
-- , inconsistent :: Maybe [(AnnSpan, (GHC.AnnKeywordId, [AnnSpan]))]
}
data ParseFailure = ParseFailure String
data ReportType =
Success
| RoundTripFailure deriving (Eq, Show)
roundTripTest :: LibDir -> FilePath -> IO Report
roundTripTest libdir f = genTest libdir noChange f f
roundTripTestBC :: LibDir -> FilePath -> IO Report
roundTripTestBC libdir f = genTest libdir changeBalanceComments f f
roundTripTestMD :: LibDir -> FilePath -> IO Report
roundTripTestMD libdir f = genTest libdir changeMakeDelta f f
mkParsingTest :: (FilePath -> IO Report) -> FilePath -> FilePath -> Test
mkParsingTest tester dir fp =
let basename = testPrefix </> dir </> fp
writeFailure = writeFile (basename <.> "out")
writeHsPP = writeFile (basename <.> "hspp")
-- writeIncons s = writeFile (basename <.> "incons") (showGhc s)
in
TestCase (do r <- either (\(ParseFailure s) -> error (s ++ basename)) id
<$> tester basename
writeFailure (debugTxt r)
-- forM_ (inconsistent r) writeIncons
forM_ (cppStatus r) writeHsPP
assertBool fp (status r == Success))
type Changer = LibDir -> (GHC.ParsedSource -> IO GHC.ParsedSource)
noChange :: Changer
noChange _libdir parsed = return parsed
changeBalanceComments :: Changer
changeBalanceComments _libdir (GHC.L l p) = do
let decls0 = GHC.hsmodDecls p
(decls,_,w) = runTransform (balanceCommentsList decls0)
let p2 = p { GHC.hsmodDecls = decls}
debugM $ "changeBalanceComments:\n" ++ unlines w
return (GHC.L l p2)
changeMakeDelta :: Changer
changeMakeDelta _libdir m = do
return (makeDeltaAst m)
genTest :: LibDir -> Changer -> FilePath -> FilePath -> IO Report
genTest libdir f origFile expectedFile = do
res <- parseModuleEpAnnsWithCpp libdir defaultCppOptions origFile
expected <- GHC.liftIO $ readFileGhc expectedFile
orig <- GHC.liftIO $ readFileGhc origFile
-- let pristine = removeSpaces expected
let pristine = expected
case res of
Left m -> return . Left $ ParseFailure (showErrorMessages m)
Right (injectedComments, dflags, pmod) -> do
(printed', pmod') <- GHC.liftIO (runRoundTrip libdir f pmod injectedComments)
let useCpp = GHC.xopt LangExt.Cpp dflags
printed = trimPrinted printed'
-- Clang cpp adds an extra newline character
-- Do not remove this line!
trimPrinted p = if useCpp
then unlines $ take (length (lines pristine)) (lines p)
else p
debugTxt = mkDebugOutput origFile printed pristine pmod'
-- consistency = checkConsistency apianns pmod
-- inconsistent = if null consistency then Nothing else Just consistency
status = if printed == pristine then Success else RoundTripFailure
cppStatus = if useCpp then Just orig else Nothing
return $ Right Report {..}
mkDebugOutput :: FilePath -> String -> String
-> GHC.ParsedSource -> String
mkDebugOutput filename printed original parsed =
intercalate sep [ printed
, filename
, "lengths:" ++ show (length printed,length original) ++ "\n"
-- , showAnnData anns 0 parsed
, showAst parsed
-- , showGhc anns
]
where
sep = "\n==============\n"
runRoundTrip :: LibDir
-> Changer
-> GHC.Located GHC.HsModule
-> [GHC.LEpaComment]
-> IO (String, GHC.ParsedSource)
runRoundTrip libdir f !parsedOrig cs = do
let !parsedOrigWithComments = insertCppComments parsedOrig cs
pmod <- f libdir parsedOrigWithComments
let !printed = exactPrint pmod
return (printed, pmod)
-- ---------------------------------------------------------------------`
canonicalizeGraph ::
[GHC.ModSummary] -> IO [(Maybe (FilePath), GHC.ModSummary)]
canonicalizeGraph graph = do
let mm = map (\m -> (GHC.ml_hs_file $ GHC.ms_location m, m)) graph
canon ((Just fp),m) = do
fp' <- canonicalizePath fp
return $ (Just fp',m)
canon (Nothing,m) = return (Nothing,m)
mm' <- mapM canon mm
return mm'
-- ---------------------------------------------------------------------
getModSummaryForFile :: (GHC.GhcMonad m) => FilePath -> m (Maybe GHC.ModSummary)
getModSummaryForFile fileName = do
cfileName <- GHC.liftIO $ canonicalizePath fileName
graph <- GHC.getModuleGraph
cgraph <- GHC.liftIO $ canonicalizeGraph (GHC.mgModSummaries graph)
let mm = filter (\(mfn,_ms) -> mfn == Just cfileName) cgraph
case mm of
[] -> return Nothing
fs -> return (Just (snd $ head fs))
-- ---------------------------------------------------------------------
showErrorMessages :: GHC.ErrorMessages -> String
showErrorMessages m = show $ GHC.bagToList m
-- ---------------------------------------------------------------------