Commit 63e9d34a authored by refold's avatar refold
Browse files

parsePkgEnv: parsing of the install-dirs section.

parent eb958ae2
......@@ -25,7 +25,8 @@ module Distribution.Client.Config (
defaultLogsDir,
baseSavedConfig,
configFieldDescriptions
configFieldDescriptions,
installDirsFields
) where
......
......@@ -11,30 +11,38 @@
module Distribution.Client.PkgEnv (dumpPkgEnv)
where
import Distribution.Client.Config ( SavedConfig(..), baseSavedConfig,
configFieldDescriptions )
import Distribution.Client.ParseUtils ( ppFields )
import Distribution.Client.Setup ( SandboxFlags(..) )
import Distribution.Simple.Setup ( Flag(..), fromFlagOrDefault, toFlag )
import Distribution.Simple.Utils ( notice, warn )
import Distribution.ParseUtils ( FieldDescr(..), ParseResult(..),
parseFilePathQ, parseFields,
liftField, simpleField )
import Distribution.Verbosity ( Verbosity )
import Data.Monoid ( Monoid(..) )
import Distribution.Compat.Exception ( catchIO )
import System.Directory ( createDirectoryIfMissing, renameFile )
import System.FilePath ( (<.>), takeDirectory )
import System.IO.Error ( isDoesNotExistError )
import Distribution.Client.Config ( SavedConfig(..), baseSavedConfig,
configFieldDescriptions,
installDirsFields )
import Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection )
import Distribution.Client.Setup ( SandboxFlags(..) )
import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate )
import Distribution.Simple.Setup ( Flag(..), fromFlagOrDefault, toFlag )
import Distribution.Simple.Utils ( notice, warn, lowercase )
import Distribution.ParseUtils ( FieldDescr(..), ParseResult(..),
liftField, lineNo,
parseFilePathQ, readFields,
showPWarning, simpleField, warning )
import Distribution.Verbosity ( Verbosity )
import Control.Monad ( foldM, when )
import Data.List ( partition )
import Data.Monoid ( Monoid(..) )
import Distribution.Compat.Exception ( catchIO )
import System.Directory ( createDirectoryIfMissing, renameFile )
import System.FilePath ( (<.>), takeDirectory )
import System.IO.Error ( isDoesNotExistError )
import Text.PrettyPrint ( ($+$) )
import qualified Text.PrettyPrint as Disp
import qualified Distribution.Compat.ReadP as Parse
import qualified Distribution.ParseUtils as ParseUtils ( Field(..) )
--
-- * Configuration saved in the package environment file
--
-- TODO: install-dirs section, constraints field, sensible defaults
-- TODO: constraints field, sensible defaults, loadPkgEnv function,
-- remove duplication between D.C.PkgEnv and D.C.Config
data PkgEnv = PkgEnv {
pkgEnvInherit :: Flag FilePath,
pkgEnvSavedConfig :: SavedConfig
......@@ -70,9 +78,11 @@ dumpPkgEnv verbosity sandboxFlags path = do
Just (ParseFailed err)
-> warn verbosity $ "Failed to parse file '" ++ path ++ "'."
Just (ParseOk warns pkgEnv)
-> do base <- basePkgEnv
-> do when (not $ null warns) $ warn verbosity $
unlines (map (showPWarning path) warns)
base <- basePkgEnv
let pkgEnv' = base `mappend` pkgEnv
putStrLn . showPkgEnvWithComments base $ mempty
putStrLn . showPkgEnvWithComments base $ pkgEnv'
-- | Descriptions of all fields in the package environment file.
pkgEnvFieldDescrs :: [FieldDescr PkgEnv]
......@@ -103,7 +113,41 @@ readPkgEnvFile initial file = handleNotExists $
-- | Parse the package environment file.
parsePkgEnv :: PkgEnv -> String -> ParseResult PkgEnv
parsePkgEnv initial str = parseFields pkgEnvFieldDescrs initial str
parsePkgEnv initial str = do
fields <- readFields str
let (knownSections, others) = partition isKnownSection fields
pkgEnv <- parse others
let config = pkgEnvSavedConfig pkgEnv
installDirs0 = savedUserInstallDirs config
installDirs <- foldM parseSection installDirs0 knownSections
return pkgEnv {
pkgEnvSavedConfig = config {
savedUserInstallDirs = installDirs,
savedGlobalInstallDirs = installDirs
}
}
where
isKnownSection :: ParseUtils.Field -> Bool
isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True
isKnownSection _ = False
parse :: [ParseUtils.Field] -> ParseResult PkgEnv
parse = parseFields pkgEnvFieldDescrs initial
parseSection :: InstallDirs (Flag PathTemplate)
-> ParseUtils.Field
-> ParseResult (InstallDirs (Flag PathTemplate))
parseSection accum (ParseUtils.Section _ "install-dirs" name fs)
| name' == "" = do accum' <- parseFields installDirsFields accum fs
return accum'
| otherwise = do warning "The install-dirs section should be unnamed"
return accum
where name' = lowercase name
parseSection accum f = do
warning $ "Unrecognized stanza on line " ++ show (lineNo f)
return accum
-- | Write out the package environment file.
writePkgEnvFile :: FilePath -> PkgEnv -> IO ()
......@@ -118,6 +162,10 @@ showPkgEnv :: PkgEnv -> String
showPkgEnv = showPkgEnvWithComments mempty
showPkgEnvWithComments :: PkgEnv -> PkgEnv -> String
showPkgEnvWithComments defPkgEnv pkgEnv =
Disp.render $
ppFields pkgEnvFieldDescrs defPkgEnv pkgEnv
showPkgEnvWithComments defPkgEnv pkgEnv = Disp.render $
ppFields pkgEnvFieldDescrs defPkgEnv pkgEnv
$+$ Disp.text ""
$+$ ppSection "install-dirs" "" installDirsFields
(field defPkgEnv) (field pkgEnv)
where
field = savedUserInstallDirs . pkgEnvSavedConfig
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