Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal On branch : master
http://hackage.haskell.org/trac/ghc/changeset/53f961a44b4c87a5e0d6c76da47d167f52f4e191 >--------------------------------------------------------------- commit 53f961a44b4c87a5e0d6c76da47d167f52f4e191 Author: Duncan Coutts <[email protected]> Date: Fri Aug 22 12:00:59 2008 +0000 Add sections for user/global install-dirs to the config file So it looks like: install-dirs user prefix: /home/username/.cabal ... Rather than using user-prefix, global-prefix, etc etc for each field. The old field names are still recognised but not added into the initial config file. >--------------------------------------------------------------- cabal-install/Distribution/Client/Config.hs | 63 +++++++++++++++++++++----- 1 files changed, 51 insertions(+), 12 deletions(-) diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs index 2b47bbf..16c0ce0 100644 --- a/cabal-install/Distribution/Client/Config.hs +++ b/cabal-install/Distribution/Client/Config.hs @@ -53,7 +53,7 @@ import Distribution.Simple.Command import Distribution.Simple.Program ( defaultProgramConfiguration ) import Distribution.Simple.Utils - ( notice, warn ) + ( notice, warn, lowercase ) import Distribution.Compiler ( CompilerFlavor(..), defaultCompilerFlavor ) import Distribution.System @@ -61,6 +61,8 @@ import Distribution.System import Distribution.Verbosity ( Verbosity, normal ) +import Data.List + ( partition ) import Data.Maybe ( fromMaybe ) import Data.Monoid @@ -71,9 +73,9 @@ import qualified Data.Map as Map import qualified Distribution.Compat.ReadP as Parse ( option ) import qualified Text.PrettyPrint.HughesPJ as Disp - ( Doc, render, text, colon, vcat, isEmpty ) + ( Doc, render, text, colon, vcat, isEmpty, nest ) import Text.PrettyPrint.HughesPJ - ( (<>), (<+>) ) + ( (<>), (<+>), ($$), ($+$) ) import System.Directory ( createDirectoryIfMissing, getAppUserDataDirectory ) import Network.URI @@ -342,23 +344,58 @@ liftUploadFlag = liftField savedUploadFlags (\flags conf -> conf { savedUploadFlags = flags }) parseConfig :: SavedConfig -> String -> ParseResult SavedConfig -parseConfig = parseFields (configFieldDescriptions - ++ deprecatedFieldDescriptions) +parseConfig initial = \str -> do + fields <- readFields str + let (knownSections, others) = partition isKnownSection fields + config <- parse others + (user, global) <- foldM parseSections (mempty, mempty) knownSections + return config { + savedUserInstallDirs = user, + savedGlobalInstallDirs = global + } + + where + isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True + isKnownSection _ = False + + parse = parseFields (configFieldDescriptions + ++ deprecatedFieldDescriptions) initial + + parseSections accum@(u,g) (ParseUtils.Section _ "install-dirs" name fs) + | name' == "user" = do u' <- parseFields installDirsFields u fs + return (u', g) + | name' == "global" = do g' <- parseFields installDirsFields g fs + return (u, g') + | otherwise = do + warning "The install-paths section should be for 'user' or 'global'" + return accum + where name' = lowercase name + parseSections accum f = do + warning $ "Unrecognized stanza on line " ++ show (lineNo f) + return accum showConfig :: SavedConfig -> String -showConfig = showFields configFieldDescriptions mempty +showConfig = showConfigWithComments mempty showConfigWithComments :: SavedConfig -> SavedConfig -> String -showConfigWithComments = showFields configFieldDescriptions - +showConfigWithComments comment vals = Disp.render $ + ppFields configFieldDescriptions comment vals + $+$ Disp.text "" + $+$ installDirsSection "user" savedUserInstallDirs + $+$ Disp.text "" + $+$ installDirsSection "global" savedGlobalInstallDirs + where + installDirsSection name field = + ppSection "install-dirs" name installDirsFields + (field comment) (field vals) ------------------------ -- * Parsing utils -- --FIXME: replace this with something better in Cabal-1.5 -parseFields :: [FieldDescr a] -> a -> String -> ParseResult a -parseFields fields initial = \str -> readFields str >>= foldM setField initial +parseFields :: [FieldDescr a] -> a -> [ParseUtils.Field] -> ParseResult a +parseFields fields initial = foldM setField initial where fieldMap = Map.fromList [ (name, f) | f@(FieldDescr name _ _) <- fields ] @@ -383,8 +420,10 @@ ppField name def cur | Disp.isEmpty cur = Disp.text "--" <+> Disp.text name <> Disp.colon <+> def | otherwise = Disp.text name <> Disp.colon <+> cur -showFields :: [FieldDescr a] -> a -> a -> String -showFields fields def = Disp.render . ppFields fields def +ppSection :: String -> String -> [FieldDescr a] -> a -> a -> Disp.Doc +ppSection name arg fields def cur = + Disp.text name <+> Disp.text arg + $$ Disp.nest 2 (ppFields fields def cur) installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))] installDirsFields = map viewAsFieldDescr installDirsOptions _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
