From f29e4f8963d57e941fbfd9254277ce690325a4db Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Mon, 8 Jan 2024 21:05:51 +0100 Subject: [PATCH] Use `open-browser` for proper `haddock --open` on Windows --- cabal-install/cabal-install.cabal | 1 + .../Client/ProjectBuilding/UnpackedPackage.hs | 20 ++++++++++++------- cabal-install/src/Distribution/Client/Utils.hs | 23 ---------------------- 3 files changed, 14 insertions(+), 30 deletions(-) diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 373152e8f..f842d4d31 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -238,6 +238,7 @@ library hackage-security >= 0.6.2.0 && < 0.7, text >= 1.2.3 && < 1.3 || >= 2.0 && < 2.2, parsec >= 3.1.13.0 && < 3.2, + open-browser >= 0.2.1.0 && < 0.3, regex-base >= 0.94.0.0 && <0.95, regex-posix >= 0.96.0.0 && <0.97, safe-exceptions >= 0.1.7.0 && < 0.2, diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index aec2aadf8..0cbb6f010 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -2,6 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | This module exposes functions to build and register unpacked packages. -- @@ -58,7 +59,6 @@ import Distribution.Client.Types hiding ) import Distribution.Client.Utils ( ProgressPhase (..) - , findOpenProgramLocation , progressMessage ) @@ -85,6 +85,7 @@ import Distribution.Types.BuildType import Distribution.Types.PackageDescription.Lens (componentModules) import Distribution.Simple.Utils +import Distribution.System (Platform (..)) import Distribution.Version import qualified Data.ByteString as BS @@ -92,12 +93,14 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as LBS.Char8 import qualified Data.List.NonEmpty as NE -import Control.Exception (Handler (..), SomeAsyncException, assert, catches) +import Control.Exception (ErrorCall, Handler (..), SomeAsyncException, assert, catches) import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile) import System.FilePath (dropDrive, normalise, takeDirectory, (<.>), ()) import System.IO (Handle, IOMode (AppendMode), withFile) import System.Semaphore (SemaphoreName (..)) +import Web.Browser (openBrowser) + import Distribution.Client.Errors import Distribution.Compat.Directory (listDirectory) @@ -420,7 +423,7 @@ buildInplaceUnpackedPackage buildSettings@BuildTimeSettings{buildSettingHaddockOpen} registerLock cacheLock - pkgshared@ElaboratedSharedConfig{pkgConfigPlatform = platform} + pkgshared@ElaboratedSharedConfig{pkgConfigPlatform = Platform _ os} plan rpkg@(ReadyPackage pkg) buildStatus @@ -527,10 +530,13 @@ buildInplaceUnpackedPackage docDir = case distHaddockOutputDir of Nothing -> distBuildDirectory distDirLayout dparams "doc" "html" name Just dir -> dir - exe <- findOpenProgramLocation platform - case exe of - Right open -> runProgramInvocation verbosity (simpleProgramInvocation open [dest]) - Left err -> dieWithException verbosity $ FindOpenProgramLocationErr err + catch + (void $ openBrowser dest) + ( \(_ :: ErrorCall) -> + dieWithException verbosity $ + FindOpenProgramLocationErr $ + "Unsupported OS: " <> show os + ) PBInstallPhase{runCopy = _runCopy, runRegister} -> do -- PURPOSELY omitted: no copy! diff --git a/cabal-install/src/Distribution/Client/Utils.hs b/cabal-install/src/Distribution/Client/Utils.hs index 59158ffd2..f5a10da78 100644 --- a/cabal-install/src/Distribution/Client/Utils.hs +++ b/cabal-install/src/Distribution/Client/Utils.hs @@ -28,7 +28,6 @@ module Distribution.Client.Utils , existsAndIsMoreRecentThan , tryFindAddSourcePackageDesc , tryFindPackageDesc - , findOpenProgramLocation , relaxEncodingErrors , ProgressPhase (..) , progressMessage @@ -69,13 +68,11 @@ import Distribution.Compat.Environment import Distribution.Compat.Time (getModTime) import Distribution.Simple.Setup (Flag (..)) import Distribution.Simple.Utils (dieWithException, findPackageDesc, noticeNoWrap) -import Distribution.System (OS (..), Platform (..)) import Distribution.Version import System.Directory ( canonicalizePath , doesDirectoryExist , doesFileExist - , findExecutable , getCurrentDirectory , getDirectoryContents , removeFile @@ -397,26 +394,6 @@ tryFindPackageDesc verbosity depPath err = do Right file -> return file Left _ -> dieWithException verbosity $ TryFindPackageDescErr err -findOpenProgramLocation :: Platform -> IO (Either String FilePath) -findOpenProgramLocation (Platform _ os) = - let - locate name = do - exe <- findExecutable name - case exe of - Just s -> pure (Right s) - Nothing -> pure (Left ("Couldn't find file-opener program `" <> name <> "`")) - xdg = locate "xdg-open" - in - case os of - Windows -> pure (Right "start") - OSX -> locate "open" - Linux -> xdg - FreeBSD -> xdg - OpenBSD -> xdg - NetBSD -> xdg - DragonFly -> xdg - _ -> pure (Left ("Couldn't determine file-opener program for " <> show os)) - -- | Phase of building a dependency. Represents current status of package -- dependency processing. See #4040 for details. data ProgressPhase -- 2.11.4.GIT