Commit d9286320 authored by Mikhail Glushenkov's avatar Mikhail Glushenkov
Browse files

Merge pull request #1707 from 23Skidoo/haddock-saved-config

Add a 'haddock' section to '~/.cabal/config'.
parents 34179398 4651d0e6
......@@ -222,7 +222,11 @@ viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa
set' (Just txt) = readEOrFail set txt
optDescrToGetOpt (ChoiceOpt alts) =
[GetOpt.Option sf lf (GetOpt.NoArg set) d | (d,(sf,lf),set,_) <- alts ]
optDescrToGetOpt (BoolOpt d (sfT,lfT) (sfF, lfF) set _) =
optDescrToGetOpt (BoolOpt d (sfT, lfT) ([], []) set _) =
[ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) d ]
optDescrToGetOpt (BoolOpt d ([], []) (sfF, lfF) set _) =
[ GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) d ]
optDescrToGetOpt (BoolOpt d (sfT,lfT) (sfF, lfF) set _) =
[ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d)
, GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) ]
......@@ -329,12 +333,15 @@ commandShowOptions command v = concat
[ showOptDescr v od | o <- commandOptions command ParseArgs
, od <- optionDescr o]
where
maybePrefix [] = []
maybePrefix (lOpt:_) = ["--" ++ lOpt]
showOptDescr :: a -> OptDescr a -> [String]
showOptDescr x (BoolOpt _ (_,lfT:_) (_,lfF:_) _ enabled)
showOptDescr x (BoolOpt _ (_,lfTs) (_,lfFs) _ enabled)
= case enabled x of
Nothing -> []
Just True -> ["--" ++ lfT]
Just False -> ["--" ++ lfF]
Just True -> maybePrefix lfTs
Just False -> maybePrefix lfFs
showOptDescr x c@ChoiceOpt{}
= ["--" ++ val | val <- getCurrentChoice c x]
showOptDescr x (ReqArg _ (_ssff,lf:_) _ _ showflag)
......
......@@ -51,7 +51,7 @@ module Distribution.Simple.Setup (
defaultBenchmarkFlags, benchmarkCommand,
CopyDest(..),
configureArgs, configureOptions, configureCCompiler, configureLinker,
buildOptions, installDirsOptions,
buildOptions, haddockOptions, installDirsOptions,
programConfigurationOptions, programConfigurationPaths',
defaultDistPref,
......@@ -171,7 +171,9 @@ flagToList (Flag x) = [x]
flagToList NoFlag = []
allFlags :: [Flag Bool] -> Flag Bool
allFlags flags = toFlag $ all (\f -> fromFlagOrDefault False f) flags
allFlags flags = if all (\f -> fromFlagOrDefault False f) flags
then Flag True
else NoFlag
-- ------------------------------------------------------------
-- * Global flags
......@@ -1166,85 +1168,7 @@ haddockCommand = makeCommand name shortDesc longDesc defaultHaddockFlags options
name = "haddock"
shortDesc = "Generate Haddock HTML documentation."
longDesc = Just $ \_ -> "Requires the program haddock, either version 0.x or 2.x.\n"
options showOrParseArgs =
[optionVerbosity haddockVerbosity
(\v flags -> flags { haddockVerbosity = v })
,optionDistPref
haddockDistPref (\d flags -> flags { haddockDistPref = d })
showOrParseArgs
,option "" ["keep-temp-files"]
"Keep temporary files"
haddockKeepTempFiles (\b flags -> flags { haddockKeepTempFiles = b })
trueArg
,option "" ["hoogle"]
"Generate a hoogle database"
haddockHoogle (\v flags -> flags { haddockHoogle = v })
trueArg
,option "" ["html"]
"Generate HTML documentation (the default)"
haddockHtml (\v flags -> flags { haddockHtml = v })
trueArg
,option "" ["html-location"]
"Location of HTML documentation for pre-requisite packages"
haddockHtmlLocation (\v flags -> flags { haddockHtmlLocation = v })
(reqArgFlag "URL")
,option "" ["executables"]
"Run haddock for Executables targets"
haddockExecutables (\v flags -> flags { haddockExecutables = v })
trueArg
,option "" ["tests"]
"Run haddock for Test Suite targets"
haddockTestSuites (\v flags -> flags { haddockTestSuites = v })
trueArg
,option "" ["benchmarks"]
"Run haddock for Benchmark targets"
haddockBenchmarks (\v flags -> flags { haddockBenchmarks = v })
trueArg
,option "" ["all"]
"Run haddock for all targets"
(\f -> allFlags [ haddockExecutables f
, haddockTestSuites f
, haddockBenchmarks f])
(\v flags -> flags { haddockExecutables = v
, haddockTestSuites = v
, haddockBenchmarks = v })
trueArg
,option "" ["internal"]
"Run haddock for internal modules and include all symbols"
haddockInternal (\v flags -> flags { haddockInternal = v })
trueArg
,option "" ["css"]
"Use PATH as the haddock stylesheet"
haddockCss (\v flags -> flags { haddockCss = v })
(reqArgFlag "PATH")
,option "" ["hyperlink-source","hyperlink-sources"]
"Hyperlink the documentation to the source code (using HsColour)"
haddockHscolour (\v flags -> flags { haddockHscolour = v })
trueArg
,option "" ["hscolour-css"]
"Use PATH as the HsColour stylesheet"
haddockHscolourCss (\v flags -> flags { haddockHscolourCss = v })
(reqArgFlag "PATH")
,option "" ["contents-location"]
"Bake URL in as the location for the contents page"
haddockContents (\v flags -> flags { haddockContents = v })
(reqArg' "URL"
(toFlag . toPathTemplate)
(flagToList . fmap fromPathTemplate))
]
options showOrParseArgs = haddockOptions showOrParseArgs
++ programConfigurationPaths progConf ParseArgs
haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v})
++ programConfigurationOption progConf showOrParseArgs
......@@ -1255,6 +1179,87 @@ haddockCommand = makeCommand name shortDesc longDesc defaultHaddockFlags options
$ addKnownProgram ghcProgram
$ emptyProgramConfiguration
haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags]
haddockOptions showOrParseArgs =
[optionVerbosity haddockVerbosity
(\v flags -> flags { haddockVerbosity = v })
,optionDistPref
haddockDistPref (\d flags -> flags { haddockDistPref = d })
showOrParseArgs
,option "" ["keep-temp-files"]
"Keep temporary files"
haddockKeepTempFiles (\b flags -> flags { haddockKeepTempFiles = b })
trueArg
,option "" ["hoogle"]
"Generate a hoogle database"
haddockHoogle (\v flags -> flags { haddockHoogle = v })
trueArg
,option "" ["html"]
"Generate HTML documentation (the default)"
haddockHtml (\v flags -> flags { haddockHtml = v })
trueArg
,option "" ["html-location"]
"Location of HTML documentation for pre-requisite packages"
haddockHtmlLocation (\v flags -> flags { haddockHtmlLocation = v })
(reqArgFlag "URL")
,option "" ["executables"]
"Run haddock for Executables targets"
haddockExecutables (\v flags -> flags { haddockExecutables = v })
trueArg
,option "" ["tests"]
"Run haddock for Test Suite targets"
haddockTestSuites (\v flags -> flags { haddockTestSuites = v })
trueArg
,option "" ["benchmarks"]
"Run haddock for Benchmark targets"
haddockBenchmarks (\v flags -> flags { haddockBenchmarks = v })
trueArg
,option "" ["all"]
"Run haddock for all targets"
(\f -> allFlags [ haddockExecutables f
, haddockTestSuites f
, haddockBenchmarks f])
(\v flags -> flags { haddockExecutables = v
, haddockTestSuites = v
, haddockBenchmarks = v })
trueArg
,option "" ["internal"]
"Run haddock for internal modules and include all symbols"
haddockInternal (\v flags -> flags { haddockInternal = v })
trueArg
,option "" ["css"]
"Use PATH as the haddock stylesheet"
haddockCss (\v flags -> flags { haddockCss = v })
(reqArgFlag "PATH")
,option "" ["hyperlink-source","hyperlink-sources"]
"Hyperlink the documentation to the source code (using HsColour)"
haddockHscolour (\v flags -> flags { haddockHscolour = v })
trueArg
,option "" ["hscolour-css"]
"Use PATH as the HsColour stylesheet"
haddockHscolourCss (\v flags -> flags { haddockHscolourCss = v })
(reqArgFlag "PATH")
,option "" ["contents-location"]
"Bake URL in as the location for the contents page"
haddockContents (\v flags -> flags { haddockContents = v })
(reqArg' "URL"
(toFlag . toPathTemplate)
(flagToList . fmap fromPathTemplate))
]
emptyHaddockFlags :: HaddockFlags
emptyHaddockFlags = mempty
......@@ -1835,10 +1840,9 @@ boolOpt' :: OptFlags -> OptFlags
-> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
boolOpt' = Command.boolOpt' flagToMaybe Flag
trueArg, falseArg :: SFlags -> LFlags -> Description -> (b -> Flag Bool) ->
(Flag Bool -> (b -> b)) -> OptDescr b
trueArg = noArg (Flag True)
falseArg = noArg (Flag False)
trueArg, falseArg :: MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
trueArg sfT lfT = boolOpt' (sfT, lfT) ([], []) sfT lfT
falseArg sfF lfF = boolOpt' ([], []) (sfF, lfF) sfF lfF
reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description ->
(b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b
......
......@@ -30,12 +30,12 @@ module Distribution.Client.Config (
commentSavedConfig,
initialSavedConfig,
configFieldDescriptions,
haddockFlagsFields,
installDirsFields,
withProgramsFields,
withProgramOptionsFields
) where
import Distribution.Client.Types
( RemoteRepo(..), Username(..), Password(..) )
import Distribution.Client.BuildReports.Types
......@@ -52,6 +52,7 @@ import Distribution.Simple.Compiler
( OptimisationLevel(..) )
import Distribution.Simple.Setup
( ConfigFlags(..), configureOptions, defaultConfigFlags
, HaddockFlags(..), haddockOptions, defaultHaddockFlags
, installDirsOptions
, programConfigurationPaths', programConfigurationOptions
, Flag(..), toFlag, flagToMaybe, fromFlagOrDefault )
......@@ -121,7 +122,8 @@ data SavedConfig = SavedConfig {
savedUserInstallDirs :: InstallDirs (Flag PathTemplate),
savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate),
savedUploadFlags :: UploadFlags,
savedReportFlags :: ReportFlags
savedReportFlags :: ReportFlags,
savedHaddockFlags :: HaddockFlags
}
instance Monoid SavedConfig where
......@@ -133,7 +135,8 @@ instance Monoid SavedConfig where
savedUserInstallDirs = mempty,
savedGlobalInstallDirs = mempty,
savedUploadFlags = mempty,
savedReportFlags = mempty
savedReportFlags = mempty,
savedHaddockFlags = mempty
}
mappend a b = SavedConfig {
savedGlobalFlags = combine savedGlobalFlags,
......@@ -143,7 +146,8 @@ instance Monoid SavedConfig where
savedUserInstallDirs = combine savedUserInstallDirs,
savedGlobalInstallDirs = combine savedGlobalInstallDirs,
savedUploadFlags = combine savedUploadFlags,
savedReportFlags = combine savedReportFlags
savedReportFlags = combine savedReportFlags,
savedHaddockFlags = combine savedHaddockFlags
}
where combine field = field a `mappend` field b
......@@ -359,7 +363,8 @@ commentSavedConfig = do
savedUserInstallDirs = fmap toFlag userInstallDirs,
savedGlobalInstallDirs = fmap toFlag globalInstallDirs,
savedUploadFlags = commandDefaultFlags uploadCommand,
savedReportFlags = commandDefaultFlags reportCommand
savedReportFlags = commandDefaultFlags reportCommand,
savedHaddockFlags = defaultHaddockFlags
}
-- | All config file fields.
......@@ -510,18 +515,25 @@ parseConfig initial = \str -> do
config <- parse others
let user0 = savedUserInstallDirs config
global0 = savedGlobalInstallDirs config
(user, global, paths, args) <-
foldM parseSections (user0, global0, [], []) knownSections
(haddockFlags, user, global, paths, args) <-
foldM parseSections
(savedHaddockFlags config, user0, global0, [], [])
knownSections
return config {
savedConfigureFlags = (savedConfigureFlags config) {
configProgramPaths = paths,
configProgramArgs = args
},
savedHaddockFlags = haddockFlags {
haddockProgramPaths = paths,
haddockProgramArgs = args
},
savedUserInstallDirs = user,
savedGlobalInstallDirs = global
}
where
isKnownSection (ParseUtils.Section _ "haddock" _ _) = True
isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True
isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True
isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True
......@@ -530,26 +542,34 @@ parseConfig initial = \str -> do
parse = parseFields (configFieldDescriptions
++ deprecatedFieldDescriptions) initial
parseSections accum@(u,g,p,a) (ParseUtils.Section _ "install-dirs" name fs)
parseSections accum@(h,u,g,p,a)
(ParseUtils.Section _ "haddock" name fs)
| name == "" = do h' <- parseFields haddockFlagsFields h fs
return (h', u, g, p, a)
| otherwise = do
warning "The 'haddock' section should be unnamed"
return accum
parseSections accum@(h,u,g,p,a)
(ParseUtils.Section _ "install-dirs" name fs)
| name' == "user" = do u' <- parseFields installDirsFields u fs
return (u', g, p, a)
return (h, u', g, p, a)
| name' == "global" = do g' <- parseFields installDirsFields g fs
return (u, g', p, a)
return (h, u, g', p, a)
| otherwise = do
warning "The 'install-paths' section should be for 'user' or 'global'"
return accum
where name' = lowercase name
parseSections accum@(u,g,p,a)
parseSections accum@(h,u,g,p,a)
(ParseUtils.Section _ "program-locations" name fs)
| name == "" = do p' <- parseFields withProgramsFields p fs
return (u, g, p', a)
return (h, u, g, p', a)
| otherwise = do
warning "The 'program-locations' section should be unnamed"
return accum
parseSections accum@(u, g, p, a)
parseSections accum@(h, u, g, p, a)
(ParseUtils.Section _ "program-default-options" name fs)
| name == "" = do a' <- parseFields withProgramOptionsFields a fs
return (u, g, p, a')
return (h, u, g, p, a')
| otherwise = do
warning "The 'program-default-options' section should be unnamed"
return accum
......@@ -564,6 +584,9 @@ showConfigWithComments :: SavedConfig -> SavedConfig -> String
showConfigWithComments comment vals = Disp.render $
ppFields configFieldDescriptions mcomment vals
$+$ Disp.text ""
$+$ ppSection "haddock" "" haddockFlagsFields
(fmap savedHaddockFlags mcomment) (savedHaddockFlags vals)
$+$ Disp.text ""
$+$ installDirsSection "user" savedUserInstallDirs
$+$ Disp.text ""
$+$ installDirsSection "global" savedGlobalInstallDirs
......@@ -583,10 +606,20 @@ showConfigWithComments comment vals = Disp.render $
(fmap (field . savedConfigureFlags) mcomment)
((field . savedConfigureFlags) vals)
-- | Fields for the 'install-dirs' sections.
installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))]
installDirsFields = map viewAsFieldDescr installDirsOptions
-- | Fields for the 'haddock' section.
haddockFlagsFields :: [FieldDescr HaddockFlags]
haddockFlagsFields = [ field
| opt <- haddockOptions ParseArgs
, let field = viewAsFieldDescr opt
name = fieldName field
, name `notElem` exclusions ]
where
exclusions = ["verbose", "builddir"]
-- | Fields for the 'program-locations' section.
withProgramsFields :: [FieldDescr [(String, FilePath)]]
withProgramsFields =
......
......@@ -30,6 +30,7 @@ module Distribution.Client.Sandbox.PackageEnvironment (
import Distribution.Client.Config ( SavedConfig(..), commentSavedConfig
, loadConfig, configFieldDescriptions
, haddockFlagsFields
, installDirsFields, withProgramsFields
, withProgramOptionsFields
, defaultCompiler )
......@@ -42,9 +43,10 @@ import Distribution.Simple.Compiler ( Compiler, PackageDB(..)
import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate
, defaultInstallDirs, combineInstallDirs
, fromPathTemplate, toPathTemplate )
import Distribution.Simple.Setup ( Flag(..), ConfigFlags(..)
import Distribution.Simple.Setup ( Flag(..)
, ConfigFlags(..), HaddockFlags(..)
, fromFlagOrDefault, toFlag, flagToMaybe )
import Distribution.Simple.Utils ( die, info, notice, warn, lowercase )
import Distribution.Simple.Utils ( die, info, notice, warn )
import Distribution.ParseUtils ( FieldDescr(..), ParseResult(..)
, commaListField, commaNewLineListField
, liftField, lineNo, locatedErrorMsg
......@@ -448,15 +450,20 @@ parsePackageEnvironment initial str = do
pkgEnv <- parse others
let config = pkgEnvSavedConfig pkgEnv
installDirs0 = savedUserInstallDirs config
-- 'install-dirs' is the only section that we care about.
(installDirs, paths, args) <- foldM parseSections (installDirs0, [], [])
knownSections
(haddockFlags, installDirs, paths, args) <-
foldM parseSections
(savedHaddockFlags config, installDirs0, [], [])
knownSections
return pkgEnv {
pkgEnvSavedConfig = config {
savedConfigureFlags = (savedConfigureFlags config) {
configProgramPaths = paths,
configProgramArgs = args
},
savedHaddockFlags = haddockFlags {
haddockProgramPaths = paths,
haddockProgramArgs = args
},
savedUserInstallDirs = installDirs,
savedGlobalInstallDirs = installDirs
}
......@@ -464,6 +471,7 @@ parsePackageEnvironment initial str = do
where
isKnownSection :: ParseUtils.Field -> Bool
isKnownSection (ParseUtils.Section _ "haddock" _ _) = True
isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True
isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True
isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True
......@@ -474,27 +482,34 @@ parsePackageEnvironment initial str = do
parseSections :: SectionsAccum -> ParseUtils.Field
-> ParseResult SectionsAccum
parseSections (d,p,a) (ParseUtils.Section line "install-dirs" name fs)
| name' == "" = do d' <- parseFields installDirsFields d fs
return (d',p,a)
| otherwise =
parseSections accum@(h,d,p,a)
(ParseUtils.Section _ "haddock" name fs)
| name == "" = do h' <- parseFields haddockFlagsFields h fs
return (h', d, p, a)
| otherwise = do
warning "The 'haddock' section should be unnamed"
return accum
parseSections (h,d,p,a)
(ParseUtils.Section line "install-dirs" name fs)
| name == "" = do d' <- parseFields installDirsFields d fs
return (h, d',p,a)
| otherwise =
syntaxError line $
"Named 'install-dirs' section: '" ++ name
++ "'. Note that named 'install-dirs' sections are not allowed in the '"
++ userPackageEnvironmentFile ++ "' file."
where name' = lowercase name
parseSections accum@(d,p,a)
parseSections accum@(h, d,p,a)
(ParseUtils.Section _ "program-locations" name fs)
| name == "" = do p' <- parseFields withProgramsFields p fs
return (d, p', a)
| otherwise = do
| name == "" = do p' <- parseFields withProgramsFields p fs
return (h, d, p', a)
| otherwise = do
warning "The 'program-locations' section should be unnamed"
return accum
parseSections accum@(d, p, a)
parseSections accum@(h, d, p, a)
(ParseUtils.Section _ "program-default-options" name fs)
| name == "" = do a' <- parseFields withProgramOptionsFields a fs
return (d, p, a')
| otherwise = do
| name == "" = do a' <- parseFields withProgramOptionsFields a fs
return (h, d, p, a')
| otherwise = do
warning "The 'program-default-options' section should be unnamed"
return accum
parseSections accum f = do
......@@ -502,7 +517,7 @@ parsePackageEnvironment initial str = do
return accum
-- | Accumulator type for 'parseSections'.
type SectionsAccum = (InstallDirs (Flag PathTemplate)
type SectionsAccum = (HaddockFlags, InstallDirs (Flag PathTemplate)
, [(String, FilePath)], [(String, [String])])
-- | Write out the package environment file.
......
......@@ -39,7 +39,7 @@ import Distribution.Client.Setup
, reportCommand
)
import Distribution.Simple.Setup
( HaddockFlags(..), haddockCommand
( HaddockFlags(..), haddockCommand, defaultHaddockFlags
, HscolourFlags(..), hscolourCommand
, ReplFlags(..), replCommand
, CopyFlags(..), copyCommand
......@@ -214,10 +214,9 @@ mainWorker args = topHandler $
,replCommand defaultProgramConfiguration
`commandAddAction` replAction
,sandboxCommand `commandAddAction` sandboxAction
,haddockCommand `commandAddAction` haddockAction
,wrapperAction copyCommand
copyVerbosity copyDistPref
,wrapperAction haddockCommand
haddockVerbosity haddockDistPref
,wrapperAction cleanCommand
cleanVerbosity cleanDistPref
,wrapperAction hscolourCommand
......@@ -636,6 +635,8 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags)
savedConfigureExFlags config `mappend` configExFlags
installFlags' = defaultInstallFlags `mappend`
savedInstallFlags config `mappend` installFlags
haddockFlags' = defaultHaddockFlags `mappend`
savedHaddockFlags config `mappend` haddockFlags
globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, platform, conf) <- configCompilerAux' configFlags'
......@@ -670,7 +671,7 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags)
comp platform conf
useSandbox mSandboxPkgInfo
globalFlags' configFlags'' configExFlags'
installFlags' haddockFlags
installFlags' haddockFlags'
targets
testAction :: (TestFlags, BuildFlags, BuildExFlags) -> [String] -> GlobalFlags
......@@ -735,6 +736,20 @@ benchmarkAction (benchmarkFlags, buildFlags, buildExFlags)
setupWrapper verbosity setupOptions Nothing
Cabal.benchmarkCommand (const benchmarkFlags) extraArgs
haddockAction :: HaddockFlags -> [String] -> GlobalFlags -> IO ()
haddockAction haddockFlags extraArgs globalFlags = do
let verbosity = fromFlag (haddockVerbosity haddockFlags)
(_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty
let haddockFlags' = defaultHaddockFlags `mappend`
savedHaddockFlags config `mappend` haddockFlags
setupScriptOptions = defaultSetupScriptOptions {
useDistPref = fromFlagOrDefault
(useDistPref defaultSetupScriptOptions)
(haddockDistPref haddockFlags')
}
setupWrapper verbosity setupScriptOptions Nothing
haddockCommand (const haddockFlags') extraArgs
listAction :: ListFlags -> [String] -> GlobalFlags -> IO ()
listAction listFlags extraArgs globalFlags = do
let verbosity = fromFlag (listVerbosity listFlags)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment