From ff32ff5759aa5a8a608398d2e83ee8a28ddf8174 Mon Sep 17 00:00:00 2001 From: Simon Jakobi Date: Sun, 3 Apr 2016 05:01:57 +0200 Subject: [PATCH] Add `haddock --open` flag. #1396 --- ChangeLog.md | 1 + src/Stack/Build.hs | 3 ++- src/Stack/Build/Execute.hs | 22 ++++++++++++++++---- src/Stack/Build/Haddock.hs | 37 +++++++++++++++++++++++++++++++-- src/Stack/Config/Build.hs | 3 +++ src/Stack/Options.hs | 7 ++++++- src/Stack/Types/Build.hs | 1 + src/Stack/Types/Config/Build.hs | 10 +++++++++ src/Stack/Types/Package.hs | 7 +++++-- stack-7.8.yaml | 1 + stack.cabal | 1 + 11 files changed, 83 insertions(+), 10 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 7d3fd1f584..52dabfa101 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -16,6 +16,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` diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index b4cdde5c40..f764f53791 100644 --- a/src/Stack/Build.hs +++ b/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. diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index f5e26b5827..722443f350 100644 --- a/src/Stack/Build/Execute.hs +++ b/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 diff --git a/src/Stack/Build/Haddock.hs b/src/Stack/Build/Haddock.hs index f6d388d502..435ee2ae13 100644 --- a/src/Stack/Build/Haddock.hs +++ b/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 diff --git a/src/Stack/Config/Build.hs b/src/Stack/Config/Build.hs index 6d5c3c1d01..83b4d4cc2b 100644 --- a/src/Stack/Config/Build.hs +++ b/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) diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index 6dbe81b1e3..7c1fbd1b23 100644 --- a/src/Stack/Options.hs +++ b/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 = diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 87eea0bde8..90972adcca 100644 --- a/src/Stack/Types/Build.hs +++ b/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 diff --git a/src/Stack/Types/Config/Build.hs b/src/Stack/Types/Config/Build.hs index 45f7cf2ec3..18bdc30d4c 100644 --- a/src/Stack/Types/Config/Build.hs +++ b/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 diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index 6789599bfb..69133a16a4 100644 --- a/src/Stack/Types/Package.hs +++ b/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 diff --git a/stack-7.8.yaml b/stack-7.8.yaml index a3172625ec..f227b96c1c 100644 --- a/stack-7.8.yaml +++ b/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 diff --git a/stack.cabal b/stack.cabal index 3fce2b39fb..c20d02371b 100644 --- a/stack.cabal +++ b/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