Add haddock --open flag. commercialhaskell#1396

src/Stack/Build/Execute.hs

@@ -549,6 +549,8 @@ 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) $
+            openHaddocks installedMap0 eeBaseConfigOpts eeLocals
   where
     installedMap' = Map.difference installedMap0
                   $ Map.fromList

src/Stack/Build/Haddock.hs

@@ -11,6 +11,7 @@ module Stack.Build.Haddock
     ( generateLocalHaddockIndex
     , generateDepsHaddockIndex
     , generateSnapHaddockIndex
+    , openHaddocks
     , 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
@@ -35,16 +37,55 @@ import qualified Data.Set                       as Set
 import           Data.Text                      (Text)
 import qualified Data.Text                      as T
 import           Data.Time                      (UTCTime)
+import           Network.HTTP.Download
 import           Path
 import           Path.Extra
 import           Path.IO
 import           Prelude
+import           Stack.Build.Source
+import           Stack.Build.Target
 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 qualified Web.Browser
+
+openHaddocks
+    :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m, MonadReader env m, HasEnvConfig env, HasHttpManager env)
+    => InstalledMap
+    -> BaseConfigOpts
+    -> [LocalPackage]
+    -> m ()
+openHaddocks installedMap bco localPkgs = do
+    inGlobalProject <- asks (bcImplicitGlobal . getBuildConfig)
+    (_mbp, _pkgMap, targets) <- parseTargetsFromBuildOpts AllowNoTargets (bcoBuildOptsCLI bco)
+    docDir <-
+        case Map.toList targets of
+            [(pkgName, _simpleTarget)] ->
+                case find (\pkg -> packageName pkg == pkgName) (map lpPackage localPkgs) of
+                    Just pkg -> do
+                        pkgRelDir <- (parseRelDir . show . packageIdentifier) pkg
+                        return (localDocDir bco </> pkgRelDir)
+                    Nothing -> do
+                        case Map.lookup pkgName installedMap of
+                            Just (_loc, installed) -> do
+                                let pkgId = PackageIdentifier pkgName (installedVersion installed)
+                                pkgRelDir <- (parseRelDir . show) pkgId
+                                let docLocation =
+                                      if inGlobalProject
+                                          then snapDocDir bco
+                                          else localDocDir bco
+                                return (docLocation </> pkgRelDir)
+                            _ ->
+                                -- Frische "global locals" kommen leider auch hier an…
+                                error ("openHaddocks: unknown package: " ++ show pkgName)
+            _ -> return $
+                if inGlobalProject
+                    then snapDocDir bco
+                    else localDepsDocDir bco
+    (liftIO . void . Web.Browser.openBrowser . toFilePath . haddockIndexFile) docDir
 
 -- | Determine whether we should haddock for a package.
 shouldHaddockPackage :: BuildOpts
@@ -100,7 +141,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 +288,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

@@ -549,6 +549,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

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