Unverified Commit 4f95a629 authored by Alex Biehl's avatar Alex Biehl Committed by GitHub
Browse files

Merge pull request #7084 from alexbiehl/alex/proj-constraint-source

Propagate provenance when parsing ProjectConfig
parents 9e6b7f3a efa1e3f1
......@@ -572,7 +572,7 @@ readProjectFile verbosity DistDirLayout{distProjectFile}
readExtensionFile =
reportParseResult verbosity extensionDescription extensionFile
. parseProjectConfig
. (parseProjectConfig extensionFile)
=<< BS.readFile extensionFile
addProjectFileProvenance config =
......@@ -587,10 +587,10 @@ readProjectFile verbosity DistDirLayout{distProjectFile}
-- For the moment this is implemented in terms of parsers for legacy
-- configuration types, plus a conversion.
--
parseProjectConfig :: BS.ByteString -> OldParser.ParseResult ProjectConfig
parseProjectConfig content =
parseProjectConfig :: FilePath -> BS.ByteString -> OldParser.ParseResult ProjectConfig
parseProjectConfig source content =
convertLegacyProjectConfig <$>
parseLegacyProjectConfig content
(parseLegacyProjectConfig source content)
-- | Render the 'ProjectConfig' format.
......
......@@ -83,7 +83,7 @@ import qualified Distribution.Deprecated.ParseUtils as ParseUtils
import Distribution.Deprecated.ParseUtils
( ParseResult(..), PError(..), syntaxError, PWarning(..)
, commaNewLineListFieldParsec, newLineListField, parseTokenQ
, parseHaskellString, showToken
, parseHaskellString, showToken
, simpleFieldParsec
)
import Distribution.Client.ParseUtils
......@@ -844,26 +844,33 @@ convertToLegacyPerPackageConfig PackageConfig {..} =
-- Parsing and showing the project config file
--
parseLegacyProjectConfig :: BS.ByteString -> ParseResult LegacyProjectConfig
parseLegacyProjectConfig =
parseConfig legacyProjectConfigFieldDescrs
parseLegacyProjectConfig :: FilePath -> BS.ByteString -> ParseResult LegacyProjectConfig
parseLegacyProjectConfig source =
parseConfig (legacyProjectConfigFieldDescrs constraintSrc)
legacyPackageConfigSectionDescrs
legacyPackageConfigFGSectionDescrs
mempty
where
constraintSrc = ConstraintSourceProjectConfig source
showLegacyProjectConfig :: LegacyProjectConfig -> String
showLegacyProjectConfig config =
Disp.render $
showConfig legacyProjectConfigFieldDescrs
showConfig (legacyProjectConfigFieldDescrs constraintSrc)
legacyPackageConfigSectionDescrs
legacyPackageConfigFGSectionDescrs
config
$+$
Disp.text ""
where
-- Note: ConstraintSource is unused when pretty-printing. We fake
-- it here to avoid having to pass it on call-sites. It's not great
-- but requires re-work of how we annotate provenance.
constraintSrc = ConstraintSourceProjectConfig "unused"
legacyProjectConfigFieldDescrs :: [FieldDescr LegacyProjectConfig]
legacyProjectConfigFieldDescrs =
legacyProjectConfigFieldDescrs :: ConstraintSource -> [FieldDescr LegacyProjectConfig]
legacyProjectConfigFieldDescrs constraintSrc =
[ newLineListField "packages"
(Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ
......@@ -882,7 +889,7 @@ legacyProjectConfigFieldDescrs =
++ map (liftField
legacySharedConfig
(\flags conf -> conf { legacySharedConfig = flags }))
legacySharedConfigFieldDescrs
(legacySharedConfigFieldDescrs constraintSrc)
++ map (liftField
legacyLocalConfig
......@@ -941,8 +948,8 @@ renderPackageLocationToken s | needsQuoting = show s
ok n (_ :cs) = ok n cs
legacySharedConfigFieldDescrs :: [FieldDescr LegacySharedConfig]
legacySharedConfigFieldDescrs = concat
legacySharedConfigFieldDescrs :: ConstraintSource -> [FieldDescr LegacySharedConfig]
legacySharedConfigFieldDescrs constraintSrc = concat
[ liftFields
legacyGlobalFlags
(\flags conf -> conf { legacyGlobalFlags = flags })
......@@ -1033,8 +1040,6 @@ legacySharedConfigFieldDescrs = concat
$ projectFlagsOptions ParseArgs
]
where
constraintSrc = ConstraintSourceProjectConfig "TODO" -- TODO: is a filepath
legacyPackageConfigFieldDescrs :: [FieldDescr LegacyPackageConfig]
......
......@@ -158,7 +158,7 @@ prop_roundtrip_legacytypes_specific config =
roundtrip_printparse :: ProjectConfig -> Property
roundtrip_printparse config =
case fmap convertLegacyProjectConfig (parseLegacyProjectConfig (toUTF8BS str)) of
case fmap convertLegacyProjectConfig (parseLegacyProjectConfig "unused" (toUTF8BS str)) of
ParseOk _ x -> counterexample ("shown:\n" ++ str) $
x `ediffEq` config { projectConfigProvenance = mempty }
ParseFailed err -> counterexample ("shown:\n" ++ str ++ "\nERROR: " ++ show err) False
......@@ -275,7 +275,7 @@ prop_roundtrip_printparse_RelaxDeps rdep =
prop_roundtrip_printparse_RelaxDeps' :: RelaxDeps -> Property
prop_roundtrip_printparse_RelaxDeps' rdep =
counterexample rdep' $
Right rdep `ediffEq` eitherParsec rdep'
Right rdep `ediffEq` eitherParsec rdep'
where
rdep' = go (prettyShow rdep)
......@@ -522,7 +522,7 @@ instance Arbitrary ProjectConfigShared where
projectConfigConstraintSource :: ConstraintSource
projectConfigConstraintSource =
ConstraintSourceProjectConfig "TODO"
ConstraintSourceProjectConfig "unused"
instance Arbitrary ProjectConfigProvenance where
arbitrary = elements [Implicit, Explicit "cabal.project"]
......
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