{-# LANGUAGE CPP #-} {-# 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 , mkParsingTest , getModSummaryForFile , testList , testPrefix , Changer , genTest , noChange , mkDebugOutput #if __GLASGOW_HASKELL__ > 808 , showErrorMessages #endif ) where import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Utils import Language.Haskell.GHC.ExactPrint.Parsers (parseModuleApiAnnsWithCpp) import Language.Haskell.GHC.ExactPrint.Preprocess import Language.Haskell.GHC.ExactPrint.Types #if __GLASGOW_HASKELL__ >= 900 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.Utils.Outputable as GHC #else import qualified ApiAnnotation as GHC import qualified DynFlags as GHC #if __GLASGOW_HASKELL__ > 808 import qualified Bag as GHC import qualified ErrUtils as GHC #endif import qualified GHC as GHC hiding (parseModule) import qualified MonadUtils as GHC #endif #if __GLASGOW_HASKELL__ <= 710 #else import qualified GHC.LanguageExtensions as LangExt #endif -- import qualified Data.Map as Map import Control.Monad import Data.List hiding (find) import System.Directory import Test.Consistency import Test.HUnit import System.FilePath -- import Debug.Trace 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) {- runParser :: GHC.P a -> GHC.DynFlags -> FilePath -> String -> GHC.ParseResult a runParser parser flags filename str = GHC.unP parser parseState where location = GHC.mkRealSrcLoc (GHC.mkFastString filename) 1 1 buffer = GHC.stringToStringBuffer str parseState = GHC.mkPState flags buffer location parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located (GHC.HsModule GhcPs)) parseFile = runParser GHC.parseModule mkApiAnns :: GHC.PState -> GHC.ApiAnns mkApiAnns pstate = (Map.fromListWith (++) . GHC.annotations $ pstate , Map.fromList ((GHC.noSrcSpan, GHC.comment_q pstate) : (GHC.annotations_comments pstate))) removeSpaces :: String -> String removeSpaces = map (\case {'\160' -> ' '; s -> s}) -} roundTripTest :: FilePath -> IO Report roundTripTest f = genTest noChange 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 = (Anns -> GHC.ParsedSource -> IO (Anns,GHC.ParsedSource)) noChange :: Changer noChange ans parsed = return (ans,parsed) genTest :: Changer -> FilePath -> FilePath -> IO Report genTest f origFile expectedFile = do res <- parseModuleApiAnnsWithCpp defaultCppOptions origFile expected <- GHC.liftIO $ readFileGhc expectedFile orig <- GHC.liftIO $ readFileGhc origFile -- let pristine = removeSpaces expected let pristine = expected case res of #if __GLASGOW_HASKELL__ > 808 Left m -> return . Left $ ParseFailure (showErrorMessages m) #else Left (_ss, m) -> return . Left $ ParseFailure m #endif Right (apianns, injectedComments, dflags, pmod) -> do (printed', anns, pmod') <- GHC.liftIO (runRoundTrip f apianns pmod injectedComments) #if __GLASGOW_HASKELL__ <= 710 let useCpp = GHC.xopt GHC.Opt_Cpp dflags #else let useCpp = GHC.xopt LangExt.Cpp dflags #endif printed = trimPrinted printed' -- let (printed, anns) = first trimPrinted $ runRoundTrip apianns pmod injectedComments -- 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 apianns anns 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.ApiAnns -> Anns -> GHC.ParsedSource -> String mkDebugOutput filename printed original apianns anns parsed = intercalate sep [ printed , filename , "lengths:" ++ show (length printed,length original) ++ "\n" , showAnnData anns 0 parsed , showGhc anns , showGhc apianns ] where sep = "\n==============\n" runRoundTrip :: Changer #if __GLASGOW_HASKELL__ >= 900 -> GHC.ApiAnns -> GHC.Located GHC.HsModule #else -> GHC.ApiAnns -> GHC.Located (GHC.HsModule GhcPs) #endif -> [Comment] -> IO (String, Anns, GHC.ParsedSource) runRoundTrip f !anns !parsedOrig cs = do let !relAnns = relativiseApiAnnsWithComments cs parsedOrig anns (annsMod, pmod) <- f relAnns parsedOrig let !printed = exactPrint pmod annsMod -- return (printed, relAnns, pmod) return (printed, annsMod, 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 #if __GLASGOW_HASKELL__ >= 804 cgraph <- GHC.liftIO $ canonicalizeGraph (GHC.mgModSummaries graph) #else cgraph <- GHC.liftIO $ canonicalizeGraph graph #endif let mm = filter (\(mfn,_ms) -> mfn == Just cfileName) cgraph case mm of [] -> return Nothing fs -> return (Just (snd $ head fs)) -- --------------------------------------------------------------------- #if __GLASGOW_HASKELL__ > 808 showErrorMessages :: GHC.ErrorMessages -> String showErrorMessages m = show $ GHC.bagToList m #endif -- --------------------------------------------------------------------- #if __GLASGOW_HASKELL__ >= 900 instance GHC.Outputable GHC.ApiAnns where ppr (GHC.ApiAnns items eof comments rogueComments) = GHC.text "ApiAnns" GHC.<+> GHC.ppr items GHC.<+> GHC.ppr eof GHC.<+> GHC.ppr comments GHC.<+> GHC.ppr rogueComments #endif -- ---------------------------------------------------------------------