From 1f53ed43f383fa8f7a0ab0991fff6f4cbc988401 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 --- src/Stack/Build/Execute.hs | 2 ++ src/Stack/Build/Haddock.hs | 47 ++++++++++++++++++++++++++++++++- src/Stack/Config/Build.hs | 3 +++ src/Stack/Options.hs | 7 ++++- src/Stack/Types/Build.hs | 1 + src/Stack/Types/Config/Build.hs | 10 +++++++ stack-7.8.yaml | 1 + stack.cabal | 1 + 8 files changed, 70 insertions(+), 2 deletions(-) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 60784895ba..62fcdd21d8 100644 --- a/src/Stack/Build/Execute.hs +++ b/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 diff --git a/src/Stack/Build/Haddock.hs b/src/Stack/Build/Haddock.hs index f6d388d502..ad899efe4e 100644 --- a/src/Stack/Build/Haddock.hs +++ b/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 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 5995dbd422..5774bf7b6e 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 1b88cba5be..e4843f1698 100644 --- a/src/Stack/Types/Build.hs +++ b/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 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/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 0961994f4e..204d71786d 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