diff --git a/Cabal/Distribution/Simple/Haddock.hs b/Cabal/Distribution/Simple/Haddock.hs index 6d885960f8d..344652811bc 100644 --- a/Cabal/Distribution/Simple/Haddock.hs +++ b/Cabal/Distribution/Simple/Haddock.hs @@ -37,25 +37,26 @@ import Distribution.Simple.GHC ( componentGhcOptions, ghcLibDir ) import Distribution.Simple.Program.GHC ( GhcOptions(..), GhcDynLinkMode(..), renderGhcOptions ) import Distribution.Simple.Program - ( ConfiguredProgram(..), requireProgramVersion + ( ConfiguredProgram(..), lookupProgramVersion, requireProgramVersion , rawSystemProgram, rawSystemProgramStdout , hscolourProgram, haddockProgram ) -import Distribution.Simple.PreProcess (PPSuffixHandler - , preprocessComponent) +import Distribution.Simple.PreProcess + ( PPSuffixHandler, preprocessComponent) import Distribution.Simple.Setup - ( defaultHscolourFlags, Flag(..), toFlag, flagToMaybe, flagToList, fromFlag - , HaddockFlags(..), HscolourFlags(..) ) + ( defaultHscolourFlags + , Flag(..), toFlag, flagToMaybe, flagToList, fromFlag + , HaddockFlags(..), HscolourFlags(..) ) import Distribution.Simple.Build (initialBuildSteps) -import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplateEnv, PathTemplate, - PathTemplateVariable(..), - toPathTemplate, fromPathTemplate, - substPathTemplate, initialPathTemplateEnv) +import Distribution.Simple.InstallDirs + ( InstallDirs(..) + , PathTemplateEnv, PathTemplate, PathTemplateVariable(..) + , toPathTemplate, fromPathTemplate + , substPathTemplate, initialPathTemplateEnv ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), Component(..), ComponentLocalBuildInfo(..) , withAllComponentsInBuildOrder ) -import Distribution.Simple.BuildPaths ( haddockName, - hscolourPref, autogenModulesDir, - ) +import Distribution.Simple.BuildPaths + ( haddockName, hscolourPref, autogenModulesDir) import Distribution.Simple.PackageIndex (dependencyClosure) import qualified Distribution.Simple.PackageIndex as PackageIndex import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo @@ -74,43 +75,59 @@ import Distribution.Text import Distribution.Verbosity import Language.Haskell.Extension --- Base -import System.Directory(doesFileExist) -import Control.Monad ( when, forM_ ) -import Data.Either ( rights ) + +import Control.Monad ( when, forM_ ) +import Data.Either ( rights ) import Data.Monoid -import Data.Maybe ( fromMaybe, listToMaybe ) +import Data.Maybe ( fromMaybe, listToMaybe ) -import System.FilePath((), (<.>), - normalise, splitPath, joinPath, isAbsolute ) -import System.IO (hClose, hPutStrLn, hSetEncoding, utf8) +import System.Directory (doesFileExist) +import System.FilePath ( (), (<.>) + , normalise, splitPath, joinPath, isAbsolute ) +import System.IO (hClose, hPutStrLn, hSetEncoding, utf8) import Distribution.Version -- ------------------------------------------------------------------------------ -- Types --- | record that represents the arguments to the haddock executable, a product monoid. +-- | A record that represents the arguments to the haddock executable, a product +-- monoid. data HaddockArgs = HaddockArgs { - argInterfaceFile :: Flag FilePath, -- ^ path of the interface file, relative to argOutputDir, required. - argPackageName :: Flag PackageIdentifier, -- ^ package name, required. - argHideModules :: (All,[ModuleName.ModuleName]), -- ^ (hide modules ?, modules to hide) - argIgnoreExports :: Any, -- ^ ignore export lists in modules? - argLinkSource :: Flag (Template,Template,Template), -- ^ (template for modules, template for symbols, template for lines) - argCssFile :: Flag FilePath, -- ^ optional custom CSS file. - argContents :: Flag String, -- ^ optional URL to contents page + argInterfaceFile :: Flag FilePath, + -- ^ Path to the interface file, relative to argOutputDir, required. + argPackageName :: Flag PackageIdentifier, + -- ^ Package name, required. + argHideModules :: (All,[ModuleName.ModuleName]), + -- ^ (Hide modules ?, modules to hide) + argIgnoreExports :: Any, + -- ^ Ignore export lists in modules? + argLinkSource :: Flag (Template,Template,Template), + -- ^ (Template for modules, template for symbols, template for lines). + argCssFile :: Flag FilePath, + -- ^ Optional custom CSS file. + argContents :: Flag String, + -- ^ Optional URL to contents page. argVerbose :: Any, - argOutput :: Flag [Output], -- ^ HTML or Hoogle doc or both? required. - argInterfaces :: [(FilePath, Maybe String)], -- ^ [(interface file, URL to the HTML docs for links)] - argOutputDir :: Directory, -- ^ where to generate the documentation. - argTitle :: Flag String, -- ^ page's title, required. - argPrologue :: Flag String, -- ^ prologue text, required. - argGhcOptions :: Flag (GhcOptions, Version), -- ^ additional flags to pass to ghc - argGhcLibDir :: Flag FilePath, -- ^ to find the correct ghc, required. - argTargets :: [FilePath] -- ^ modules to process. + argOutput :: Flag [Output], + -- ^ HTML or Hoogle doc or both? Required. + argInterfaces :: [(FilePath, Maybe String)], + -- ^ [(Interface file, URL to the HTML docs for links)]. + argOutputDir :: Directory, + -- ^ Where to generate the documentation. + argTitle :: Flag String, + -- ^ Page title, required. + argPrologue :: Flag String, + -- ^ Prologue text, required. + argGhcOptions :: Flag (GhcOptions, Version), + -- ^ Additional flags to pass to GHC. + argGhcLibDir :: Flag FilePath, + -- ^ To find the correct GHC, required. + argTargets :: [FilePath] + -- ^ Modules to process. } --- | the FilePath of a directory, it's a monoid under () +-- | The FilePath of a directory, it's a monoid under '()'. newtype Directory = Dir { unDir' :: FilePath } deriving (Read,Show,Eq,Ord) unDir :: Directory -> FilePath @@ -123,7 +140,11 @@ data Output = Html | Hoogle -- ------------------------------------------------------------------------------ -- Haddock support -haddock :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags -> IO () +haddock :: PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HaddockFlags + -> IO () haddock pkg_descr _ _ haddockFlags | not (hasLibs pkg_descr) && not (fromFlag $ haddockExecutables haddockFlags) @@ -163,8 +184,9 @@ haddock pkg_descr lbi suffixes flags = do initialBuildSteps (flag haddockDistPref) pkg_descr lbi verbosity - when (flag haddockHscolour) $ hscolour' pkg_descr lbi suffixes $ - defaultHscolourFlags `mappend` haddockToHscolour flags + when (flag haddockHscolour) $ + hscolour' (warn verbosity) pkg_descr lbi suffixes + (defaultHscolourFlags `mappend` haddockToHscolour flags) libdirArgs <- getGhcLibDir verbosity lbi let commonArgs = mconcat @@ -178,22 +200,24 @@ haddock pkg_descr lbi suffixes flags = do let doExe com = case (compToExe com) of Just exe -> do - withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ \tmp -> do - exeArgs <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate - version - let exeArgs' = commonArgs `mappend` exeArgs - runHaddock verbosity tmpFileOpts comp confHaddock exeArgs' + withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ + \tmp -> do + exeArgs <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate + version + let exeArgs' = commonArgs `mappend` exeArgs + runHaddock verbosity tmpFileOpts comp confHaddock exeArgs' Nothing -> do warn (fromFlag $ haddockVerbosity flags) "Unsupported component, skipping..." return () case component of CLib lib -> do - withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ \tmp -> do - libArgs <- fromLibrary verbosity tmp lbi lib clbi htmlTemplate - version - let libArgs' = commonArgs `mappend` libArgs - runHaddock verbosity tmpFileOpts comp confHaddock libArgs' + withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ + \tmp -> do + libArgs <- fromLibrary verbosity tmp lbi lib clbi htmlTemplate + version + let libArgs' = commonArgs `mappend` libArgs + runHaddock verbosity tmpFileOpts comp confHaddock libArgs' CExe _ -> when (flag haddockExecutables) $ doExe component CTest _ -> when (flag haddockTestSuites) $ doExe component CBench _ -> when (flag haddockBenchmarks) $ doExe component @@ -207,7 +231,8 @@ haddock pkg_descr lbi suffixes flags = do comp = compiler lbi tmpFileOpts = defaultTempFileOptions { optKeepTempFiles = keepTempFiles } flag f = fromFlag $ f flags - htmlTemplate = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ flags + htmlTemplate = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation + $ flags -- ------------------------------------------------------------------------------ -- Contributions to HaddockArgs. @@ -215,15 +240,18 @@ haddock pkg_descr lbi suffixes flags = do fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs fromFlags env flags = mempty { - argHideModules = (maybe mempty (All . not) $ flagToMaybe (haddockInternal flags), mempty), + argHideModules = (maybe mempty (All . not) + $ flagToMaybe (haddockInternal flags), mempty), argLinkSource = if fromFlag (haddockHscolour flags) then Flag ("src/%{MODULE/./-}.html" ,"src/%{MODULE/./-}.html#%{NAME}" ,"src/%{MODULE/./-}.html#line-%{LINE}") else NoFlag, argCssFile = haddockCss flags, - argContents = fmap (fromPathTemplate . substPathTemplate env) (haddockContents flags), - argVerbose = maybe mempty (Any . (>= deafening)) . flagToMaybe $ haddockVerbosity flags, + argContents = fmap (fromPathTemplate . substPathTemplate env) + (haddockContents flags), + argVerbose = maybe mempty (Any . (>= deafening)) + . flagToMaybe $ haddockVerbosity flags, argOutput = Flag $ case [ Html | Flag True <- [haddockHtml flags] ] ++ [ Hoogle | Flag True <- [haddockHoogle flags] ] @@ -234,12 +262,13 @@ fromFlags env flags = fromPackageDescription :: PackageDescription -> HaddockArgs fromPackageDescription pkg_descr = - mempty { - argInterfaceFile = Flag $ haddockName pkg_descr, - argPackageName = Flag $ packageId $ pkg_descr, - argOutputDir = Dir $ "doc" "html" display (packageName pkg_descr), - argPrologue = Flag $ if null desc then synopsis pkg_descr else desc, - argTitle = Flag $ showPkg ++ subtitle + mempty { argInterfaceFile = Flag $ haddockName pkg_descr, + argPackageName = Flag $ packageId $ pkg_descr, + argOutputDir = Dir $ "doc" "html" + display (packageName pkg_descr), + argPrologue = Flag $ if null desc then synopsis pkg_descr + else desc, + argTitle = Flag $ showPkg ++ subtitle } where desc = PD.description pkg_descr @@ -276,7 +305,8 @@ fromLibrary verbosity tmp lbi lib clbi htmlTemplate haddockVersion = do then return vanillaOpts else if withSharedLib lbi then return sharedOpts - else die "Must have vanilla or shared libraries enabled in order to run haddock" + else die $ "Must have vanilla or shared libraries " + ++ "enabled in order to run haddock" return ifaceArgs { argHideModules = (mempty,otherModules $ bi), argGhcOptions = toFlag (opts, ghcVersion), @@ -315,7 +345,8 @@ fromExecutable verbosity tmp lbi exe clbi htmlTemplate haddockVersion = do then return vanillaOpts else if withSharedLib lbi then return sharedOpts - else die "Must have vanilla or shared libraries enabled in order to run haddock" + else die $ "Must have vanilla or shared libraries " + ++ "enabled in order to run haddock" return ifaceArgs { argGhcOptions = toFlag (opts, ghcVersion), argOutputDir = Dir (exeName exe), @@ -406,12 +437,13 @@ renderArgs :: Verbosity -> IO a renderArgs verbosity tmpFileOpts version comp args k = do createDirectoryIfMissingVerbose verbosity True outputDir - withTempFileEx tmpFileOpts outputDir "haddock-prolog.txt" $ \prologFileName h -> do + withTempFileEx tmpFileOpts outputDir "haddock-prologue.txt" $ + \prologueFileName h -> do do when (version >= Version [2,14,4] []) (hSetEncoding h utf8) hPutStrLn h $ fromFlag $ argPrologue args hClose h - let pflag = "--prologue=" ++ prologFileName + let pflag = "--prologue=" ++ prologueFileName k (pflag : renderPureArgs version comp args, result) where outputDir = (unDir $ argOutputDir args) @@ -428,30 +460,49 @@ renderArgs verbosity tmpFileOpts version comp args k = do renderPureArgs :: Version -> Compiler -> HaddockArgs -> [String] renderPureArgs version comp args = concat - [ - (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) f) - . fromFlag . argInterfaceFile $ args, - (\pname -> ["--optghc=-package-name", "--optghc=" ++ pname] - ) . display . fromFlag . argPackageName $ args, - (\(All b,xs) -> bool (map (("--hide=" ++). display) xs) [] b) . argHideModules $ args, - bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args, - maybe [] (\(m,e,l) -> ["--source-module=" ++ m - ,"--source-entity=" ++ e] - ++ if isVersion2_14 then ["--source-entity-line=" ++ l] - else [] - ) . flagToMaybe . argLinkSource $ args, - maybe [] ((:[]).("--css="++)) . flagToMaybe . argCssFile $ args, - maybe [] ((:[]).("--use-contents="++)) . flagToMaybe . argContents $ args, - bool [] [verbosityFlag] . getAny . argVerbose $ args, - map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html") . fromFlag . argOutput $ args, - renderInterfaces . argInterfaces $ args, - (:[]).("--odir="++) . unDir . argOutputDir $ args, - (:[]).("--title="++) . (bool (++" (internal documentation)") id (getAny $ argIgnoreExports args)) - . fromFlag . argTitle $ args, - [ "--optghc=" ++ opt | (opts, _ghcVer) <- flagToList (argGhcOptions args) - , opt <- renderGhcOptions comp opts ], - maybe [] (\l -> ["-B"++l]) $ flagToMaybe (argGhcLibDir args), -- error if Nothing? - argTargets $ args + [ (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) f) + . fromFlag . argInterfaceFile $ args + + , (\pname -> ["--optghc=-package-name", "--optghc=" ++ pname]) + . display . fromFlag . argPackageName $ args + + , (\(All b,xs) -> bool (map (("--hide=" ++). display) xs) [] b) + . argHideModules $ args + + , bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args + + , maybe [] (\(m,e,l) -> + ["--source-module=" ++ m + ,"--source-entity=" ++ e] + ++ if isVersion2_14 then ["--source-entity-line=" ++ l] + else [] + ) . flagToMaybe . argLinkSource $ args + + , maybe [] ((:[]) . ("--css="++)) . flagToMaybe . argCssFile $ args + + , maybe [] ((:[]) . ("--use-contents="++)) . flagToMaybe . argContents $ args + + , bool [] [verbosityFlag] . getAny . argVerbose $ args + + , map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html") + . fromFlag . argOutput $ args + + , renderInterfaces . argInterfaces $ args + + , (:[]) . ("--odir="++) . unDir . argOutputDir $ args + + , (:[]) . ("--title="++) + . (bool (++" (internal documentation)") + id (getAny $ argIgnoreExports args)) + . fromFlag . argTitle $ args + + , [ "--optghc=" ++ opt | (opts, _ghcVer) <- flagToList (argGhcOptions args) + , opt <- renderGhcOptions comp opts ] + + , maybe [] (\l -> ["-B"++l]) $ + flagToMaybe (argGhcLibDir args) -- error if Nothing? + + , argTargets $ args ] where renderInterfaces = @@ -540,54 +591,62 @@ haddockTemplateEnv lbi pkg_id = -- ------------------------------------------------------------------------------ -- hscolour support. -hscolour :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags -> IO () +hscolour :: PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HscolourFlags + -> IO () hscolour pkg_descr lbi suffixes flags = do -- we preprocess even if hscolour won't be found on the machine -- will this upset someone? initialBuildSteps distPref pkg_descr lbi verbosity - hscolour' pkg_descr lbi suffixes flags + hscolour' die pkg_descr lbi suffixes flags where verbosity = fromFlag (hscolourVerbosity flags) distPref = fromFlag $ hscolourDistPref flags -hscolour' :: PackageDescription +hscolour' :: (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found. + -> PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags -> IO () -hscolour' pkg_descr lbi suffixes flags = do - let distPref = fromFlag $ hscolourDistPref flags - (hscolourProg, _, _) <- - requireProgramVersion - verbosity hscolourProgram - (orLaterVersion (Version [1,8] [])) (withPrograms lbi) - - setupMessage verbosity "Running hscolour for" (packageId pkg_descr) - createDirectoryIfMissingVerbose verbosity True $ hscolourPref distPref pkg_descr - - let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes - withAllComponentsInBuildOrder pkg_descr lbi $ \comp _ -> do - pre comp - let - doExe com = case (compToExe com) of - Just exe -> do - let outputDir = hscolourPref distPref pkg_descr exeName exe "src" - runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe - Nothing -> do - warn (fromFlag $ hscolourVerbosity flags) - "Unsupported component, skipping..." - return () - case comp of - CLib lib -> do - let outputDir = hscolourPref distPref pkg_descr "src" - runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib - CExe _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp - CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp - CBench _ -> when (fromFlag (hscolourBenchmarks flags)) $ doExe comp +hscolour' onNoHsColour pkg_descr lbi suffixes flags = + either onNoHsColour (\(hscolourProg, _, _) -> go hscolourProg) =<< + lookupProgramVersion verbosity hscolourProgram + (orLaterVersion (Version [1,8] [])) (withPrograms lbi) where + go :: ConfiguredProgram -> IO () + go hscolourProg = do + setupMessage verbosity "Running hscolour for" (packageId pkg_descr) + createDirectoryIfMissingVerbose verbosity True $ + hscolourPref distPref pkg_descr + + let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes + withAllComponentsInBuildOrder pkg_descr lbi $ \comp _ -> do + pre comp + let + doExe com = case (compToExe com) of + Just exe -> do + let outputDir = hscolourPref distPref pkg_descr + exeName exe "src" + runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe + Nothing -> do + warn (fromFlag $ hscolourVerbosity flags) + "Unsupported component, skipping..." + return () + case comp of + CLib lib -> do + let outputDir = hscolourPref distPref pkg_descr "src" + runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib + CExe _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp + CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp + CBench _ -> when (fromFlag (hscolourBenchmarks flags)) $ doExe comp + stylesheet = flagToMaybe (hscolourCSS flags) verbosity = fromFlag (hscolourVerbosity flags) + distPref = fromFlag (hscolourDistPref flags) runHsColour prog outputDir moduleFiles = do createDirectoryIfMissingVerbose verbosity True outputDir @@ -603,7 +662,8 @@ hscolour' pkg_descr lbi suffixes flags = do rawSystemProgram verbosity prog ["-css", "-anchor", "-o" ++ outFile m, inFile] where - outFile m = outputDir intercalate "-" (ModuleName.components m) <.> "html" + outFile m = outputDir + intercalate "-" (ModuleName.components m) <.> "html" haddockToHscolour :: HaddockFlags -> HscolourFlags haddockToHscolour flags = diff --git a/Cabal/Distribution/Simple/Program.hs b/Cabal/Distribution/Simple/Program.hs index dd35b427c53..b8caf6052d8 100644 --- a/Cabal/Distribution/Simple/Program.hs +++ b/Cabal/Distribution/Simple/Program.hs @@ -79,6 +79,7 @@ module Distribution.Simple.Program ( , userSpecifyArgss , userSpecifiedArgs , lookupProgram + , lookupProgramVersion , updateProgram , configureProgram , configureAllKnownPrograms diff --git a/Cabal/Distribution/Simple/Program/Db.hs b/Cabal/Distribution/Simple/Program/Db.hs index f2fbc9b22f4..4dc4411d0bb 100644 --- a/Cabal/Distribution/Simple/Program/Db.hs +++ b/Cabal/Distribution/Simple/Program/Db.hs @@ -50,6 +50,7 @@ module Distribution.Simple.Program.Db ( -- ** Query and manipulate the program db configureProgram, configureAllKnownPrograms, + lookupProgramVersion, reconfigurePrograms, requireProgram, requireProgramVersion, @@ -73,6 +74,7 @@ import Distribution.Verbosity ( Verbosity ) import Data.Binary (Binary(..)) +import Data.Functor ((<$>)) import Data.List ( foldl' ) import Data.Maybe @@ -410,32 +412,35 @@ requireProgram verbosity prog conf = do -- | Check that a program is configured and available to be run. -- --- Additionally check that the version of the program number is suitable and --- return it. For example you could require 'AnyVersion' or --- @'orLaterVersion' ('Version' [1,0] [])@ +-- Additionally check that the program version number is suitable and return +-- it. For example you could require 'AnyVersion' or @'orLaterVersion' +-- ('Version' [1,0] [])@ -- --- It raises an exception if the program could not be configured or the version --- is unsuitable, otherwise it returns the configured program and its version --- number. +-- It returns the configured program, its version number and a possibly updated +-- 'ProgramDb'. If the program could not be configured or the version is +-- unsuitable, it returns an error value. -- -requireProgramVersion :: Verbosity -> Program -> VersionRange - -> ProgramDb - -> IO (ConfiguredProgram, Version, ProgramDb) -requireProgramVersion verbosity prog range conf = do +lookupProgramVersion + :: Verbosity -> Program -> VersionRange -> ProgramDb + -> IO (Either String (ConfiguredProgram, Version, ProgramDb)) +lookupProgramVersion verbosity prog range programDb = do -- If it's not already been configured, try to configure it now - conf' <- case lookupProgram prog conf of - Nothing -> configureProgram verbosity prog conf - Just _ -> return conf + programDb' <- case lookupProgram prog programDb of + Nothing -> configureProgram verbosity prog programDb + Just _ -> return programDb - case lookupProgram prog conf' of - Nothing -> die notFound + case lookupProgram prog programDb' of + Nothing -> return $! Left notFound Just configuredProg@ConfiguredProgram { programLocation = location } -> case programVersion configuredProg of Just version - | withinRange version range -> return (configuredProg, version, conf') - | otherwise -> die (badVersion version location) - Nothing -> die (noVersion location) + | withinRange version range -> + return $! Right (configuredProg, version ,programDb') + | otherwise -> + return $! Left (badVersion version location) + Nothing -> + return $! Left (noVersion location) where notFound = "The program '" ++ programName prog ++ "'" ++ versionRequirement @@ -451,3 +456,13 @@ requireProgramVersion verbosity prog range conf = do versionRequirement | isAnyVersion range = "" | otherwise = " version " ++ display range + +-- | Like 'lookupProgramVersion', but raises an exception in case of error +-- instead of returning 'Left errMsg'. +-- +requireProgramVersion :: Verbosity -> Program -> VersionRange + -> ProgramDb + -> IO (ConfiguredProgram, Version, ProgramDb) +requireProgramVersion verbosity prog range programDb = + join $ either die return <$> + lookupProgramVersion verbosity prog range programDb diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs index 362448f73fe..bb7547740ff 100644 --- a/cabal-install/Distribution/Client/Config.hs +++ b/cabal-install/Distribution/Client/Config.hs @@ -46,6 +46,7 @@ import Distribution.Client.Setup , InstallFlags(..), installOptions, defaultInstallFlags , UploadFlags(..), uploadCommand , ReportFlags(..), reportCommand + , defaultHaddockFlags , showRepo, parseRepo ) import Distribution.Utils.NubList ( fromNubList, toNubList) @@ -54,7 +55,7 @@ import Distribution.Simple.Compiler ( OptimisationLevel(..) ) import Distribution.Simple.Setup ( ConfigFlags(..), configureOptions, defaultConfigFlags - , HaddockFlags(..), haddockOptions, defaultHaddockFlags + , HaddockFlags(..), haddockOptions , installDirsOptions , programConfigurationPaths', programConfigurationOptions , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault ) diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index 628ef9be5c0..f47c869ae88 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -17,6 +17,7 @@ module Distribution.Client.Setup , configureExOptions , buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..) , replCommand, testCommand, benchmarkCommand + , defaultHaddockFlags , installCommand, InstallFlags(..), installOptions, defaultInstallFlags , listCommand, ListFlags(..) , updateCommand @@ -494,6 +495,15 @@ benchmarkCommand = parent { parent = Cabal.benchmarkCommand progConf = defaultProgramConfiguration +-- ------------------------------------------------------------ +-- * Default Haddock flags for 'cabal-install'. +-- ------------------------------------------------------------ + +defaultHaddockFlags :: HaddockFlags +defaultHaddockFlags = Cabal.defaultHaddockFlags { + haddockHscolour = Flag True + } + -- ------------------------------------------------------------ -- * Fetch command -- ------------------------------------------------------------ @@ -985,7 +995,7 @@ data InstallFlags = InstallFlags { defaultInstallFlags :: InstallFlags defaultInstallFlags = InstallFlags { - installDocumentation = Flag False, + installDocumentation = Flag True, installHaddockIndex = Flag docIndexFile, installDryRun = Flag False, installMaxBackjumps = Flag defaultMaxBackjumps, diff --git a/cabal-install/Main.hs b/cabal-install/Main.hs index d228eb8a211..c5a83b2f021 100644 --- a/cabal-install/Main.hs +++ b/cabal-install/Main.hs @@ -21,6 +21,7 @@ import Distribution.Client.Setup , ConfigExFlags(..), defaultConfigExFlags, configureExCommand , BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..) , buildCommand, replCommand, testCommand, benchmarkCommand + , defaultHaddockFlags , InstallFlags(..), defaultInstallFlags , installCommand, upgradeCommand , FetchFlags(..), fetchCommand @@ -42,7 +43,7 @@ import Distribution.Client.Setup , reportCommand ) import Distribution.Simple.Setup - ( HaddockFlags(..), haddockCommand, defaultHaddockFlags + ( HaddockFlags(..), haddockCommand , HscolourFlags(..), hscolourCommand , ReplFlags(..) , CopyFlags(..), copyCommand