Commit a1e60565 authored by Matthias Fischmann's avatar Matthias Fischmann

Support new section syntax for remote-repo.

parent 49dba823
{-# LANGUAGE CPP #-}
{-# LANGUAGE ViewPatterns #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Config
......@@ -40,7 +42,7 @@ module Distribution.Client.Config (
) where
import Distribution.Client.Types
( RemoteRepo(..), Username(..), Password(..) )
( RemoteRepo(..), Username(..), Password(..), emptyRemoteRepo )
import Distribution.Client.BuildReports.Types
( ReportLevel(..) )
import Distribution.Client.Setup
......@@ -49,7 +51,7 @@ import Distribution.Client.Setup
, InstallFlags(..), installOptions, defaultInstallFlags
, UploadFlags(..), uploadCommand
, ReportFlags(..), reportCommand
, showRepo, parseRepo )
, showRepo, parseRepo, readRepo )
import Distribution.Utils.NubList
( NubList, fromNubList, toNubList)
......@@ -108,7 +110,7 @@ import Text.PrettyPrint
import System.Directory
( createDirectoryIfMissing, getAppUserDataDirectory, renameFile )
import Network.URI
( URI(..), URIAuth(..) )
( URI(..), URIAuth(..), parseURI )
import System.FilePath
( (<.>), (</>), takeDirectory )
import System.IO.Error
......@@ -124,6 +126,12 @@ import Data.Version
import Data.Char
( isSpace )
import qualified Data.Map as M
import Text.PrettyPrint.HughesPJ
( text )
import Data.Function
( on )
import Data.List
( nubBy )
--
-- * Configuration saved in the config file
......@@ -487,7 +495,7 @@ defaultUserInstall = True
-- global installs on Windows but that no longer works on Windows Vista or 7.
defaultRemoteRepo :: RemoteRepo
defaultRemoteRepo = RemoteRepo name uri
defaultRemoteRepo = RemoteRepo name uri ()
where
name = "hackage.haskell.org"
uri = URI "http:" (Just (URIAuth "" name "")) "/" "" ""
......@@ -771,11 +779,16 @@ parseConfig initial = \str -> do
config <- parse others
let user0 = savedUserInstallDirs config
global0 = savedGlobalInstallDirs config
(haddockFlags, user, global, paths, args) <-
compileRemoteRepos = reverse . nubBy ((==) `on` remoteRepoName)
(compileRemoteRepos -> remoteRepoSections, haddockFlags, user, global, paths, args) <-
foldM parseSections
(savedHaddockFlags config, user0, global0, [], [])
([], savedHaddockFlags config, user0, global0, [], [])
knownSections
return config {
savedGlobalFlags = (savedGlobalFlags config) {
globalRemoteRepos = toNubList remoteRepoSections
},
savedConfigureFlags = (savedConfigureFlags config) {
configProgramPaths = paths,
configProgramArgs = args
......@@ -786,6 +799,8 @@ parseConfig initial = \str -> do
}
where
isKnownSection (ParseUtils.Section _ "remote-repo" _ _) = True
isKnownSection (ParseUtils.F _ "remote-repo" _) = True
isKnownSection (ParseUtils.Section _ "haddock" _ _) = True
isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True
isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True
......@@ -795,34 +810,45 @@ parseConfig initial = \str -> do
parse = parseFields (configFieldDescriptions
++ deprecatedFieldDescriptions) initial
parseSections accum@(h,u,g,p,a)
parseSections (rs, h, u, g, p, a)
(ParseUtils.Section _ "remote-repo" name fs) = do
r' <- parseFields remoteRepoFields (emptyRemoteRepo name) fs
return (r':rs, h, u, g, p, a)
parseSections (rs, h, u, g, p, a)
(ParseUtils.F lno "remote-repo" raw) = do
let mr' = readRepo raw
r' <- maybe (ParseFailed $ NoParse "remote-repo" lno) return mr'
return (r':rs, h, u, g, p, a)
parseSections accum@(rs, h, u, g, p, a)
(ParseUtils.Section _ "haddock" name fs)
| name == "" = do h' <- parseFields haddockFlagsFields h fs
return (h', u, g, p, a)
return (rs, h', u, g, p, a)
| otherwise = do
warning "The 'haddock' section should be unnamed"
return accum
parseSections accum@(h,u,g,p,a)
parseSections accum@(rs, h, u, g, p, a)
(ParseUtils.Section _ "install-dirs" name fs)
| name' == "user" = do u' <- parseFields installDirsFields u fs
return (h, u', g, p, a)
return (rs, h, u', g, p, a)
| name' == "global" = do g' <- parseFields installDirsFields g fs
return (h, u, g', p, a)
return (rs, 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@(h,u,g,p,a)
parseSections accum@(rs, h, u, g, p, a)
(ParseUtils.Section _ "program-locations" name fs)
| name == "" = do p' <- parseFields withProgramsFields p fs
return (h, u, g, p', a)
return (rs, h, u, g, p', a)
| otherwise = do
warning "The 'program-locations' section should be unnamed"
return accum
parseSections accum@(h, u, g, p, a)
parseSections accum@(rs, h, u, g, p, a)
(ParseUtils.Section _ "program-default-options" name fs)
| name == "" = do a' <- parseFields withProgramOptionsFields a fs
return (h, u, g, p, a')
return (rs, h, u, g, p, a')
| otherwise = do
warning "The 'program-default-options' section should be unnamed"
return accum
......@@ -863,6 +889,17 @@ showConfigWithComments comment vals = Disp.render $
installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))]
installDirsFields = map viewAsFieldDescr installDirsOptions
remoteRepoFields :: [FieldDescr RemoteRepo]
remoteRepoFields =
[ FieldDescr { fieldName = "url",
fieldGet = text . show . remoteRepoURI,
fieldSet = \ _ uriString remoteRepo -> maybe
(fail $ "remote-repo: no parse on " ++ show uriString)
(\ uri -> return $ remoteRepo { remoteRepoURI = uri })
(parseURI uriString)
}
]
-- | Fields for the 'haddock' section.
haddockFlagsFields :: [FieldDescr HaddockFlags]
haddockFlagsFields = [ field
......
......@@ -43,6 +43,7 @@ module Distribution.Client.Setup
--TODO: stop exporting these:
, showRepo
, parseRepo
, readRepo
) where
import Distribution.Client.Types
......@@ -2148,8 +2149,9 @@ parseRepo = do
uriStr <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?~")
uri <- maybe Parse.pfail return (parseAbsoluteURI uriStr)
return $ RemoteRepo {
remoteRepoName = name,
remoteRepoURI = uri
remoteRepoName = name,
remoteRepoURI = uri,
remoteRepoRootKeys = ()
}
-- ------------------------------------------------------------
......
......@@ -235,12 +235,21 @@ data PackageLocation local =
data LocalRepo = LocalRepo
deriving (Show,Eq)
data RemoteRepo = RemoteRepo {
remoteRepoName :: String,
remoteRepoURI :: URI
}
data RemoteRepo =
RemoteRepo {
remoteRepoName :: String,
remoteRepoURI :: URI,
remoteRepoRootKeys :: ()
}
-- FIXME: discuss this type some more.
deriving (Show,Eq,Ord)
-- | Construct a partial 'RemoteRepo' value to fold the field parser list over.
emptyRemoteRepo :: String -> RemoteRepo
emptyRemoteRepo name = RemoteRepo name (error "RemoteRepo: empty URI!") ()
data Repo = Repo {
repoKind :: Either RemoteRepo LocalRepo,
repoLocalDir :: FilePath
......
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