From f0dff98eddcbb60911f22507acb03c8fdabac2ab Mon Sep 17 00:00:00 2001 From: Iain Nicol <iain@iainnicol.com> Date: Sat, 10 May 2014 13:44:21 +0100 Subject: [PATCH] Use Haddock's builtin support for .lhs and CPP This is a code simplification on our end. Thanks to Mikhail Glushenkov for the suggestion. Conflicts: Cabal/Distribution/Simple/Haddock.hs --- Cabal/Distribution/Simple/Haddock.hs | 94 ++++++++++------------------ 1 file changed, 32 insertions(+), 62 deletions(-) diff --git a/Cabal/Distribution/Simple/Haddock.hs b/Cabal/Distribution/Simple/Haddock.hs index ef8bf0557e..1495ef7705 100644 --- a/Cabal/Distribution/Simple/Haddock.hs +++ b/Cabal/Distribution/Simple/Haddock.hs @@ -6,9 +6,7 @@ -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- --- This module deals with the @haddock@ and @hscolour@ commands. Sadly this is a --- rather complicated module. It has to do pre-processing which involves --- \'unlit\'ing and using @-D__HADDOCK__@ for any source code that uses @cpp@. +-- This module deals with the @haddock@ and @hscolour@ commands. -- It uses information about installed packages (from @ghc-pkg@) to find the -- locations of documentation for dependent packages, so it can create links. -- @@ -69,8 +67,7 @@ import Distribution.Simple.Program ( ConfiguredProgram(..), requireProgramVersion , rawSystemProgram, rawSystemProgramStdout , hscolourProgram, haddockProgram ) -import Distribution.Simple.PreProcess (ppCpp', ppUnlit - , PPSuffixHandler, runSimplePreProcessor +import Distribution.Simple.PreProcess (PPSuffixHandler , preprocessComponent) import Distribution.Simple.Setup ( defaultHscolourFlags, Flag(..), toFlag, flagToMaybe, flagToList, fromFlag @@ -105,14 +102,13 @@ import Distribution.Text import Distribution.Verbosity import Language.Haskell.Extension -- Base -import System.Directory(removeFile, doesFileExist, createDirectoryIfMissing) +import System.Directory(doesFileExist) import Control.Monad ( when, forM_ ) -import Control.Exception (assert) import Data.Monoid import Data.Maybe ( fromMaybe, listToMaybe ) -import System.FilePath((</>), (<.>), splitFileName, splitExtension, +import System.FilePath((</>), (<.>), normalise, splitPath, joinPath, isAbsolute ) import System.IO (hClose, hPutStrLn) import Distribution.Version @@ -208,10 +204,9 @@ haddock pkg_descr lbi suffixes flags = do doExe com = case (compToExe com) of Just exe -> do withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ \tmp -> do - let bi = buildInfo exe - exeArgs <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate - exeArgs' <- prepareSources verbosity tmp - lbi version bi (commonArgs `mappend` exeArgs) + exeArgs <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate + version + let exeArgs' = commonArgs `mappend` exeArgs runHaddock verbosity tmpFileOpts confHaddock exeArgs' Nothing -> do warn (fromFlag $ haddockVerbosity flags) @@ -220,10 +215,9 @@ haddock pkg_descr lbi suffixes flags = do case comp of CLib lib -> do withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ \tmp -> do - let bi = libBuildInfo lib - libArgs <- fromLibrary verbosity tmp lbi lib clbi htmlTemplate - libArgs' <- prepareSources verbosity tmp - lbi version bi (commonArgs `mappend` libArgs) + libArgs <- fromLibrary verbosity tmp lbi lib clbi htmlTemplate + version + let libArgs' = commonArgs `mappend` libArgs runHaddock verbosity tmpFileOpts confHaddock libArgs' CExe _ -> when (flag haddockExecutables) $ doExe comp CTest _ -> when (flag haddockTestSuites) $ doExe comp @@ -239,48 +233,6 @@ haddock pkg_descr lbi suffixes flags = do flag f = fromFlag $ f flags htmlTemplate = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ flags --- | performs cpp and unlit preprocessing where needed on the files in --- | argTargets, which must have an .hs or .lhs extension. -prepareSources :: Verbosity - -> FilePath - -> LocalBuildInfo - -> Version - -> BuildInfo - -> HaddockArgs - -> IO HaddockArgs -prepareSources verbosity tmp lbi haddockVersion bi args@HaddockArgs{argTargets=files} = - mapM (mockPP tmp) files >>= \targets -> return args {argTargets=targets} - where - mockPP pref file = do - let (filePref, fileName) = splitFileName file - targetDir = pref </> filePref - targetFile = targetDir </> fileName - (targetFileNoext, targetFileExt) = splitExtension $ targetFile - hsFile = targetFileNoext <.> "hs" - - assert (targetFileExt `elem` [".lhs",".hs"]) $ return () - - createDirectoryIfMissing True targetDir - - if needsCpp - then do - runSimplePreProcessor (ppCpp' defines bi lbi) - file targetFile verbosity - else - copyFileVerbose verbosity file targetFile - - when (targetFileExt == ".lhs") $ do - runSimplePreProcessor ppUnlit targetFile hsFile verbosity - removeFile targetFile - - return hsFile - needsCpp = EnableExtension CPP `elem` allExtensions bi - defines = [haddockVersionMacro] - haddockVersionMacro = "-D__HADDOCK_VERSION__=" - ++ show (v1 * 1000 + v2 * 10 + v3) - where - [v1, v2, v3] = take 3 $ versionBranch haddockVersion ++ [0,0] - -- ------------------------------------------------------------------------------ -- Contributions to HaddockArgs. @@ -322,8 +274,9 @@ fromLibrary :: Verbosity -> FilePath -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> Maybe PathTemplate -- ^ template for html location + -> Version -> IO HaddockArgs -fromLibrary verbosity tmp lbi lib clbi htmlTemplate = do +fromLibrary verbosity tmp lbi lib clbi htmlTemplate haddockVersion = do inFiles <- map snd `fmap` getLibSourceFiles lbi lib ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) { @@ -334,7 +287,7 @@ fromLibrary verbosity tmp lbi lib clbi htmlTemplate = do ghcOptObjDir = toFlag tmp, ghcOptHiDir = toFlag tmp, ghcOptStubDir = toFlag tmp - } + } `mappend` getGhcCppOpts haddockVersion bi sharedOpts = vanillaOpts { ghcOptDynLinkMode = toFlag GhcDynamicOnly, ghcOptFPic = toFlag True, @@ -360,8 +313,9 @@ fromExecutable :: Verbosity -> FilePath -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> Maybe PathTemplate -- ^ template for html location + -> Version -> IO HaddockArgs -fromExecutable verbosity tmp lbi exe clbi htmlTemplate = do +fromExecutable verbosity tmp lbi exe clbi htmlTemplate haddockVersion = do inFiles <- map snd `fmap` getExeSourceFiles lbi exe ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) { @@ -372,7 +326,7 @@ fromExecutable verbosity tmp lbi exe clbi htmlTemplate = do ghcOptObjDir = toFlag tmp, ghcOptHiDir = toFlag tmp, ghcOptStubDir = toFlag tmp - } + } `mappend` getGhcCppOpts haddockVersion bi sharedOpts = vanillaOpts { ghcOptDynLinkMode = toFlag GhcDynamicOnly, ghcOptFPic = toFlag True, @@ -425,6 +379,22 @@ getInterfaces verbosity lbi clbi htmlTemplate = do argInterfaces = packageFlags } +getGhcCppOpts :: Version + -> BuildInfo + -> GhcOptions +getGhcCppOpts haddockVersion bi = + mempty { + ghcOptExtensions = [EnableExtension CPP | needsCpp], + ghcOptCppOptions = defines + } + where + needsCpp = EnableExtension CPP `elem` allExtensions bi + defines = [haddockVersionMacro] + haddockVersionMacro = "-D__HADDOCK_VERSION__=" + ++ show (v1 * 1000 + v2 * 10 + v3) + where + [v1, v2, v3] = take 3 $ versionBranch haddockVersion ++ [0,0] + getGhcLibDir :: Verbosity -> LocalBuildInfo -> IO HaddockArgs getGhcLibDir verbosity lbi = do -- GitLab