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