Merge remote-tracking branch 'mrhania/testing-framework-improvements' into ghc-head

4 files changed, 474 insertions, 0 deletions

diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
new file mode 100644
index 00000000..8f1f4885
--- /dev/null
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -0,0 +1,282 @@
+{-# LANGUAGE RecordWildCards #-}
+
+
+module Test.Haddock.Config
+    ( TestPackage(..), CheckConfig(..), DirConfig(..), Config(..)
+    , defaultDirConfig
+    , cfgSrcDir, cfgRefDir, cfgOutDir, cfgResDir
+    , parseArgs, checkOpt, loadConfig
+    ) where
+
+
+import Control.Applicative
+import Control.Monad
+
+import qualified Data.List as List
+import Data.Maybe
+
+import Distribution.InstalledPackageInfo
+import Distribution.Package
+import Distribution.Simple.Compiler hiding (Flag)
+import Distribution.Simple.GHC
+import Distribution.Simple.PackageIndex
+import Distribution.Simple.Program
+import Distribution.Simple.Utils
+import Distribution.Verbosity
+
+import System.Console.GetOpt
+import System.Directory
+import System.Exit
+import System.Environment
+import System.FilePath
+import System.IO
+
+import Test.Haddock.Process
+import Test.Haddock.Utils
+
+
+data TestPackage = TestPackage
+    { tpkgName :: String
+    , tpkgFiles :: [FilePath]
+    }
+
+
+data CheckConfig c = CheckConfig
+    { ccfgRead :: String -> String -> Maybe c
+    , ccfgDump :: c -> String
+    , ccfgEqual :: c -> c -> Bool
+    }
+
+
+data DirConfig = DirConfig
+    { dcfgSrcDir :: FilePath
+    , dcfgRefDir :: FilePath
+    , dcfgOutDir :: FilePath
+    , dcfgResDir :: FilePath
+    , dcfgCheckIgnore :: FilePath -> Bool
+    }
+
+
+defaultDirConfig :: FilePath -> DirConfig
+defaultDirConfig baseDir = DirConfig
+    { dcfgSrcDir = baseDir </> "src"
+    , dcfgRefDir = baseDir </> "ref"
+    , dcfgOutDir = baseDir </> "out"
+    , dcfgResDir = rootDir </> "resources"
+    , dcfgCheckIgnore = const False
+    }
+  where
+    rootDir = baseDir </> ".."
+
+
+data Config c = Config
+    { cfgHaddockPath :: FilePath
+    , cfgPackages :: [TestPackage]
+    , cfgHaddockArgs :: [String]
+    , cfgHaddockStdOut :: FilePath
+    , cfgDiffTool :: Maybe FilePath
+    , cfgEnv :: Environment
+    , cfgAccept :: Bool
+    , cfgCheckConfig :: CheckConfig c
+    , cfgDirConfig :: DirConfig
+    }
+
+
+cfgSrcDir, cfgRefDir, cfgOutDir, cfgResDir :: Config c -> FilePath
+cfgSrcDir = dcfgSrcDir . cfgDirConfig
+cfgRefDir = dcfgRefDir . cfgDirConfig
+cfgOutDir = dcfgOutDir . cfgDirConfig
+cfgResDir = dcfgResDir . cfgDirConfig
+
+
+
+data Flag
+    = FlagHaddockPath FilePath
+    | FlagHaddockOptions String
+    | FlagHaddockStdOut FilePath
+    | FlagDiffTool FilePath
+    | FlagNoDiff
+    | FlagAccept
+    | FlagHelp
+    deriving Eq
+
+
+flagsHaddockPath :: [Flag] -> Maybe FilePath
+flagsHaddockPath flags = mlast [ path | FlagHaddockPath path <- flags ]
+
+
+flagsHaddockOptions :: [Flag] -> [String]
+flagsHaddockOptions flags = concat
+    [ words opts | FlagHaddockOptions opts <- flags ]
+
+
+flagsHaddockStdOut :: [Flag] -> Maybe FilePath
+flagsHaddockStdOut flags = mlast [ path | FlagHaddockStdOut path <- flags ]
+
+
+flagsDiffTool :: [Flag] -> Maybe FilePath
+flagsDiffTool flags = mlast [ path | FlagDiffTool path <- flags ]
+
+
+options :: [OptDescr Flag]
+options =
+    [ Option [] ["haddock-path"] (ReqArg FlagHaddockPath "FILE")
+        "path to Haddock executable to exectue tests with"
+    , Option [] ["haddock-options"] (ReqArg FlagHaddockOptions "OPTS")
+        "additional options to run Haddock with"
+    , Option [] ["haddock-stdout"] (ReqArg FlagHaddockStdOut "FILE")
+        "where to redirect Haddock output"
+    , Option [] ["diff-tool"] (ReqArg FlagDiffTool "PATH")
+        "diff tool to use when printing failed cases"
+    , Option ['a'] ["accept"] (NoArg FlagAccept)
+        "accept generated output"
+    , Option [] ["no-diff"] (NoArg FlagNoDiff)
+        "do not print diff for failed cases"
+    , Option ['h'] ["help"] (NoArg FlagHelp)
+        "display this help end exit"
+    ]
+
+
+parseArgs :: CheckConfig c -> DirConfig -> [String] -> IO (Config c)
+parseArgs ccfg dcfg args = uncurry (loadConfig ccfg dcfg) =<< checkOpt args
+
+
+checkOpt :: [String] -> IO ([Flag], [String])
+checkOpt args = do
+    let (flags, files, errors) = getOpt Permute options args
+
+    unless (null errors) $ do
+        hPutStr stderr $ concat errors
+        exitFailure
+
+    when (FlagHelp `elem` flags) $ do
+        hPutStrLn stderr $ usageInfo "" options
+        exitSuccess
+
+    return (flags, files)
+
+
+loadConfig :: CheckConfig c -> DirConfig -> [Flag] -> [String] -> IO (Config c)
+loadConfig ccfg dcfg flags files = do
+    cfgEnv <- (:) ("haddock_datadir", dcfgResDir dcfg) <$> getEnvironment
+
+    systemHaddockPath <- List.lookup "HADDOCK_PATH" <$> getEnvironment
+    cfgHaddockPath <- case flagsHaddockPath flags <|> systemHaddockPath of
+        Just path -> pure path
+        Nothing -> do
+            hPutStrLn stderr $ "Haddock executable not specified"
+            exitFailure
+
+    ghcPath <- init <$> rawSystemStdout normal cfgHaddockPath
+        ["--print-ghc-path"]
+
+    printVersions cfgEnv cfgHaddockPath
+
+    cfgPackages <- processFileArgs dcfg files
+
+    cfgHaddockArgs <- liftM concat . sequence $
+        [ pure ["--no-warnings"]
+        , pure ["--odir=" ++ dcfgOutDir dcfg]
+        , pure ["--optghc=-w"]
+        , pure $ flagsHaddockOptions flags
+        , baseDependencies ghcPath
+        ]
+
+    let cfgHaddockStdOut = fromMaybe "/dev/null" (flagsHaddockStdOut flags)
+
+    cfgDiffTool <- if FlagNoDiff `elem` flags
+        then pure Nothing
+        else (<|>) <$> pure (flagsDiffTool flags) <*> defaultDiffTool
+
+    let cfgAccept = FlagAccept `elem` flags
+
+    let cfgCheckConfig = ccfg
+    let cfgDirConfig = dcfg
+
+    return $ Config { .. }
+
+
+printVersions :: Environment -> FilePath -> IO ()
+printVersions env haddockPath = do
+    handleHaddock <- runProcess' haddockPath $ processConfig
+        { pcEnv = Just env
+        , pcArgs = ["--version"]
+        }
+    waitForSuccess "Failed to run `haddock --version`" handleHaddock
+
+    handleGhc <- runProcess' haddockPath $ processConfig
+        { pcEnv = Just env
+        , pcArgs = ["--ghc-version"]
+        }
+    waitForSuccess "Failed to run `haddock --ghc-version`" handleGhc
+
+
+baseDependencies :: FilePath -> IO [String]
+baseDependencies ghcPath = do
+    -- The 'getInstalledPackages' crashes if used when "GHC_PACKAGE_PATH" is
+    -- set to some value. I am not sure why is that happening and what are the
+    -- consequences of unsetting it - but looks like it works (for now).
+    unsetEnv "GHC_PACKAGE_PATH"
+
+    (_, _, cfg) <- configure normal (Just ghcPath) Nothing
+        defaultProgramConfiguration
+    pkgIndex <- getInstalledPackages normal [GlobalPackageDB] cfg
+    mapM (getDependency pkgIndex) ["base", "process", "ghc-prim"]
+  where
+    getDependency pkgIndex name = case ifaces pkgIndex name of
+        [] -> do
+            hPutStrLn stderr $ "Couldn't find base test dependency: " ++ name
+            exitFailure
+        (ifArg:_) -> pure ifArg
+    ifaces pkgIndex name = do
+        pkg <- join $ snd <$> lookupPackageName pkgIndex (PackageName name)
+        iface <$> haddockInterfaces pkg <*> haddockHTMLs pkg
+    iface file html = "--read-interface=" ++ html ++ "," ++ file
+
+
+defaultDiffTool :: IO (Maybe FilePath)
+defaultDiffTool =
+    liftM listToMaybe . filterM isAvailable $ ["colordiff", "diff"]
+  where
+    isAvailable = liftM isJust . findProgramLocation silent
+
+
+processFileArgs :: DirConfig -> [String] -> IO [TestPackage]
+processFileArgs dcfg [] =
+    processFileArgs' dcfg . filter isValidEntry =<< getDirectoryContents srcDir
+  where
+    isValidEntry entry
+        | hasExtension entry = isSourceFile entry
+        | otherwise = isRealDir entry
+    srcDir = dcfgSrcDir dcfg
+processFileArgs dcfg args = processFileArgs' dcfg args
+
+
+processFileArgs' :: DirConfig -> [String] -> IO [TestPackage]
+processFileArgs' dcfg args = do
+    (dirs, mdls) <- partitionM doesDirectoryExist' . map takeBaseName $ args
+    rootPkg <- pure $ TestPackage
+        { tpkgName = ""
+        , tpkgFiles = map (srcDir </>) mdls
+        }
+    otherPkgs <- forM dirs $ \dir -> do
+        let srcDir' = srcDir </> dir
+        files <- filterM (isModule dir) =<< getDirectoryContents srcDir'
+        pure $ TestPackage
+            { tpkgName = dir
+            , tpkgFiles = map (srcDir' </>) files
+            }
+    pure . filter (not . null . tpkgFiles) $ rootPkg:otherPkgs
+  where
+    doesDirectoryExist' path = doesDirectoryExist (srcDir </> path)
+    isModule dir file = (isSourceFile file &&) <$>
+        doesFileExist (srcDir </> dir </> file)
+    srcDir = dcfgSrcDir dcfg
+
+
+isSourceFile :: FilePath -> Bool
+isSourceFile file = takeExtension file `elem` [".hs", ".lhs"]
+
+
+isRealDir :: FilePath -> Bool
+isRealDir dir = not $ dir `elem` [".", ".."]
diff --git a/haddock-test/src/Test/Haddock/Process.hs b/haddock-test/src/Test/Haddock/Process.hs
new file mode 100644
index 00000000..ae720f6f
--- /dev/null
+++ b/haddock-test/src/Test/Haddock/Process.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE RecordWildCards #-}
+
+
+module Test.Haddock.Process where
+
+
+import Control.Monad
+
+import System.Exit
+import System.IO
+import System.Process
+
+
+type Environment = [(String, String)]
+
+
+data ProcessConfig = ProcessConfig
+    { pcArgs :: [String]
+    , pcWorkDir :: Maybe FilePath
+    , pcEnv :: Maybe Environment
+    , pcStdIn :: Maybe Handle
+    , pcStdOut :: Maybe Handle
+    , pcStdErr :: Maybe Handle
+    }
+
+
+processConfig :: ProcessConfig
+processConfig = ProcessConfig
+    { pcArgs = []
+    , pcWorkDir = Nothing
+    , pcEnv = Nothing
+    , pcStdIn = Nothing
+    , pcStdOut = Nothing
+    , pcStdErr = Nothing
+    }
+
+
+runProcess' :: FilePath -> ProcessConfig -> IO ProcessHandle
+runProcess' path (ProcessConfig { .. }) = runProcess
+    path pcArgs pcWorkDir pcEnv pcStdIn pcStdOut pcStdErr
+
+
+waitForSuccess :: String -> ProcessHandle -> IO ()
+waitForSuccess msg handle = do
+    result <- waitForProcess handle
+    unless (result == ExitSuccess) $ do
+        hPutStrLn stderr $ msg
+        exitFailure
diff --git a/haddock-test/src/Test/Haddock/Utils.hs b/haddock-test/src/Test/Haddock/Utils.hs
new file mode 100644
index 00000000..a947fea1
--- /dev/null
+++ b/haddock-test/src/Test/Haddock/Utils.hs
@@ -0,0 +1,50 @@
+module Test.Haddock.Utils where
+
+
+import Control.Monad
+
+import Data.Maybe
+
+import System.Directory
+import System.FilePath
+
+
+mlast :: [a] -> Maybe a
+mlast = listToMaybe . reverse
+
+
+partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])
+partitionM _ [] = pure ([], [])
+partitionM p (x:xs) = do
+    (ss, fs) <- partitionM p xs
+    b <- p x
+    pure $ if b then (x:ss, fs) else (ss, x:fs)
+
+
+whenM :: Monad m => m Bool -> m () -> m ()
+whenM mb action = mb >>= \b -> when b action
+
+
+getDirectoryTree :: FilePath -> IO [FilePath]
+getDirectoryTree path = do
+    (dirs, files) <- partitionM isDirectory =<< contents
+    subfiles <- fmap concat . forM dirs $ \dir ->
+        map (dir </>) <$> getDirectoryTree (path </> dir)
+    pure $ files ++ subfiles
+  where
+    contents = filter realEntry <$> getDirectoryContents path
+    isDirectory entry = doesDirectoryExist $ path </> entry
+    realEntry entry = not $ entry == "." || entry == ".."
+
+
+createEmptyDirectory :: FilePath -> IO ()
+createEmptyDirectory path = do
+    whenM (doesDirectoryExist path) $ removeDirectoryRecursive path
+    createDirectory path
+
+
+-- | Just like 'copyFile' but output directory path is not required to exist.
+copyFile' :: FilePath -> FilePath -> IO ()
+copyFile' old new = do
+    createDirectoryIfMissing True $ takeDirectory new
+    copyFile old new
diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs
new file mode 100644
index 00000000..69361f7c
--- /dev/null
+++ b/haddock-test/src/Test/Haddock/Xhtml.hs
@@ -0,0 +1,94 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+
+module Test.Haddock.Xhtml
+    ( Xml(..)
+    , parseXml, dumpXml
+    , stripLinks, stripLinksWhen, stripAnchorsWhen, stripFooter
+    ) where
+
+
+import Data.Generics.Aliases
+import Data.Generics.Schemes
+
+import Text.XML.Light
+import Text.XHtml (Html, HtmlAttr, (!))
+import qualified Text.XHtml as Xhtml
+
+
+newtype Xml = Xml
+    { xmlElement :: Element
+    } deriving Eq
+
+
+-- TODO: Find a way to avoid warning about orphan instances.
+deriving instance Eq Element
+deriving instance Eq Content
+deriving instance Eq CData
+
+
+parseXml :: String -> Maybe Xml
+parseXml = fmap Xml . parseXMLDoc
+
+
+dumpXml :: Xml -> String
+dumpXml = Xhtml.renderHtmlFragment. xmlElementToXhtml . xmlElement
+
+
+stripLinks :: Xml -> Xml
+stripLinks = stripLinksWhen (const True)
+
+
+stripLinksWhen :: (String -> Bool) -> Xml -> Xml
+stripLinksWhen p =
+    processAnchors unlink
+  where
+    unlink attr@(Attr { attrKey = key, attrVal = val })
+        | qName key == "href" && p val = attr { attrVal = "#" }
+        | otherwise = attr
+
+
+stripAnchorsWhen :: (String -> Bool) -> Xml -> Xml
+stripAnchorsWhen p =
+    processAnchors unname
+  where
+    unname attr@(Attr { attrKey = key, attrVal = val })
+        | qName key == "name" && p val = attr { attrVal = "" }
+        | otherwise = attr
+
+
+processAnchors :: (Attr -> Attr) -> Xml -> Xml
+processAnchors f = Xml . everywhere (mkT f) . xmlElement
+
+
+stripFooter :: Xml -> Xml
+stripFooter =
+    Xml . everywhere (mkT defoot) . xmlElement
+  where
+    defoot el
+        | isFooter el = el { elContent = [] }
+        | otherwise = el
+    isFooter el = any isFooterAttr $ elAttribs el
+    isFooterAttr (Attr { .. }) = and
+        [ qName attrKey == "id"
+        , attrVal == "footer"
+        ]
+
+
+xmlElementToXhtml :: Element -> Html
+xmlElementToXhtml (Element { .. }) =
+    Xhtml.tag (qName elName) contents ! attrs
+  where
+    contents = mconcat $ map xmlContentToXhtml elContent
+    attrs = map xmlAttrToXhtml elAttribs
+
+
+xmlContentToXhtml :: Content -> Html
+xmlContentToXhtml (Elem el) = xmlElementToXhtml el
+xmlContentToXhtml (Text text) = Xhtml.toHtml $ cdData text
+xmlContentToXhtml (CRef _) = Xhtml.noHtml
+
+
+xmlAttrToXhtml :: Attr -> HtmlAttr
+xmlAttrToXhtml (Attr { .. }) = Xhtml.strAttr (qName attrKey) attrVal