diff options
| -rw-r--r-- | src/Haddock/Options.hs | 3 | ||||
| -rw-r--r-- | src/Main.hs | 39 | ||||
| -rw-r--r-- | tests/html-tests/README | 6 | ||||
| -rw-r--r-- | tests/html-tests/accept.hs | 30 | ||||
| -rw-r--r-- | tests/html-tests/runtests.hs | 49 |
5 files changed, 86 insertions, 41 deletions
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs index 8cb70d00..7323a806 100644 --- a/src/Haddock/Options.hs +++ b/src/Haddock/Options.hs @@ -71,6 +71,7 @@ data Flag | Flag_OptGhc String | Flag_GhcLibDir String | Flag_GhcVersion + | Flag_PrintGhcPath | Flag_PrintGhcLibDir | Flag_NoWarnings | Flag_UseUnicode @@ -147,6 +148,8 @@ options backwardsCompat = "option to be forwarded to GHC", Option [] ["ghc-version"] (NoArg Flag_GhcVersion) "output GHC version in numeric format", + Option [] ["print-ghc-path"] (NoArg Flag_PrintGhcPath) + "output path to GHC binary", Option [] ["print-ghc-libdir"] (NoArg Flag_PrintGhcLibDir) "output GHC lib dir", Option ['w'] ["no-warnings"] (NoArg Flag_NoWarnings) "turn off all warnings", diff --git a/src/Main.hs b/src/Main.hs index ba48a709..cc5d1302 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -50,7 +50,7 @@ import Data.Int #ifdef IN_GHC_TREE import System.FilePath #else -import GHC.Paths +import qualified GHC.Paths as GhcPaths import Paths_haddock #endif @@ -155,7 +155,7 @@ main = handleTopExceptions $ do readPackagesAndProcessModules :: [Flag] -> [String] -> IO ([(DocPaths, InterfaceFile)], [Interface], LinkEnv) readPackagesAndProcessModules flags files = do - libDir <- getGhcLibDir flags + libDir <- fmap snd (getGhcDirs flags) -- Catches all GHC source errors, then prints and re-throws them. let handleSrcErrors action' = flip handleSourceError action' $ \err -> do @@ -329,23 +329,24 @@ getHaddockLibDir flags = case [str | Flag_Lib str <- flags] of [] -> #ifdef IN_GHC_TREE - getInTreeLibDir + fmap snd getInTreeDirs #else getDataDir -- provided by Cabal #endif fs -> return (last fs) -getGhcLibDir :: [Flag] -> IO String -getGhcLibDir flags = - case [ dir | Flag_GhcLibDir dir <- flags ] of - [] -> +getGhcDirs :: [Flag] -> IO (String, String) +getGhcDirs flags = do + (ghcPath, libDir) <- #ifdef IN_GHC_TREE - getInTreeLibDir + getInTreeDirs #else - return libdir -- from GHC.Paths + return (GhcPaths.ghc, GhcPaths.libdir) #endif - xs -> return $ last xs + case [ dir | Flag_GhcLibDir dir <- flags ] of + [] -> return (ghcPath, libDir) + xs -> return (ghcPath, last xs) shortcutFlags :: [Flag] -> IO () @@ -356,8 +357,12 @@ shortcutFlags flags = do when (Flag_Version `elem` flags) byeVersion when (Flag_GhcVersion `elem` flags) byeGhcVersion + when (Flag_PrintGhcPath `elem` flags) $ do + dir <- fmap fst (getGhcDirs flags) + bye $ dir ++ "\n" + when (Flag_PrintGhcLibDir `elem` flags) $ do - dir <- getGhcLibDir flags + dir <- fmap snd (getGhcDirs flags) bye $ dir ++ "\n" when (Flag_UseUnicode `elem` flags && Flag_Html `notElem` flags) $ @@ -404,16 +409,12 @@ getPrologue flags = #ifdef IN_GHC_TREE -getInTreeLibDir :: IO String -getInTreeLibDir = do +getInTreeDirs :: IO (String, String) +getInTreeDirs = do m <- getExecDir case m of - Nothing -> error "No GhcLibDir found" -#ifdef NEW_GHC_LAYOUT - Just d -> return (d </> ".." </> "lib") -#else - Just d -> return (d </> "..") -#endif + Nothing -> error "No GhcDir found" + Just d -> let p = d </> ".." in return (p </> "bin" </> "ghc", p </> "lib") getExecDir :: IO (Maybe String) diff --git a/tests/html-tests/README b/tests/html-tests/README index 644d0a71..9afb10e7 100644 --- a/tests/html-tests/README +++ b/tests/html-tests/README @@ -9,12 +9,12 @@ To add a new test: passes since there is no reference file to compare with. 3) To make a reference file from the output file, do - runhaskell copy.hs <modulename> + runhaskell accept.hs <modulename> Tips and tricks: -To copy all output files into reference files, run - runhaskell copy.hs +To "accept" all output files (copy them to reference files), run + runhaskell accept.hs You can run all tests despite failing tests, like so cabal test --test-option=all diff --git a/tests/html-tests/accept.hs b/tests/html-tests/accept.hs new file mode 100644 index 00000000..fa18fe9c --- /dev/null +++ b/tests/html-tests/accept.hs @@ -0,0 +1,30 @@ +import System.Cmd +import System.Environment +import System.FilePath +import System.Exit +import System.Directory +import Data.List +import Control.Monad +import Text.Regex + + +main = do + args <- getArgs + dir <- getCurrentDirectory + contents <- getDirectoryContents (dir </> "output") + if not $ null args + then + mapM copy [ "output" </> file | file <- contents, ".html" `isSuffixOf` file, takeBaseName file `elem` args ] + else + mapM copy [ "output" </> file | file <- contents, ".html" `isSuffixOf` file ] + + +copy file = do + let new = "tests" </> takeFileName file <.> ".ref" + print file + print new + contents <- readFile file + writeFile new (stripLinks contents) + + +stripLinks f = subRegex (mkRegexWithOpts "<A HREF=[^>]*>" False False) f "<A HREF=\"\">" diff --git a/tests/html-tests/runtests.hs b/tests/html-tests/runtests.hs index 2f7ed2e2..48ea5214 100644 --- a/tests/html-tests/runtests.hs +++ b/tests/html-tests/runtests.hs @@ -1,17 +1,22 @@ +import Control.Monad +import Data.List +import Data.Maybe +import Distribution.InstalledPackageInfo +import Distribution.Package +import Distribution.Simple.Compiler +import Distribution.Simple.GHC +import Distribution.Simple.PackageIndex +import Distribution.Simple.Program +import Distribution.Simple.Utils +import Distribution.Verbosity import System.Cmd +import System.Directory import System.Environment -import System.FilePath import System.Exit -import System.Directory +import System.FilePath import System.Process -import Data.List -import Control.Monad import Text.Printf import Text.Regex -import Distribution.Simple.Utils -import Distribution.Simple.Program -import Distribution.Verbosity -import Data.Maybe packageRoot = "." @@ -51,17 +56,23 @@ test = do waitForProcess h2 putStrLn "" - -- TODO: use Distribution.* to get the packages instead - libdir <- rawSystemStdout normal haddockPath ["--print-ghc-libdir"] - let librariesPath = ".."</>".."</>"share"</>"doc"</>"ghc"</>"html"</>"libraries" - - let mkDep name version = - let path = init libdir </> librariesPath </> name ++ "-" ++ version - in "-i " ++ path ++ "," ++ path </> name ++ ".haddock" - - let base = mkDep "base" "4.3.1.0" - process = mkDep "process" "1.0.1.5" - ghcprim = mkDep "ghc-prim" "0.2.0.0" + -- TODO: maybe do something more clever here using haddock.cabal + ghcPath <- fmap init $ rawSystemStdout normal haddockPath ["--print-ghc-path"] + (_, conf) <- configure normal (Just ghcPath) Nothing emptyProgramConfiguration + pkgIndex <- getInstalledPackages normal [GlobalPackageDB] conf + let safeHead xs = case xs of x : _ -> Just x; [] -> Nothing + let mkDep pkgName = + maybe (error "Couldn't find test dependencies") id $ do + let pkgs = lookupPackageName pkgIndex (PackageName pkgName) + (_, pkgs') <- safeHead pkgs + pkg <- safeHead pkgs' + ifacePath <- safeHead (haddockInterfaces pkg) + htmlPath <- safeHead (haddockHTMLs pkg) + return ("-i " ++ htmlPath ++ "," ++ ifacePath) + + let base = mkDep "base" + process = mkDep "process" + ghcprim = mkDep "ghc-prim" putStrLn "Running tests..." handle <- runProcess haddockPath |