Merge pull request #2015 from sjakobi/1396-haddock-open

Add `haddock --open` flag. #1396

ChangeLog.md

@@ -23,6 +23,7 @@ Behavior changes:
 
 Other enhancements:
 
+* `stack haddock --open [PACKAGE]` opens the local haddocks in the browser.
 * Fix too much rebuilding when enabling/disabling profiling flags.
 * Experimental support for `--split-objs` added.
 * `git` packages with submodules are supported by passing the `--recursive`

src/Stack/Build.hs

@@ -83,7 +83,7 @@ build setLocalFiles mbuildLk boptsCli = fixCodePage $ do
     let profiling = boptsLibProfile bopts || boptsExeProfile bopts
     menv <- getMinimalEnvOverride
 
-    (_, mbp, locals, extraToBuild, sourceMap) <- loadSourceMap NeedTargets boptsCli
+    (targets, mbp, locals, extraToBuild, sourceMap) <- loadSourceMap NeedTargets boptsCli
 
     -- Set local files, necessary for file watching
     stackYaml <- asks $ bcStackYaml . getBuildConfig
@@ -126,6 +126,7 @@ build setLocalFiles mbuildLk boptsCli = fixCodePage $ do
                          snapshotDumpPkgs
                          localDumpPkgs
                          installedMap
+                         targets
                          plan
 
 -- | If all the tasks are local, they don't mutate anything outside of our local directory.

src/Stack/Build/Execute.hs

@@ -17,7 +17,7 @@ module Stack.Build.Execute
     ) where
 
 import           Control.Applicative
-import           Control.Arrow ((&&&))
+import           Control.Arrow ((&&&), second)
 import           Control.Concurrent.Execute
 import           Control.Concurrent.MVar.Lifted
 import           Control.Concurrent.STM
@@ -56,6 +56,7 @@ import qualified Data.Text as T
 import           Data.Text.Encoding (decodeUtf8)
 import           Data.Time.Clock (getCurrentTime)
 import           Data.Traversable (forM)
+import           Data.Tuple
 import qualified Distribution.PackageDescription as C
 import           Distribution.System            (OS (Windows),
                                                  Platform (Platform))
@@ -69,6 +70,7 @@ import           Stack.Build.Cache
 import           Stack.Build.Haddock
 import           Stack.Build.Installed
 import           Stack.Build.Source
+import           Stack.Build.Target
 import           Stack.Config
 import           Stack.Constants
 import           Stack.Coverage
@@ -342,11 +344,12 @@ executePlan :: M env m
             -> [DumpPackage () ()] -- ^ snapshot packages
             -> [DumpPackage () ()] -- ^ local packages
             -> InstalledMap
+            -> Map PackageName SimpleTarget
             -> Plan
             -> m ()
-executePlan menv boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages installedMap plan = do
+executePlan menv boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages installedMap targets plan = do
     bopts <- asks (configBuild . getConfig)
-    withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages (executePlan' installedMap plan)
+    withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages (executePlan' installedMap targets plan)
 
     unless (Map.null $ planInstallExes plan) $ do
         snapBin <- (</> bindirSuffix) `liftM` installationRootDeps
@@ -468,10 +471,11 @@ windowsRenameCopy src dest = do
 -- | Perform the actual plan (internal)
 executePlan' :: M env m
              => InstalledMap
+             -> Map PackageName SimpleTarget
              -> Plan
              -> ExecuteEnv
              -> m ()
-executePlan' installedMap0 plan ee@ExecuteEnv {..} = do
+executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do
     when (toCoverage $ boptsTestOpts eeBuildOpts) deleteHpcReports
     wc <- getWhichCompiler
     cv <- asks $ envConfigCompilerVersion . getEnvConfig
@@ -548,6 +552,16 @@ executePlan' installedMap0 plan ee@ExecuteEnv {..} = do
         generateLocalHaddockIndex eeEnvOverride wc eeBaseConfigOpts localDumpPkgs eeLocals
         generateDepsHaddockIndex eeEnvOverride wc eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs localDumpPkgs eeLocals
         generateSnapHaddockIndex eeEnvOverride wc eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs
+        when (boptsOpenHaddocks eeBuildOpts) $ do
+            let planPkgs, localPkgs, installedPkgs, availablePkgs
+                    :: Map PackageName (PackageIdentifier, InstallLocation)
+                planPkgs = Map.map (taskProvides &&& taskLocation) (planTasks plan)
+                localPkgs =
+                    Map.fromList
+                        [(packageName p, (packageIdentifier p, Local)) | p <- map lpPackage eeLocals]
+                installedPkgs = Map.map (swap . second installedPackageIdentifier) installedMap'
+                availablePkgs = Map.unions [planPkgs, localPkgs, installedPkgs]
+            openHaddocksInBrowser eeBaseConfigOpts availablePkgs (Map.keysSet targets)
   where
     installedMap' = Map.difference installedMap0
                   $ Map.fromList

src/Stack/Build/Haddock.hs

@@ -11,6 +11,7 @@ module Stack.Build.Haddock
     ( generateLocalHaddockIndex
     , generateDepsHaddockIndex
     , generateSnapHaddockIndex
+    , openHaddocksInBrowser
     , shouldHaddockPackage
     , shouldHaddockDeps
     ) where
@@ -20,6 +21,7 @@ import           Control.Monad
 import           Control.Monad.Catch            (MonadCatch)
 import           Control.Monad.IO.Class
 import           Control.Monad.Logger
+import           Control.Monad.Reader
 import           Control.Monad.Trans.Resource
 import qualified Data.Foldable                  as F
 import           Data.Function
@@ -39,12 +41,39 @@ import           Path
 import           Path.Extra
 import           Path.IO
 import           Prelude
-import           Stack.Types.Build
 import           Stack.PackageDump
 import           Stack.Types
 import qualified System.FilePath                as FP
 import           System.IO.Error                (isDoesNotExistError)
 import           System.Process.Read
+import           Web.Browser                    (openBrowser)
+
+openHaddocksInBrowser
+    :: (MonadIO m, MonadReader env m, HasBuildConfig env, MonadThrow m)
+    => BaseConfigOpts
+    -> Map PackageName (PackageIdentifier, InstallLocation)
+    -- ^ Available packages and their locations for the current project
+    -> Set PackageName
+    -- ^ Build targets as determined by 'Stack.Build.Source.loadSourceMap'
+    -> m ()
+openHaddocksInBrowser bco pkgLocations buildTargets = do
+    let cliTargets = (boptsCLITargets . bcoBuildOptsCLI) bco
+    docDir <-
+        case (cliTargets, map (`Map.lookup` pkgLocations) (Set.toList buildTargets)) of
+            ([_], [Just (pkgId, iloc)]) -> do
+                pkgRelDir <- (parseRelDir . packageIdentifierString) pkgId
+                let docLocation =
+                        case iloc of
+                            Snap -> snapDocDir bco
+                            Local -> localDocDir bco
+                return (docLocation </> pkgRelDir)
+            _ -> do
+                inGlobalProject <- asks (bcImplicitGlobal . getBuildConfig)
+                return $
+                    if inGlobalProject
+                        then snapDocDir bco
+                        else localDepsDocDir bco
+    (liftIO . void . openBrowser . toFilePath . haddockIndexFile) docDir
 
 -- | Determine whether we should haddock for a package.
 shouldHaddockPackage :: BuildOpts
@@ -100,7 +129,7 @@ generateDepsHaddockIndex
     -> m ()
 generateDepsHaddockIndex envOverride wc bco globalDumpPkgs snapshotDumpPkgs localDumpPkgs locals = do
     let deps = (mapMaybe (`lookupDumpPackage` allDumpPkgs) . nubOrd . findTransitiveDepends . mapMaybe getGhcPkgId) locals
-        depDocDir = localDocDir bco </> $(mkRelDir "all")
+        depDocDir = localDepsDocDir bco
     generateHaddockIndex
         "local packages and dependencies"
         envOverride
@@ -247,6 +276,10 @@ haddockIndexFile destDir = destDir </> $(mkRelFile "index.html")
 localDocDir :: BaseConfigOpts -> Path Abs Dir
 localDocDir bco = bcoLocalInstallRoot bco </> docDirSuffix
 
+-- | Path of documentation directory for the dependencies of local packages
+localDepsDocDir :: BaseConfigOpts -> Path Abs Dir
+localDepsDocDir bco = localDocDir bco </> $(mkRelDir "all")
+
 -- | Path of snapshot packages documentation directory.
 snapDocDir :: BaseConfigOpts -> Path Abs Dir
 snapDocDir bco = bcoSnapInstallRoot bco </> docDirSuffix

src/Stack/Config/Build.hs

@@ -18,6 +18,9 @@ buildOptsFromMonoid BuildOptsMonoid{..} = BuildOpts
     , boptsHaddock = fromMaybe
           (boptsHaddock defaultBuildOpts)
           buildMonoidHaddock
+    , boptsOpenHaddocks = fromMaybe
+          (boptsOpenHaddocks defaultBuildOpts)
+          buildMonoidOpenHaddocks
     , boptsHaddockDeps = buildMonoidHaddockDeps
     , boptsInstallExes = fromMaybe
           (boptsInstallExes defaultBuildOpts)

src/Stack/Options.hs

@@ -356,7 +356,7 @@ buildOptsMonoidParser hide0 =
                     \exception" <>
             hide)
     options =
-        BuildOptsMonoid <$> libProfiling <*> exeProfiling <*> haddock <*>
+        BuildOptsMonoid <$> libProfiling <*> exeProfiling <*> haddock <*> openHaddocks <*>
         haddockDeps <*> copyBins <*> preFetch <*> keepGoing <*> forceDirty <*>
         tests <*> testOptsParser hide0 <*> benches <*> benchOptsParser hide0 <*> reconfigure <*>
         cabalVerbose <*> splitObjs
@@ -375,6 +375,11 @@ buildOptsMonoidParser hide0 =
             "haddock"
             "generating Haddocks the package(s) in this directory/configuration"
             hide
+    openHaddocks =
+        maybeBoolFlags
+            "open"
+            "opening the local Haddock documentation in the browser"
+            hide
     haddockDeps =
         maybeBoolFlags "haddock-deps" "building Haddocks for dependencies" hide
     copyBins =

src/Stack/Types/Build.hs

@@ -550,6 +550,7 @@ data BaseConfigOpts = BaseConfigOpts
     , bcoBuildOptsCLI :: !BuildOptsCLI
     , bcoExtraDBs :: ![(Path Abs Dir)]
     }
+    deriving Show
 
 -- | Render a @BaseConfigOpts@ to an actual list of options
 configureOpts :: EnvConfig

src/Stack/Types/Config/Build.hs

@@ -37,6 +37,8 @@ data BuildOpts =
             ,boptsExeProfile :: !Bool
             ,boptsHaddock :: !Bool
             -- ^ Build haddocks?
+            ,boptsOpenHaddocks :: !Bool
+            -- ^ Open haddocks in the browser?
             ,boptsHaddockDeps :: !(Maybe Bool)
             -- ^ Build haddocks for dependencies?
             ,boptsInstallExes :: !Bool
@@ -74,6 +76,7 @@ defaultBuildOpts = BuildOpts
     { boptsLibProfile = False
     , boptsExeProfile = False
     , boptsHaddock = False
+    , boptsOpenHaddocks = False
     , boptsHaddockDeps = Nothing
     , boptsInstallExes = False
     , boptsPreFetch = False
@@ -128,6 +131,7 @@ data BuildOptsMonoid = BuildOptsMonoid
     { buildMonoidLibProfile :: !(Maybe Bool)
     , buildMonoidExeProfile :: !(Maybe Bool)
     , buildMonoidHaddock :: !(Maybe Bool)
+    , buildMonoidOpenHaddocks :: !(Maybe Bool)
     , buildMonoidHaddockDeps :: !(Maybe Bool)
     , buildMonoidInstallExes :: !(Maybe Bool)
     , buildMonoidPreFetch :: !(Maybe Bool)
@@ -147,6 +151,7 @@ instance FromJSON (WithJSONWarnings BuildOptsMonoid) where
     (\o -> do buildMonoidLibProfile <- o ..:? buildMonoidLibProfileArgName
               buildMonoidExeProfile <- o ..:? buildMonoidExeProfileArgName
               buildMonoidHaddock <- o ..:? buildMonoidHaddockArgName
+              buildMonoidOpenHaddocks <- o ..:? buildMonoidOpenHaddocksArgName
               buildMonoidHaddockDeps <- o ..:? buildMonoidHaddockDepsArgName
               buildMonoidInstallExes <- o ..:? buildMonoidInstallExesArgName
               buildMonoidPreFetch <- o ..:? buildMonoidPreFetchArgName
@@ -170,6 +175,9 @@ buildMonoidExeProfileArgName = "executable-profiling"
 buildMonoidHaddockArgName :: Text
 buildMonoidHaddockArgName = "haddock"
 
+buildMonoidOpenHaddocksArgName :: Text
+buildMonoidOpenHaddocksArgName = "open-haddocks"
+
 buildMonoidHaddockDepsArgName :: Text
 buildMonoidHaddockDepsArgName = "haddock-deps"
 
@@ -211,6 +219,7 @@ instance Monoid BuildOptsMonoid where
     {buildMonoidLibProfile = Nothing
     ,buildMonoidExeProfile = Nothing
     ,buildMonoidHaddock = Nothing
+    ,buildMonoidOpenHaddocks = Nothing
     ,buildMonoidHaddockDeps = Nothing
     ,buildMonoidInstallExes = Nothing
     ,buildMonoidPreFetch = Nothing
@@ -229,6 +238,7 @@ instance Monoid BuildOptsMonoid where
     {buildMonoidLibProfile = buildMonoidLibProfile l <|> buildMonoidLibProfile r
     ,buildMonoidExeProfile = buildMonoidExeProfile l <|> buildMonoidExeProfile r
     ,buildMonoidHaddock = buildMonoidHaddock l <|> buildMonoidHaddock r
+    ,buildMonoidOpenHaddocks = buildMonoidOpenHaddocks l <|> buildMonoidOpenHaddocks r
     ,buildMonoidHaddockDeps = buildMonoidHaddockDeps l <|> buildMonoidHaddockDeps r
     ,buildMonoidInstallExes = buildMonoidInstallExes l <|> buildMonoidInstallExes r
     ,buildMonoidPreFetch = buildMonoidPreFetch l <|> buildMonoidPreFetch r

src/Stack/Types/Package.hs

@@ -414,7 +414,10 @@ type InstalledMap = Map PackageName (InstallLocation, Installed)
 data Installed = Library PackageIdentifier GhcPkgId | Executable PackageIdentifier
     deriving (Show, Eq, Ord)
 
+installedPackageIdentifier :: Installed -> PackageIdentifier
+installedPackageIdentifier (Library pid _) = pid
+installedPackageIdentifier (Executable pid) = pid
+
 -- | Get the installed Version.
 installedVersion :: Installed -> Version
-installedVersion (Library (PackageIdentifier _ v) _) = v
-installedVersion (Executable (PackageIdentifier _ v)) = v
+installedVersion = packageIdentifierVersion . installedPackageIdentifier

stack-7.8.yaml

@@ -26,3 +26,4 @@ extra-deps:
 - base-compat-0.9.0
 - hpack-0.10.0
 - microlens-0.4.1.0
+- open-browser-0.2.1.0

stack.cabal

@@ -175,6 +175,7 @@ library
                    , monad-control
                    , monad-logger >= 0.3.13.1
                    , mtl >= 2.1.3.1
+                   , open-browser >= 0.2.1
                    , optparse-applicative >= 0.11 && < 0.13
                    , path >= 0.5.1
                    , path-io >= 1.1.0 && < 2.0.0