@@ -5,16 +5,29 @@ module IntegrationTests2.ProjectConfig.ParsecTests (parserTests) where
5
5
6
6
import qualified Data.ByteString as BS
7
7
import Data.Either
8
- import Distribution.Client.BuildReports.Types
8
+ import Data.Maybe
9
+ import Distribution.Client.Dependency.Types (PreSolver (.. ))
9
10
import Distribution.Client.DistDirLayout
10
11
import Distribution.Client.HttpUtils
12
+ import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepoEntry (.. ), ActiveRepos (.. ), CombineStrategy (.. ))
13
+ import Distribution.Client.IndexUtils.IndexState (RepoIndexState (.. ), headTotalIndexState , insertIndexState )
11
14
import Distribution.Client.ProjectConfig
12
15
import Distribution.Client.ProjectConfig.Parsec
13
16
import Distribution.Client.RebuildMonad (runRebuild )
17
+ import Distribution.Client.Targets (readUserConstraint )
18
+ import Distribution.Client.Types.AllowNewer (AllowNewer (.. ), AllowOlder (.. ), RelaxDepMod (.. ), RelaxDepScope (.. ), RelaxDepSubject (.. ), RelaxDeps (.. ), RelaxedDep (.. ))
19
+ import Distribution.Client.Types.RepoName (RepoName (.. ))
14
20
import Distribution.Client.Types.SourceRepo
21
+ import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy (WriteGhcEnvironmentFilesPolicy (.. ))
22
+ import Distribution.Compiler (CompilerFlavor (.. ))
23
+ import Distribution.Parsec (simpleParsec )
24
+ import Distribution.Simple.Compiler (PackageDB (.. ))
15
25
import Distribution.Simple.Flag
16
26
import Distribution.Simple.InstallDirs (toPathTemplate )
27
+ import Distribution.Solver.Types.ConstraintSource (ConstraintSource (.. ))
28
+ import Distribution.Solver.Types.Settings (AllowBootLibInstalls (.. ), CountConflicts (.. ), FineGrainedConflicts (.. ), MinimizeConflictSet (.. ), PreferOldest (.. ), ReorderGoals (.. ), StrongFlags (.. ))
17
29
import Distribution.Types.CondTree (CondTree (.. ))
30
+ import Distribution.Types.PackageId (PackageIdentifier (.. ))
18
31
import Distribution.Types.PackageName
19
32
import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (.. ))
20
33
import Distribution.Types.SourceRepo (KnownRepoType (.. ), RepoType (.. ))
@@ -37,6 +50,7 @@ parserTests =
37
50
, testCase " read extra-packages" testExtraPackages
38
51
, testCase " read source-repository-package" testSourceRepoList
39
52
, testCase " read project-config-build-only" testProjectConfigBuildOnly
53
+ , testCase " read project-shared" testProjectConfigShared
40
54
]
41
55
42
56
testPackages :: Assertion
@@ -110,6 +124,70 @@ testProjectConfigBuildOnly = do
110
124
projectConfigLogsDir = toFlag " logs-directory"
111
125
projectConfigClientInstallFlags = mempty -- cli only
112
126
127
+ testProjectConfigShared :: Assertion
128
+ testProjectConfigShared = do
129
+ let rootFp = " project-config-shared"
130
+ projectFileFp <- projectConfigPath rootFp " cabal.project" " "
131
+ let
132
+ projectConfigConstraints = getProjectConfigConstraints projectFileFp
133
+ expected = ProjectConfigShared {.. }
134
+ (config, legacy) <- readConfigDefault rootFp
135
+ print (projectConfigShared $ condTreeData legacy)
136
+ assertConfig expected config legacy (projectConfigShared . condTreeData)
137
+ where
138
+ projectConfigDistDir = mempty -- cli only
139
+ projectConfigConfigFile = mempty -- cli only
140
+ projectConfigProjectDir = mempty -- cli only
141
+ projectConfigProjectFile = mempty -- cli only
142
+ projectConfigIgnoreProject = toFlag True
143
+ projectConfigHcFlavor = toFlag GHCJS
144
+ projectConfigHcPath = toFlag " /some/path/to/compiler"
145
+ projectConfigHcPkg = toFlag " /some/path/to/ghc-pkg"
146
+ projectConfigHaddockIndex = toFlag $ toPathTemplate " /path/to/haddock-index"
147
+ projectConfigInstallDirs = mempty -- cli only
148
+ projectConfigPackageDBs = [Nothing , Just (SpecificPackageDB " foo" ), Nothing , Just (SpecificPackageDB " bar" ), Just (SpecificPackageDB " baz" )]
149
+ projectConfigRemoteRepos = mempty -- cli only
150
+ projectConfigLocalNoIndexRepos = mempty -- cli only
151
+ projectConfigActiveRepos = Flag (ActiveRepos [ActiveRepo (RepoName " hackage.haskell.org" ) CombineStrategyMerge , ActiveRepo (RepoName " my-repository" ) CombineStrategyOverride ])
152
+ projectConfigIndexState =
153
+ let
154
+ hackageState = IndexStateTime $ fromJust $ simpleParsec " 2020-05-06T22:33:27Z"
155
+ indexState' = insertIndexState (RepoName " hackage.haskell.org" ) hackageState headTotalIndexState
156
+ headHackageState = IndexStateTime $ fromJust $ simpleParsec " 2020-04-29T04:11:05Z"
157
+ indexState'' = insertIndexState (RepoName " head.hackage" ) headHackageState headTotalIndexState
158
+ in
159
+ toFlag indexState''
160
+ projectConfigStoreDir = mempty -- cli only
161
+ getProjectConfigConstraints projectFileFp =
162
+ let
163
+ bar = fromRight (error " error parsing bar" ) $ readUserConstraint " bar == 2.1"
164
+ barFlags = fromRight (error " error parsing bar flags" ) $ readUserConstraint " bar +foo -baz"
165
+ source = ConstraintSourceProjectConfig projectFileFp
166
+ in
167
+ [(bar, source), (barFlags, source)]
168
+ projectConfigPreferences = [PackageVersionConstraint (mkPackageName " foo" ) (ThisVersion (mkVersion [0 , 9 ])), PackageVersionConstraint (mkPackageName " baz" ) (LaterVersion (mkVersion [2 , 0 ]))]
169
+ projectConfigCabalVersion = Flag (mkVersion [1 , 24 , 0 , 1 ])
170
+ projectConfigSolver = Flag AlwaysModular
171
+ projectConfigAllowOlder = Just (AllowOlder $ RelaxDepsSome [RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName " dep" )), RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName " pkga" ) (mkVersion [1 , 1 , 2 ]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName " dep-pkg" ))])
172
+ projectConfigAllowNewer = Just (AllowNewer $ RelaxDepsSome [RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName " pkgb" ) (mkVersion [1 , 2 , 3 ]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName " dep-pkgb" )), RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName " importantlib" ))])
173
+ projectConfigWriteGhcEnvironmentFilesPolicy = Flag AlwaysWriteGhcEnvironmentFiles
174
+ projectConfigMaxBackjumps = toFlag 42
175
+ projectConfigReorderGoals = Flag (ReorderGoals True )
176
+ projectConfigCountConflicts = Flag (CountConflicts False )
177
+ projectConfigFineGrainedConflicts = Flag (FineGrainedConflicts False )
178
+ projectConfigMinimizeConflictSet = Flag (MinimizeConflictSet True )
179
+ projectConfigStrongFlags = Flag (StrongFlags True )
180
+ projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls True )
181
+ projectConfigOnlyConstrained = mempty -- cli only
182
+ projectConfigPerComponent = mempty -- cli only
183
+ projectConfigIndependentGoals = mempty -- cli only
184
+ projectConfigPreferOldest = Flag (PreferOldest True )
185
+ projectConfigProgPathExtra = mempty
186
+ -- TODO ^ I need to investigate this. The config says the following: extra-prog-path: /foo/bar, /baz/quux
187
+ -- but the legacy parser always parses an empty list, maybe we have a bug here
188
+ -- this also does not work if using a single path such as extra-prog-path: /foo/bar, list is always empty
189
+ projectConfigMultiRepl = toFlag True
190
+
113
191
readConfigDefault :: FilePath -> IO (ProjectConfigSkeleton , ProjectConfigSkeleton )
114
192
readConfigDefault rootFp = readConfig rootFp " cabal.project"
115
193
@@ -121,7 +199,7 @@ readConfig rootFp projectFileName = do
121
199
extensionName = " "
122
200
distDirLayout = defaultDistDirLayout projectRoot Nothing Nothing
123
201
extensionDescription = " description"
124
- distProjectConfigFp = distProjectFile distDirLayout extensionName
202
+ distProjectConfigFp <- projectConfigPath rootFp projectFileName extensionName
125
203
exists <- doesFileExist distProjectConfigFp
126
204
assertBool (" projectConfig does not exist: " <> distProjectConfigFp) exists
127
205
contents <- BS. readFile distProjectConfigFp
@@ -134,6 +212,14 @@ readConfig rootFp projectFileName = do
134
212
readProjectFileSkeletonLegacy verbosity httpTransport distDirLayout extensionName extensionDescription
135
213
return (parsec, legacy)
136
214
215
+ projectConfigPath :: FilePath -> FilePath -> String -> IO FilePath
216
+ projectConfigPath rootFp projectFileName extensionName = do
217
+ projectRootDir <- canonicalizePath (basedir </> rootFp)
218
+ let projectRoot = ProjectRootExplicit projectRootDir projectFileName
219
+ distDirLayout = defaultDistDirLayout projectRoot Nothing Nothing
220
+ distProjectConfigFp = distProjectFile distDirLayout extensionName
221
+ return distProjectConfigFp
222
+
137
223
assertConfig' :: (Eq a , Show a ) => a -> ProjectConfigSkeleton -> (ProjectConfigSkeleton -> a ) -> IO ()
138
224
assertConfig' expected config access = expected @=? actual
139
225
where
0 commit comments