Merge pull request #362 from commercialhaskell/143-haddock-deps

Build haddocks for dependencies (#143)

src/Options/Applicative/Builder/Extra.hs

@@ -2,8 +2,10 @@
 
 module Options.Applicative.Builder.Extra
   (boolFlags
+  ,boolFlagsNoDefault
   ,maybeBoolFlags
   ,enableDisableFlags
+  ,enableDisableFlagsNoDefault
   ,extraHelpOption
   ,execExtraHelp)
   where
@@ -17,13 +19,23 @@ import System.FilePath (takeBaseName)
 boolFlags :: Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool
 boolFlags defaultValue = enableDisableFlags defaultValue True False
 
+-- | Enable/disable flags for a @Bool@, without a default case (to allow chaining @<|>@s).
+boolFlagsNoDefault :: String -> String -> Mod FlagFields Bool -> Parser Bool
+boolFlagsNoDefault = enableDisableFlagsNoDefault True False
+
 -- | Enable/disable flags for a @(Maybe Bool)@.
 maybeBoolFlags :: String -> String -> Mod FlagFields (Maybe Bool) -> Parser (Maybe Bool)
 maybeBoolFlags = enableDisableFlags Nothing (Just True) (Just False)
 
 -- | Enable/disable flags for any type.
 enableDisableFlags :: a -> a -> a -> String -> String -> Mod FlagFields a -> Parser a
 enableDisableFlags defaultValue enabledValue disabledValue name helpSuffix mods =
+  enableDisableFlagsNoDefault enabledValue disabledValue name helpSuffix mods <|>
+  pure defaultValue
+
+-- | Enable/disable flags for any type, without a default (to allow chaining @<|>@s)
+enableDisableFlagsNoDefault :: a -> a -> String -> String -> Mod FlagFields a -> Parser a
+enableDisableFlagsNoDefault enabledValue disabledValue name helpSuffix mods =
   flag' enabledValue
         (long name <>
          help ("Enable " ++ helpSuffix) <>
@@ -41,8 +53,7 @@ enableDisableFlags defaultValue enabledValue disabledValue name helpSuffix mods
         (internal <>
          long ("disable-" ++ name) <>
          help ("Disable " ++ helpSuffix) <>
-         mods) <|>
-  pure defaultValue
+         mods)
 
 -- | Show an extra help option (e.g. @--docker-help@ shows help for all @--docker*@ args).
 -- To actually show have that help appear, use 'execExtraHelp' before executing the main parser.

src/Stack/Build.hs

@@ -26,6 +26,7 @@ import           Control.Monad.Trans.Resource
 import           Data.Function
 import           Data.Map.Strict (Map)
 import qualified Data.Map as Map
+import           Data.Maybe (fromMaybe)
 import           Network.HTTP.Client.Conduit (HasHttpManager)
 import           Path.IO
 import           Prelude hiding (FilePath, writeFile)
@@ -55,7 +56,12 @@ build bopts = do
     menv <- getMinimalEnvOverride
 
     (mbp, locals, extraToBuild, sourceMap) <- loadSourceMap bopts
-    (installedMap, locallyRegistered) <- getInstalled menv profiling sourceMap
+    (installedMap, locallyRegistered) <-
+        getInstalled menv
+                     GetInstalledOpts
+                         { getInstalledProfiling = profiling
+                         , getInstalledHaddock   = fromMaybe (boptsHaddock bopts) (boptsDepsHaddock bopts) }
+                     sourceMap
 
     baseConfigOpts <- mkBaseConfigOpts bopts
     plan <- withLoadPackage menv $ \loadPackage ->

src/Stack/Build/ConstructPlan.hs

@@ -89,6 +89,7 @@ data Ctx = Ctx
     , callStack      :: ![PackageName]
     , extraToBuild   :: !(Set PackageName)
     , latestVersions :: !(Map PackageName Version)
+    , wanted         :: !(Set PackageName)
     }
 
 instance HasStackRoot Ctx
@@ -161,6 +162,7 @@ constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 locallyRegistered loadPa
         , callStack = []
         , extraToBuild = extraToBuild0
         , latestVersions = latest
+        , wanted = wantedLocalPackages locals
         }
     toolMap = getToolMap mbp0
 
@@ -197,7 +199,7 @@ addFinal lp = do
                             allDeps
                             True -- wanted
                             Local
-                            (packageFlags package)
+                            package
                 , taskPresent = present
                 , taskType = TTLocal lp
                 }
@@ -239,7 +241,7 @@ addDep'' name = do
             installPackage name ps
         Just (PIBoth ps installed) -> do
             tellExecutables name ps
-            needInstall <- checkNeedInstall name ps installed
+            needInstall <- checkNeedInstall name ps installed (wanted ctx)
             if needInstall
                 then installPackage name ps
                 else return $ Right $ ADRFound (piiLocation ps) (piiVersion ps) installed
@@ -290,22 +292,22 @@ installPackage name ps = do
                             -- An assertion to check for a recurrence of
                             -- https://github.com/commercialhaskell/stack/issues/345
                             (assert (destLoc == piiLocation ps) destLoc)
-                            (packageFlags package)
+                            package
                 , taskPresent = present
                 , taskType =
                     case ps of
                         PSLocal lp -> TTLocal lp
                         PSUpstream _ loc _ -> TTUpstream package $ loc <> minLoc
                 }
 
-checkNeedInstall :: PackageName -> PackageSource -> Installed -> M Bool
-checkNeedInstall name ps installed = assert (piiLocation ps == Local) $ do
+checkNeedInstall :: PackageName -> PackageSource -> Installed -> Set PackageName -> M Bool
+checkNeedInstall name ps installed wanted = assert (piiLocation ps == Local) $ do
     package <- psPackage name ps
     depsRes <- addPackageDeps package
     case depsRes of
         Left _e -> return True -- installPackage will find the error again
         Right (missing, present, _loc)
-            | Set.null missing -> checkDirtiness ps installed package present
+            | Set.null missing -> checkDirtiness ps installed package present wanted
             | otherwise -> return True
 
 addPackageDeps :: Package -> M (Either ConstructPlanException (Set PackageIdentifier, Set GhcPkgId, Location))
@@ -345,28 +347,35 @@ checkDirtiness :: PackageSource
                -> Installed
                -> Package
                -> Set GhcPkgId
+               -> Set PackageName
                -> M Bool
-checkDirtiness ps installed package present = do
+checkDirtiness ps installed package present wanted = do
     ctx <- ask
+    moldOpts <- tryGetFlagCache installed
     let configOpts = configureOpts
             (getEnvConfig ctx)
             (baseConfigOpts ctx)
             present
             (psWanted ps)
             (piiLocation ps) -- should be Local always
-            (packageFlags package)
-        configCache = ConfigCache
+            package
+        buildOpts = bcoBuildOpts (baseConfigOpts ctx)
+        wantConfigCache = ConfigCache
             { configCacheOpts = map encodeUtf8 configOpts
             , configCacheDeps = present
             , configCacheComponents =
                 case ps of
                     PSLocal lp -> Set.map encodeUtf8 $ lpComponents lp
                     PSUpstream _ _ _ -> Set.empty
+            , configCacheHaddock =
+                shouldBuildHaddock buildOpts wanted (packageName package) ||
+                -- Disabling haddocks when old config had haddocks doesn't make dirty.
+                maybe False configCacheHaddock moldOpts
             }
-    moldOpts <- tryGetFlagCache installed
     case moldOpts of
         Nothing -> return True
-        Just oldOpts -> return $ oldOpts /= configCache || psDirty ps
+        Just oldOpts -> return $ oldOpts /= wantConfigCache ||
+                                 psDirty ps
 
 psDirty :: PackageSource -> Bool
 psDirty (PSLocal lp) = lpDirtyFiles lp

src/Stack/Build/Execute.hs

@@ -36,6 +36,7 @@ import           Data.Map.Strict                (Map)
 import qualified Data.Map.Strict                as M
 import qualified Data.Map.Strict                as Map
 import           Data.Maybe
+import           Data.Set                       (Set)
 import qualified Data.Set                       as Set
 import           Data.Streaming.Process         hiding (callProcess, env)
 import qualified Data.Streaming.Process         as Process
@@ -115,7 +116,6 @@ printPlan finalAction plan = do
                 DoNothing -> Nothing
                 DoBenchmarks -> Just "benchmark"
                 DoTests -> Just "test"
-                DoHaddock -> Just "haddock"
     case mfinalLabel of
         Nothing -> return ()
         Just finalLabel -> do
@@ -174,6 +174,7 @@ data ExecuteEnv = ExecuteEnv
     , eeSetupHs        :: !(Path Abs File)
     , eeCabalPkgVer    :: !Version
     , eeTotalWanted    :: !Int
+    , eeWanted         :: !(Set PackageName)
     }
 
 -- | Perform the actual plan
@@ -208,6 +209,7 @@ executePlan menv bopts baseConfigOpts locals plan = do
             , eeSetupHs = setupHs
             , eeCabalPkgVer = cabalPkgVer
             , eeTotalWanted = length $ filter lpWanted locals
+            , eeWanted = wantedLocalPackages locals
             }
 
     unless (Map.null $ planInstallExes plan) $ do
@@ -372,7 +374,6 @@ toActions runInBase ee (mbuild, mfinal) =
             DoNothing -> Nothing
             DoTests -> Just (singleTest, checkTest)
             DoBenchmarks -> Just (singleBench, checkBench)
-            DoHaddock -> Just (singleHaddock, const True)
 
     checkTest task =
         case taskType task of
@@ -419,6 +420,8 @@ ensureConfig pkgDir ExecuteEnv {..} Task {..} announce cabal cabalfp extra = do
                 case taskType of
                     TTLocal lp -> Set.map encodeUtf8 $ lpComponents lp
                     TTUpstream _ _ -> Set.empty
+            , configCacheHaddock =
+                shouldBuildHaddock eeBuildOpts eeWanted (packageIdentifierName taskProvides)
             }
 
     let needConfig = mOldConfigCache /= Just newConfigCache
@@ -593,6 +596,16 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} =
             TTLocal lp -> "build" : map T.unpack (Set.toList $ lpComponents lp)
             TTUpstream _ _ -> ["build"]
 
+    when (shouldBuildHaddock eeBuildOpts eeWanted (packageName package) &&
+          packageHasLibrary package &&
+          -- Works around haddock failing on bytestring-builder since it has no modules when
+          -- bytestring is new enough.
+          packageHasExposedModules package) $ do
+        announce "haddock"
+        hscolourExists <- doesExecutableExist eeEnvOverride "hscolour"
+        cabal False (concat [["haddock", "--html"]
+                            ,["--hyperlink-source" | hscolourExists]])
+
     withMVar eeInstallLock $ \() -> do
         announce "install"
         cabal False ["install"]
@@ -720,61 +733,6 @@ singleBench ac ee task =
         announce "benchmarks"
         cabal False ["bench"]
 
-singleHaddock :: M env m
-              => ActionContext
-              -> ExecuteEnv
-              -> Task
-              -> m ()
-singleHaddock ac ee task =
-    withSingleContext ac ee task $ \_package _cabalfp _pkgDir cabal announce _console _mlogFile -> do
-        announce "haddock"
-        hscolourExists <- doesExecutableExist (eeEnvOverride ee) "hscolour"
-              {- EKB TODO: doc generation for stack-doc-server
- #ifndef mingw32_HOST_OS
-              liftIO (removeDocLinks docLoc package)
- #endif
-              ifcOpts <- liftIO (haddockInterfaceOpts docLoc package packages)
-              -}
-        cabal False (concat [["haddock", "--html"]
-                            ,["--hyperlink-source" | hscolourExists]])
-              {- EKB TODO: doc generation for stack-doc-server
-                         ,"--hoogle"
-                         ,"--html-location=../$pkg-$version/"
-                         ,"--haddock-options=" ++ intercalate " " ifcOpts ]
-              haddockLocs <-
-                liftIO (findFiles (packageDocDir package)
-                                  (\loc -> FilePath.takeExtensions (toFilePath loc) ==
-                                           "." ++ haddockExtension)
-                                  (not . isHiddenDir))
-              forM_ haddockLocs $ \haddockLoc ->
-                do let hoogleTxtPath = FilePath.replaceExtension (toFilePath haddockLoc) "txt"
-                       hoogleDbPath = FilePath.replaceExtension hoogleTxtPath hoogleDbExtension
-                   hoogleExists <- liftIO (doesFileExist hoogleTxtPath)
-                   when hoogleExists
-                        (callProcess
-                             "hoogle"
-                             ["convert"
-                             ,"--haddock"
-                             ,hoogleTxtPath
-                             ,hoogleDbPath])
-                        -}
-                 {- EKB TODO: doc generation for stack-doc-server
-             #ifndef mingw32_HOST_OS
-                 case setupAction of
-                   DoHaddock -> liftIO (createDocLinks docLoc package)
-                   _ -> return ()
-             #endif
-
- -- | Package's documentation directory.
- packageDocDir :: (MonadThrow m, MonadReader env m, HasPlatform env)
-               => PackageIdentifier -- ^ Cabal version
-               -> Package
-               -> m (Path Abs Dir)
- packageDocDir cabalPkgVer package' = do
-   dist <- distDirFromDir cabalPkgVer (packageDir package')
-   return (dist </> $(mkRelDir "doc/"))
-                 --}
-
 -- | Grab all output from the given @Handle@ and print it to stdout, stripping
 -- Template Haskell "Loading package" lines. Does work in a separate thread.
 printBuildOutput :: (MonadIO m, MonadBaseControl IO m, MonadLogger m)