1{-# LANGUAGE CPP #-} 2{-# LANGUAGE BangPatterns #-} 3{-# LANGUAGE DeriveDataTypeable #-} 4{-# LANGUAGE RankNTypes #-} 5{-# LANGUAGE ScopedTypeVariables #-} 6{-# LANGUAGE OverloadedStrings #-} 7 8-- For the handy instance IsString PackageIdentifier 9{-# OPTIONS_GHC -fno-warn-orphans #-} 10 11module Main where 12 13import Distribution.Client.Compat.Prelude 14import Prelude () 15 16import Distribution.Client.DistDirLayout 17import Distribution.Client.ProjectConfig 18import Distribution.Client.Config (getCabalDir) 19import Distribution.Client.TargetSelector hiding (DirActions(..)) 20import qualified Distribution.Client.TargetSelector as TS (DirActions(..)) 21import Distribution.Client.ProjectPlanning 22import Distribution.Client.ProjectPlanning.Types 23import Distribution.Client.ProjectBuilding 24import Distribution.Client.ProjectOrchestration 25 ( resolveTargets, distinctTargetComponents ) 26import Distribution.Client.TargetProblem 27 ( TargetProblem', TargetProblem (..) ) 28import Distribution.Client.Types 29 ( PackageLocation(..), UnresolvedSourcePackage 30 , PackageSpecifier(..) ) 31import Distribution.Client.Targets 32 ( UserConstraint(..), UserConstraintScope(UserAnyQualifier) ) 33import qualified Distribution.Client.InstallPlan as InstallPlan 34import Distribution.Solver.Types.SourcePackage as SP 35import Distribution.Solver.Types.ConstraintSource 36 ( ConstraintSource(ConstraintSourceUnknown) ) 37import Distribution.Solver.Types.PackageConstraint 38 ( PackageProperty(PackagePropertySource) ) 39 40import qualified Distribution.Client.CmdBuild as CmdBuild 41import qualified Distribution.Client.CmdRepl as CmdRepl 42import qualified Distribution.Client.CmdRun as CmdRun 43import qualified Distribution.Client.CmdTest as CmdTest 44import qualified Distribution.Client.CmdBench as CmdBench 45import qualified Distribution.Client.CmdHaddock as CmdHaddock 46 47import Distribution.Package 48import Distribution.PackageDescription 49import Distribution.InstalledPackageInfo (InstalledPackageInfo) 50import Distribution.Simple.Setup (toFlag, HaddockFlags(..), defaultHaddockFlags) 51import Distribution.Simple.Compiler 52import Distribution.System 53import Distribution.Version 54import Distribution.ModuleName (ModuleName) 55import Distribution.Text 56 57import qualified Data.Map as Map 58import qualified Data.Set as Set 59import Control.Monad 60import Control.Concurrent (threadDelay) 61import Control.Exception hiding (assert) 62import System.FilePath 63import System.Directory 64import System.IO (hPutStrLn, stderr) 65 66import Test.Tasty 67import Test.Tasty.HUnit 68import Test.Tasty.Options 69import Data.Tagged (Tagged(..)) 70 71import qualified Data.ByteString as BS 72 73#if !MIN_VERSION_directory(1,2,7) 74removePathForcibly :: FilePath -> IO () 75removePathForcibly = removeDirectoryRecursive 76#endif 77 78main :: IO () 79main = 80 defaultMainWithIngredients 81 (defaultIngredients ++ [includingOptions projectConfigOptionDescriptions]) 82 (withProjectConfig $ \config -> 83 testGroup "Integration tests (internal)" 84 (tests config)) 85 86 87tests :: ProjectConfig -> [TestTree] 88tests config = 89 --TODO: tests for: 90 -- * normal success 91 -- * dry-run tests with changes 92 [ testGroup "Discovery and planning" $ 93 [ testCase "find root" testFindProjectRoot 94 , testCase "find root fail" testExceptionFindProjectRoot 95 , testCase "no package" (testExceptionInFindingPackage config) 96 , testCase "no package2" (testExceptionInFindingPackage2 config) 97 , testCase "proj conf1" (testExceptionInProjectConfig config) 98 ] 99 , testGroup "Target selectors" $ 100 [ testCaseSteps "valid" testTargetSelectors 101 , testCase "bad syntax" testTargetSelectorBadSyntax 102 , testCaseSteps "ambiguous syntax" testTargetSelectorAmbiguous 103 , testCase "no current pkg" testTargetSelectorNoCurrentPackage 104 , testCase "no targets" testTargetSelectorNoTargets 105 , testCase "project empty" testTargetSelectorProjectEmpty 106 , testCase "problems (common)" (testTargetProblemsCommon config) 107 , testCaseSteps "problems (build)" (testTargetProblemsBuild config) 108 , testCaseSteps "problems (repl)" (testTargetProblemsRepl config) 109 , testCaseSteps "problems (run)" (testTargetProblemsRun config) 110 , testCaseSteps "problems (test)" (testTargetProblemsTest config) 111 , testCaseSteps "problems (bench)" (testTargetProblemsBench config) 112 , testCaseSteps "problems (haddock)" (testTargetProblemsHaddock config) 113 ] 114 , testGroup "Exceptions during building (local inplace)" $ 115 [ testCase "configure" (testExceptionInConfigureStep config) 116 , testCase "build" (testExceptionInBuildStep config) 117-- , testCase "register" testExceptionInRegisterStep 118 ] 119 --TODO: need to repeat for packages for the store 120 --TODO: need to check we can build sub-libs, foreign libs and exes 121 -- components for non-local packages / packages in the store. 122 123 , testGroup "Successful builds" $ 124 [ testCaseSteps "Setup script styles" (testSetupScriptStyles config) 125 , testCase "keep-going" (testBuildKeepGoing config) 126#ifndef mingw32_HOST_OS 127 -- disabled because https://github.com/haskell/cabal/issues/6272 128 , testCase "local tarball" (testBuildLocalTarball config) 129#endif 130 ] 131 132 , testGroup "Regression tests" $ 133 [ testCase "issue #3324" (testRegressionIssue3324 config) 134 ] 135 ] 136 137 138testFindProjectRoot :: Assertion 139testFindProjectRoot = do 140 Left (BadProjectRootExplicitFile file) <- findProjectRoot (Just testdir) 141 (Just testfile) 142 file @?= testfile 143 where 144 testdir = basedir </> "exception" </> "no-pkg2" 145 testfile = "bklNI8O1OpOUuDu3F4Ij4nv3oAqN" 146 147 148testExceptionFindProjectRoot :: Assertion 149testExceptionFindProjectRoot = do 150 Right (ProjectRootExplicit dir _) <- findProjectRoot (Just testdir) Nothing 151 cwd <- getCurrentDirectory 152 dir @?= cwd </> testdir 153 where 154 testdir = basedir </> "exception" </> "no-pkg2" 155 156 157testTargetSelectors :: (String -> IO ()) -> Assertion 158testTargetSelectors reportSubCase = do 159 (_, _, _, localPackages, _) <- configureProject testdir config 160 let readTargetSelectors' = readTargetSelectorsWith (dirActions testdir) 161 localPackages 162 Nothing 163 164 reportSubCase "cwd" 165 do Right ts <- readTargetSelectors' [] 166 ts @?= [TargetPackage TargetImplicitCwd ["p-0.1"] Nothing] 167 168 reportSubCase "all" 169 do Right ts <- readTargetSelectors' 170 ["all", ":all"] 171 ts @?= replicate 2 (TargetAllPackages Nothing) 172 173 reportSubCase "filter" 174 do Right ts <- readTargetSelectors' 175 [ "libs", ":cwd:libs" 176 , "flibs", ":cwd:flibs" 177 , "exes", ":cwd:exes" 178 , "tests", ":cwd:tests" 179 , "benchmarks", ":cwd:benchmarks"] 180 zipWithM_ (@?=) ts 181 [ TargetPackage TargetImplicitCwd ["p-0.1"] (Just kind) 182 | kind <- concatMap (replicate 2) [LibKind .. ] 183 ] 184 185 reportSubCase "all:filter" 186 do Right ts <- readTargetSelectors' 187 [ "all:libs", ":all:libs" 188 , "all:flibs", ":all:flibs" 189 , "all:exes", ":all:exes" 190 , "all:tests", ":all:tests" 191 , "all:benchmarks", ":all:benchmarks"] 192 zipWithM_ (@?=) ts 193 [ TargetAllPackages (Just kind) 194 | kind <- concatMap (replicate 2) [LibKind .. ] 195 ] 196 197 reportSubCase "pkg" 198 do Right ts <- readTargetSelectors' 199 [ ":pkg:p", ".", "./", "p.cabal" 200 , "q", ":pkg:q", "q/", "./q/", "q/q.cabal"] 201 ts @?= replicate 4 (mkTargetPackage "p-0.1") 202 ++ replicate 5 (mkTargetPackage "q-0.1") 203 204 reportSubCase "pkg:filter" 205 do Right ts <- readTargetSelectors' 206 [ "p:libs", ".:libs", ":pkg:p:libs" 207 , "p:flibs", ".:flibs", ":pkg:p:flibs" 208 , "p:exes", ".:exes", ":pkg:p:exes" 209 , "p:tests", ".:tests", ":pkg:p:tests" 210 , "p:benchmarks", ".:benchmarks", ":pkg:p:benchmarks" 211 , "q:libs", "q/:libs", ":pkg:q:libs" 212 , "q:flibs", "q/:flibs", ":pkg:q:flibs" 213 , "q:exes", "q/:exes", ":pkg:q:exes" 214 , "q:tests", "q/:tests", ":pkg:q:tests" 215 , "q:benchmarks", "q/:benchmarks", ":pkg:q:benchmarks"] 216 zipWithM_ (@?=) ts $ 217 [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just kind) 218 | kind <- concatMap (replicate 3) [LibKind .. ] 219 ] ++ 220 [ TargetPackage TargetExplicitNamed ["q-0.1"] (Just kind) 221 | kind <- concatMap (replicate 3) [LibKind .. ] 222 ] 223 224 reportSubCase "component" 225 do Right ts <- readTargetSelectors' 226 [ "p", "lib:p", "p:lib:p", ":pkg:p:lib:p" 227 , "lib:q", "q:lib:q", ":pkg:q:lib:q" ] 228 ts @?= replicate 4 (TargetComponent "p-0.1" (CLibName LMainLibName) WholeComponent) 229 ++ replicate 3 (TargetComponent "q-0.1" (CLibName LMainLibName) WholeComponent) 230 231 reportSubCase "module" 232 do Right ts <- readTargetSelectors' 233 [ "P", "lib:p:P", "p:p:P", ":pkg:p:lib:p:module:P" 234 , "QQ", "lib:q:QQ", "q:q:QQ", ":pkg:q:lib:q:module:QQ" 235 , "pexe:PMain" -- p:P or q:QQ would be ambiguous here 236 , "qexe:QMain" -- package p vs component p 237 ] 238 ts @?= replicate 4 (TargetComponent "p-0.1" (CLibName LMainLibName) (ModuleTarget "P")) 239 ++ replicate 4 (TargetComponent "q-0.1" (CLibName LMainLibName) (ModuleTarget "QQ")) 240 ++ [ TargetComponent "p-0.1" (CExeName "pexe") (ModuleTarget "PMain") 241 , TargetComponent "q-0.1" (CExeName "qexe") (ModuleTarget "QMain") 242 ] 243 244 reportSubCase "file" 245 do Right ts <- readTargetSelectors' 246 [ "./P.hs", "p:P.lhs", "lib:p:P.hsc", "p:p:P.hsc", 247 ":pkg:p:lib:p:file:P.y" 248 , "q/QQ.hs", "q:QQ.lhs", "lib:q:QQ.hsc", "q:q:QQ.hsc", 249 ":pkg:q:lib:q:file:QQ.y" 250 , "q/Q.hs", "q:Q.lhs", "lib:q:Q.hsc", "q:q:Q.hsc", 251 ":pkg:q:lib:q:file:Q.y" 252 , "app/Main.hs", "p:app/Main.hs", "exe:ppexe:app/Main.hs", "p:ppexe:app/Main.hs", 253 ":pkg:p:exe:ppexe:file:app/Main.hs" 254 ] 255 ts @?= replicate 5 (TargetComponent "p-0.1" (CLibName LMainLibName) (FileTarget "P")) 256 ++ replicate 5 (TargetComponent "q-0.1" (CLibName LMainLibName) (FileTarget "QQ")) 257 ++ replicate 5 (TargetComponent "q-0.1" (CLibName LMainLibName) (FileTarget "Q")) 258 ++ replicate 5 (TargetComponent "p-0.1" (CExeName "ppexe") (FileTarget ("app" </> "Main.hs"))) 259 -- Note there's a bit of an inconsistency here: for the single-part 260 -- syntax the target has to point to a file that exists, whereas for 261 -- all the other forms we don't require that. 262 263 cleanProject testdir 264 where 265 testdir = "targets/simple" 266 config = mempty 267 268 269testTargetSelectorBadSyntax :: Assertion 270testTargetSelectorBadSyntax = do 271 (_, _, _, localPackages, _) <- configureProject testdir config 272 let targets = [ "foo bar", " foo" 273 , "foo:", "foo::bar" 274 , "foo: ", "foo: :bar" 275 , "a:b:c:d:e:f", "a:b:c:d:e:f:g:h" ] 276 Left errs <- readTargetSelectors localPackages Nothing targets 277 zipWithM_ (@?=) errs (map TargetSelectorUnrecognised targets) 278 cleanProject testdir 279 where 280 testdir = "targets/empty" 281 config = mempty 282 283 284testTargetSelectorAmbiguous :: (String -> IO ()) -> Assertion 285testTargetSelectorAmbiguous reportSubCase = do 286 287 -- 'all' is ambiguous with packages and cwd components 288 reportSubCase "ambiguous: all vs pkg" 289 assertAmbiguous "all" 290 [mkTargetPackage "all", mkTargetAllPackages] 291 [mkpkg "all" []] 292 293 reportSubCase "ambiguous: all vs cwd component" 294 assertAmbiguous "all" 295 [mkTargetComponent "other" (CExeName "all"), mkTargetAllPackages] 296 [mkpkg "other" [mkexe "all"]] 297 298 -- but 'all' is not ambiguous with non-cwd components, modules or files 299 reportSubCase "unambiguous: all vs non-cwd comp, mod, file" 300 assertUnambiguous "All" 301 mkTargetAllPackages 302 [ mkpkgAt "foo" [mkexe "All"] "foo" 303 , mkpkg "bar" [ mkexe "bar" `withModules` ["All"] 304 , mkexe "baz" `withCFiles` ["All"] ] 305 ] 306 307 -- filters 'libs', 'exes' etc are ambiguous with packages and 308 -- local components 309 reportSubCase "ambiguous: cwd-pkg filter vs pkg" 310 assertAmbiguous "libs" 311 [ mkTargetPackage "libs" 312 , TargetPackage TargetImplicitCwd ["libs"] (Just LibKind) ] 313 [mkpkg "libs" []] 314 315 reportSubCase "ambiguous: filter vs cwd component" 316 assertAmbiguous "exes" 317 [ mkTargetComponent "other" (CExeName "exes") 318 , TargetPackage TargetImplicitCwd ["other"] (Just ExeKind) ] 319 [mkpkg "other" [mkexe "exes"]] 320 321 -- but filters are not ambiguous with non-cwd components, modules or files 322 reportSubCase "unambiguous: filter vs non-cwd comp, mod, file" 323 assertUnambiguous "Libs" 324 (TargetPackage TargetImplicitCwd ["bar"] (Just LibKind)) 325 [ mkpkgAt "foo" [mkexe "Libs"] "foo" 326 , mkpkg "bar" [ mkexe "bar" `withModules` ["Libs"] 327 , mkexe "baz" `withCFiles` ["Libs"] ] 328 ] 329 330 -- local components shadow packages and other components 331 reportSubCase "unambiguous: cwd comp vs pkg, non-cwd comp" 332 assertUnambiguous "foo" 333 (mkTargetComponent "other" (CExeName "foo")) 334 [ mkpkg "other" [mkexe "foo"] 335 , mkpkgAt "other2" [mkexe "foo"] "other2" -- shadows non-local foo 336 , mkpkg "foo" [] ] -- shadows package foo 337 338 -- local components shadow modules and files 339 reportSubCase "unambiguous: cwd comp vs module, file" 340 assertUnambiguous "Foo" 341 (mkTargetComponent "bar" (CExeName "Foo")) 342 [ mkpkg "bar" [mkexe "Foo"] 343 , mkpkg "other" [ mkexe "other" `withModules` ["Foo"] 344 , mkexe "other2" `withCFiles` ["Foo"] ] 345 ] 346 347 -- packages shadow non-local components 348 reportSubCase "unambiguous: pkg vs non-cwd comp" 349 assertUnambiguous "foo" 350 (mkTargetPackage "foo") 351 [ mkpkg "foo" [] 352 , mkpkgAt "other" [mkexe "foo"] "other" -- shadows non-local foo 353 ] 354 355 -- packages shadow modules and files 356 reportSubCase "unambiguous: pkg vs module, file" 357 assertUnambiguous "Foo" 358 (mkTargetPackage "Foo") 359 [ mkpkgAt "Foo" [] "foo" 360 , mkpkg "other" [ mkexe "other" `withModules` ["Foo"] 361 , mkexe "other2" `withCFiles` ["Foo"] ] 362 ] 363 364 -- File target is ambiguous, part of multiple components 365 reportSubCase "ambiguous: file in multiple comps" 366 assertAmbiguous "Bar.hs" 367 [ mkTargetFile "foo" (CExeName "bar") "Bar" 368 , mkTargetFile "foo" (CExeName "bar2") "Bar" 369 ] 370 [ mkpkg "foo" [ mkexe "bar" `withModules` ["Bar"] 371 , mkexe "bar2" `withModules` ["Bar"] ] 372 ] 373 reportSubCase "ambiguous: file in multiple comps with path" 374 assertAmbiguous ("src" </> "Bar.hs") 375 [ mkTargetFile "foo" (CExeName "bar") ("src" </> "Bar") 376 , mkTargetFile "foo" (CExeName "bar2") ("src" </> "Bar") 377 ] 378 [ mkpkg "foo" [ mkexe "bar" `withModules` ["Bar"] `withHsSrcDirs` ["src"] 379 , mkexe "bar2" `withModules` ["Bar"] `withHsSrcDirs` ["src"] ] 380 ] 381 382 -- non-exact case packages and components are ambiguous 383 reportSubCase "ambiguous: non-exact-case pkg names" 384 assertAmbiguous "Foo" 385 [ mkTargetPackage "foo", mkTargetPackage "FOO" ] 386 [ mkpkg "foo" [], mkpkg "FOO" [] ] 387 reportSubCase "ambiguous: non-exact-case comp names" 388 assertAmbiguous "Foo" 389 [ mkTargetComponent "bar" (CExeName "foo") 390 , mkTargetComponent "bar" (CExeName "FOO") ] 391 [ mkpkg "bar" [mkexe "foo", mkexe "FOO"] ] 392 393 -- exact-case Module or File over non-exact case package or component 394 reportSubCase "unambiguous: module vs non-exact-case pkg, comp" 395 assertUnambiguous "Baz" 396 (mkTargetModule "other" (CExeName "other") "Baz") 397 [ mkpkg "baz" [mkexe "BAZ"] 398 , mkpkg "other" [ mkexe "other" `withModules` ["Baz"] ] 399 ] 400 reportSubCase "unambiguous: file vs non-exact-case pkg, comp" 401 assertUnambiguous "Baz" 402 (mkTargetFile "other" (CExeName "other") "Baz") 403 [ mkpkg "baz" [mkexe "BAZ"] 404 , mkpkg "other" [ mkexe "other" `withCFiles` ["Baz"] ] 405 ] 406 where 407 assertAmbiguous :: String 408 -> [TargetSelector] 409 -> [SourcePackage (PackageLocation a)] 410 -> Assertion 411 assertAmbiguous str tss pkgs = do 412 res <- readTargetSelectorsWith 413 fakeDirActions 414 (map SpecificSourcePackage pkgs) 415 Nothing 416 [str] 417 case res of 418 Left [TargetSelectorAmbiguous _ tss'] -> 419 sort (map snd tss') @?= sort tss 420 _ -> assertFailure $ "expected Left [TargetSelectorAmbiguous _ _], " 421 ++ "got " ++ show res 422 423 assertUnambiguous :: String 424 -> TargetSelector 425 -> [SourcePackage (PackageLocation a)] 426 -> Assertion 427 assertUnambiguous str ts pkgs = do 428 res <- readTargetSelectorsWith 429 fakeDirActions 430 (map SpecificSourcePackage pkgs) 431 Nothing 432 [str] 433 case res of 434 Right [ts'] -> ts' @?= ts 435 _ -> assertFailure $ "expected Right [Target...], " 436 ++ "got " ++ show res 437 438 fakeDirActions = TS.DirActions { 439 TS.doesFileExist = \_p -> return True, 440 TS.doesDirectoryExist = \_p -> return True, 441 TS.canonicalizePath = \p -> return ("/" </> p), -- FilePath.Unix.</> ? 442 TS.getCurrentDirectory = return "/" 443 } 444 445 mkpkg :: String -> [Executable] -> SourcePackage (PackageLocation a) 446 mkpkg pkgidstr exes = mkpkgAt pkgidstr exes "" 447 448 mkpkgAt :: String -> [Executable] -> FilePath 449 -> SourcePackage (PackageLocation a) 450 mkpkgAt pkgidstr exes loc = 451 SourcePackage { 452 srcpkgPackageId = pkgid, 453 srcpkgSource = LocalUnpackedPackage loc, 454 srcpkgDescrOverride = Nothing, 455 srcpkgDescription = GenericPackageDescription { 456 packageDescription = emptyPackageDescription { package = pkgid }, 457 gpdScannedVersion = Nothing, 458 genPackageFlags = [], 459 condLibrary = Nothing, 460 condSubLibraries = [], 461 condForeignLibs = [], 462 condExecutables = [ ( exeName exe, CondNode exe [] [] ) 463 | exe <- exes ], 464 condTestSuites = [], 465 condBenchmarks = [] 466 } 467 } 468 where 469 pkgid = fromMaybe (error $ "failed to parse " ++ pkgidstr) $ simpleParse pkgidstr 470 471 mkexe :: String -> Executable 472 mkexe name = mempty { exeName = fromString name } 473 474 withModules :: Executable -> [String] -> Executable 475 withModules exe mods = 476 exe { buildInfo = (buildInfo exe) { otherModules = map fromString mods } } 477 478 withCFiles :: Executable -> [FilePath] -> Executable 479 withCFiles exe files = 480 exe { buildInfo = (buildInfo exe) { cSources = files } } 481 482 withHsSrcDirs :: Executable -> [FilePath] -> Executable 483 withHsSrcDirs exe srcDirs = 484 exe { buildInfo = (buildInfo exe) { hsSourceDirs = srcDirs }} 485 486 487mkTargetPackage :: PackageId -> TargetSelector 488mkTargetPackage pkgid = 489 TargetPackage TargetExplicitNamed [pkgid] Nothing 490 491mkTargetComponent :: PackageId -> ComponentName -> TargetSelector 492mkTargetComponent pkgid cname = 493 TargetComponent pkgid cname WholeComponent 494 495mkTargetModule :: PackageId -> ComponentName -> ModuleName -> TargetSelector 496mkTargetModule pkgid cname mname = 497 TargetComponent pkgid cname (ModuleTarget mname) 498 499mkTargetFile :: PackageId -> ComponentName -> String -> TargetSelector 500mkTargetFile pkgid cname fname = 501 TargetComponent pkgid cname (FileTarget fname) 502 503mkTargetAllPackages :: TargetSelector 504mkTargetAllPackages = TargetAllPackages Nothing 505 506instance IsString PackageIdentifier where 507 fromString pkgidstr = pkgid 508 where pkgid = fromMaybe (error $"fromString @PackageIdentifier " ++ show pkgidstr) $ simpleParse pkgidstr 509 510 511testTargetSelectorNoCurrentPackage :: Assertion 512testTargetSelectorNoCurrentPackage = do 513 (_, _, _, localPackages, _) <- configureProject testdir config 514 let readTargetSelectors' = readTargetSelectorsWith (dirActions testdir) 515 localPackages 516 Nothing 517 targets = [ "libs", ":cwd:libs" 518 , "flibs", ":cwd:flibs" 519 , "exes", ":cwd:exes" 520 , "tests", ":cwd:tests" 521 , "benchmarks", ":cwd:benchmarks"] 522 Left errs <- readTargetSelectors' targets 523 zipWithM_ (@?=) errs 524 [ TargetSelectorNoCurrentPackage ts 525 | target <- targets 526 , let ts = fromMaybe (error $ "failed to parse target string " ++ target) $ parseTargetString target 527 ] 528 cleanProject testdir 529 where 530 testdir = "targets/complex" 531 config = mempty 532 533 534testTargetSelectorNoTargets :: Assertion 535testTargetSelectorNoTargets = do 536 (_, _, _, localPackages, _) <- configureProject testdir config 537 Left errs <- readTargetSelectors localPackages Nothing [] 538 errs @?= [TargetSelectorNoTargetsInCwd] 539 cleanProject testdir 540 where 541 testdir = "targets/complex" 542 config = mempty 543 544 545testTargetSelectorProjectEmpty :: Assertion 546testTargetSelectorProjectEmpty = do 547 (_, _, _, localPackages, _) <- configureProject testdir config 548 Left errs <- readTargetSelectors localPackages Nothing [] 549 errs @?= [TargetSelectorNoTargetsInProject] 550 cleanProject testdir 551 where 552 testdir = "targets/empty" 553 config = mempty 554 555 556testTargetProblemsCommon :: ProjectConfig -> Assertion 557testTargetProblemsCommon config0 = do 558 (_,elaboratedPlan,_) <- planProject testdir config 559 560 let pkgIdMap :: Map.Map PackageName PackageId 561 pkgIdMap = Map.fromList 562 [ (packageName p, packageId p) 563 | p <- InstallPlan.toList elaboratedPlan ] 564 565 cases :: [( TargetSelector -> TargetProblem' 566 , TargetSelector 567 )] 568 cases = 569 [ -- Cannot resolve packages outside of the project 570 ( \_ -> TargetProblemNoSuchPackage "foobar" 571 , mkTargetPackage "foobar" ) 572 573 -- We cannot currently build components like testsuites or 574 -- benchmarks from packages that are not local to the project 575 , ( \_ -> TargetComponentNotProjectLocal 576 (pkgIdMap Map.! "filepath") (CTestName "filepath-tests") 577 WholeComponent 578 , mkTargetComponent (pkgIdMap Map.! "filepath") 579 (CTestName "filepath-tests") ) 580 581 -- Components can be explicitly @buildable: False@ 582 , ( \_ -> TargetComponentNotBuildable "q-0.1" (CExeName "buildable-false") WholeComponent 583 , mkTargetComponent "q-0.1" (CExeName "buildable-false") ) 584 585 -- Testsuites and benchmarks can be disabled by the solver if it 586 -- cannot satisfy deps 587 , ( \_ -> TargetOptionalStanzaDisabledBySolver "q-0.1" (CTestName "solver-disabled") WholeComponent 588 , mkTargetComponent "q-0.1" (CTestName "solver-disabled") ) 589 590 -- Testsuites and benchmarks can be disabled explicitly by the 591 -- user via config 592 , ( \_ -> TargetOptionalStanzaDisabledByUser 593 "q-0.1" (CBenchName "user-disabled") WholeComponent 594 , mkTargetComponent "q-0.1" (CBenchName "user-disabled") ) 595 596 -- An unknown package. The target selector resolution should only 597 -- produce known packages, so this should not happen with the 598 -- output from 'readTargetSelectors'. 599 , ( \_ -> TargetProblemNoSuchPackage "foobar" 600 , mkTargetPackage "foobar" ) 601 602 -- An unknown component of a known package. The target selector 603 -- resolution should only produce known packages, so this should 604 -- not happen with the output from 'readTargetSelectors'. 605 , ( \_ -> TargetProblemNoSuchComponent "q-0.1" (CExeName "no-such") 606 , mkTargetComponent "q-0.1" (CExeName "no-such") ) 607 ] 608 assertTargetProblems 609 elaboratedPlan 610 CmdBuild.selectPackageTargets 611 CmdBuild.selectComponentTarget 612 cases 613 where 614 testdir = "targets/complex" 615 config = config0 { 616 projectConfigLocalPackages = (projectConfigLocalPackages config0) { 617 packageConfigBenchmarks = toFlag False 618 } 619 , projectConfigShared = (projectConfigShared config0) { 620 projectConfigConstraints = 621 [( UserConstraint (UserAnyQualifier "filepath") PackagePropertySource 622 , ConstraintSourceUnknown )] 623 } 624 } 625 626 627testTargetProblemsBuild :: ProjectConfig -> (String -> IO ()) -> Assertion 628testTargetProblemsBuild config reportSubCase = do 629 630 reportSubCase "empty-pkg" 631 assertProjectTargetProblems 632 "targets/empty-pkg" config 633 CmdBuild.selectPackageTargets 634 CmdBuild.selectComponentTarget 635 [ ( TargetProblemNoTargets, mkTargetPackage "p-0.1" ) 636 ] 637 638 reportSubCase "all-disabled" 639 assertProjectTargetProblems 640 "targets/all-disabled" 641 config { 642 projectConfigLocalPackages = (projectConfigLocalPackages config) { 643 packageConfigBenchmarks = toFlag False 644 } 645 } 646 CmdBuild.selectPackageTargets 647 CmdBuild.selectComponentTarget 648 [ ( flip TargetProblemNoneEnabled 649 [ AvailableTarget "p-0.1" (CBenchName "user-disabled") 650 TargetDisabledByUser True 651 , AvailableTarget "p-0.1" (CTestName "solver-disabled") 652 TargetDisabledBySolver True 653 , AvailableTarget "p-0.1" (CExeName "buildable-false") 654 TargetNotBuildable True 655 , AvailableTarget "p-0.1" (CLibName LMainLibName) 656 TargetNotBuildable True 657 ] 658 , mkTargetPackage "p-0.1" ) 659 ] 660 661 reportSubCase "enabled component kinds" 662 -- When we explicitly enable all the component kinds then selecting the 663 -- whole package selects those component kinds too 664 do (_,elaboratedPlan,_) <- planProject "targets/variety" config { 665 projectConfigLocalPackages = (projectConfigLocalPackages config) { 666 packageConfigTests = toFlag True, 667 packageConfigBenchmarks = toFlag True 668 } 669 } 670 assertProjectDistinctTargets 671 elaboratedPlan 672 CmdBuild.selectPackageTargets 673 CmdBuild.selectComponentTarget 674 [ mkTargetPackage "p-0.1" ] 675 [ ("p-0.1-inplace", (CLibName LMainLibName)) 676 , ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") 677 , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") 678 , ("p-0.1-inplace-an-exe", CExeName "an-exe") 679 , ("p-0.1-inplace-libp", CFLibName "libp") 680 ] 681 682 reportSubCase "disabled component kinds" 683 -- When we explicitly disable all the component kinds then selecting the 684 -- whole package only selects the library, foreign lib and exes 685 do (_,elaboratedPlan,_) <- planProject "targets/variety" config { 686 projectConfigLocalPackages = (projectConfigLocalPackages config) { 687 packageConfigTests = toFlag False, 688 packageConfigBenchmarks = toFlag False 689 } 690 } 691 assertProjectDistinctTargets 692 elaboratedPlan 693 CmdBuild.selectPackageTargets 694 CmdBuild.selectComponentTarget 695 [ mkTargetPackage "p-0.1" ] 696 [ ("p-0.1-inplace", (CLibName LMainLibName)) 697 , ("p-0.1-inplace-an-exe", CExeName "an-exe") 698 , ("p-0.1-inplace-libp", CFLibName "libp") 699 ] 700 701 reportSubCase "requested component kinds" 702 -- When we selecting the package with an explicit filter then we get those 703 -- components even though we did not explicitly enable tests/benchmarks 704 do (_,elaboratedPlan,_) <- planProject "targets/variety" config 705 assertProjectDistinctTargets 706 elaboratedPlan 707 CmdBuild.selectPackageTargets 708 CmdBuild.selectComponentTarget 709 [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) 710 , TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind) 711 ] 712 [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") 713 , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") 714 ] 715 716 717testTargetProblemsRepl :: ProjectConfig -> (String -> IO ()) -> Assertion 718testTargetProblemsRepl config reportSubCase = do 719 720 reportSubCase "multiple-libs" 721 assertProjectTargetProblems 722 "targets/multiple-libs" config 723 CmdRepl.selectPackageTargets 724 CmdRepl.selectComponentTarget 725 [ ( flip CmdRepl.matchesMultipleProblem 726 [ AvailableTarget "p-0.1" (CLibName LMainLibName) 727 (TargetBuildable () TargetRequestedByDefault) True 728 , AvailableTarget "q-0.1" (CLibName LMainLibName) 729 (TargetBuildable () TargetRequestedByDefault) True 730 ] 731 , mkTargetAllPackages ) 732 ] 733 734 reportSubCase "multiple-exes" 735 assertProjectTargetProblems 736 "targets/multiple-exes" config 737 CmdRepl.selectPackageTargets 738 CmdRepl.selectComponentTarget 739 [ ( flip CmdRepl.matchesMultipleProblem 740 [ AvailableTarget "p-0.1" (CExeName "p2") 741 (TargetBuildable () TargetRequestedByDefault) True 742 , AvailableTarget "p-0.1" (CExeName "p1") 743 (TargetBuildable () TargetRequestedByDefault) True 744 ] 745 , mkTargetPackage "p-0.1" ) 746 ] 747 748 reportSubCase "multiple-tests" 749 assertProjectTargetProblems 750 "targets/multiple-tests" config 751 CmdRepl.selectPackageTargets 752 CmdRepl.selectComponentTarget 753 [ ( flip CmdRepl.matchesMultipleProblem 754 [ AvailableTarget "p-0.1" (CTestName "p2") 755 (TargetBuildable () TargetNotRequestedByDefault) True 756 , AvailableTarget "p-0.1" (CTestName "p1") 757 (TargetBuildable () TargetNotRequestedByDefault) True 758 ] 759 , TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) ) 760 ] 761 762 reportSubCase "multiple targets" 763 do (_,elaboratedPlan,_) <- planProject "targets/multiple-exes" config 764 assertProjectDistinctTargets 765 elaboratedPlan 766 CmdRepl.selectPackageTargets 767 CmdRepl.selectComponentTarget 768 [ mkTargetComponent "p-0.1" (CExeName "p1") 769 , mkTargetComponent "p-0.1" (CExeName "p2") 770 ] 771 [ ("p-0.1-inplace-p1", CExeName "p1") 772 , ("p-0.1-inplace-p2", CExeName "p2") 773 ] 774 775 reportSubCase "libs-disabled" 776 assertProjectTargetProblems 777 "targets/libs-disabled" config 778 CmdRepl.selectPackageTargets 779 CmdRepl.selectComponentTarget 780 [ ( flip TargetProblemNoneEnabled 781 [ AvailableTarget "p-0.1" (CLibName LMainLibName) TargetNotBuildable True ] 782 , mkTargetPackage "p-0.1" ) 783 ] 784 785 reportSubCase "exes-disabled" 786 assertProjectTargetProblems 787 "targets/exes-disabled" config 788 CmdRepl.selectPackageTargets 789 CmdRepl.selectComponentTarget 790 [ ( flip TargetProblemNoneEnabled 791 [ AvailableTarget "p-0.1" (CExeName "p") TargetNotBuildable True 792 ] 793 , mkTargetPackage "p-0.1" ) 794 ] 795 796 reportSubCase "test-only" 797 assertProjectTargetProblems 798 "targets/test-only" config 799 CmdRepl.selectPackageTargets 800 CmdRepl.selectComponentTarget 801 [ ( flip TargetProblemNoneEnabled 802 [ AvailableTarget "p-0.1" (CTestName "pexe") 803 (TargetBuildable () TargetNotRequestedByDefault) True 804 ] 805 , mkTargetPackage "p-0.1" ) 806 ] 807 808 reportSubCase "empty-pkg" 809 assertProjectTargetProblems 810 "targets/empty-pkg" config 811 CmdRepl.selectPackageTargets 812 CmdRepl.selectComponentTarget 813 [ ( TargetProblemNoTargets, mkTargetPackage "p-0.1" ) 814 ] 815 816 reportSubCase "requested component kinds" 817 do (_,elaboratedPlan,_) <- planProject "targets/variety" config 818 -- by default we only get the lib 819 assertProjectDistinctTargets 820 elaboratedPlan 821 CmdRepl.selectPackageTargets 822 CmdRepl.selectComponentTarget 823 [ TargetPackage TargetExplicitNamed ["p-0.1"] Nothing ] 824 [ ("p-0.1-inplace", (CLibName LMainLibName)) ] 825 -- When we select the package with an explicit filter then we get those 826 -- components even though we did not explicitly enable tests/benchmarks 827 assertProjectDistinctTargets 828 elaboratedPlan 829 CmdRepl.selectPackageTargets 830 CmdRepl.selectComponentTarget 831 [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) ] 832 [ ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") ] 833 assertProjectDistinctTargets 834 elaboratedPlan 835 CmdRepl.selectPackageTargets 836 CmdRepl.selectComponentTarget 837 [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind) ] 838 [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") ] 839 840 841testTargetProblemsRun :: ProjectConfig -> (String -> IO ()) -> Assertion 842testTargetProblemsRun config reportSubCase = do 843 844 reportSubCase "multiple-exes" 845 assertProjectTargetProblems 846 "targets/multiple-exes" config 847 CmdRun.selectPackageTargets 848 CmdRun.selectComponentTarget 849 [ ( flip CmdRun.matchesMultipleProblem 850 [ AvailableTarget "p-0.1" (CExeName "p2") 851 (TargetBuildable () TargetRequestedByDefault) True 852 , AvailableTarget "p-0.1" (CExeName "p1") 853 (TargetBuildable () TargetRequestedByDefault) True 854 ] 855 , mkTargetPackage "p-0.1" ) 856 ] 857 858 reportSubCase "multiple targets" 859 do (_,elaboratedPlan,_) <- planProject "targets/multiple-exes" config 860 assertProjectDistinctTargets 861 elaboratedPlan 862 CmdRun.selectPackageTargets 863 CmdRun.selectComponentTarget 864 [ mkTargetComponent "p-0.1" (CExeName "p1") 865 , mkTargetComponent "p-0.1" (CExeName "p2") 866 ] 867 [ ("p-0.1-inplace-p1", CExeName "p1") 868 , ("p-0.1-inplace-p2", CExeName "p2") 869 ] 870 871 reportSubCase "exes-disabled" 872 assertProjectTargetProblems 873 "targets/exes-disabled" config 874 CmdRun.selectPackageTargets 875 CmdRun.selectComponentTarget 876 [ ( flip TargetProblemNoneEnabled 877 [ AvailableTarget "p-0.1" (CExeName "p") TargetNotBuildable True 878 ] 879 , mkTargetPackage "p-0.1" ) 880 ] 881 882 reportSubCase "empty-pkg" 883 assertProjectTargetProblems 884 "targets/empty-pkg" config 885 CmdRun.selectPackageTargets 886 CmdRun.selectComponentTarget 887 [ ( TargetProblemNoTargets, mkTargetPackage "p-0.1" ) 888 ] 889 890 reportSubCase "lib-only" 891 assertProjectTargetProblems 892 "targets/lib-only" config 893 CmdRun.selectPackageTargets 894 CmdRun.selectComponentTarget 895 [ (CmdRun.noExesProblem, mkTargetPackage "p-0.1" ) 896 ] 897 898 899testTargetProblemsTest :: ProjectConfig -> (String -> IO ()) -> Assertion 900testTargetProblemsTest config reportSubCase = do 901 902 reportSubCase "disabled by config" 903 assertProjectTargetProblems 904 "targets/tests-disabled" 905 config { 906 projectConfigLocalPackages = (projectConfigLocalPackages config) { 907 packageConfigTests = toFlag False 908 } 909 } 910 CmdTest.selectPackageTargets 911 CmdTest.selectComponentTarget 912 [ ( flip TargetProblemNoneEnabled 913 [ AvailableTarget "p-0.1" (CTestName "user-disabled") 914 TargetDisabledByUser True 915 , AvailableTarget "p-0.1" (CTestName "solver-disabled") 916 TargetDisabledByUser True 917 ] 918 , mkTargetPackage "p-0.1" ) 919 ] 920 921 reportSubCase "disabled by solver & buildable false" 922 assertProjectTargetProblems 923 "targets/tests-disabled" 924 config 925 CmdTest.selectPackageTargets 926 CmdTest.selectComponentTarget 927 [ ( flip TargetProblemNoneEnabled 928 [ AvailableTarget "p-0.1" (CTestName "user-disabled") 929 TargetDisabledBySolver True 930 , AvailableTarget "p-0.1" (CTestName "solver-disabled") 931 TargetDisabledBySolver True 932 ] 933 , mkTargetPackage "p-0.1" ) 934 935 , ( flip TargetProblemNoneEnabled 936 [ AvailableTarget "q-0.1" (CTestName "buildable-false") 937 TargetNotBuildable True 938 ] 939 , mkTargetPackage "q-0.1" ) 940 ] 941 942 reportSubCase "empty-pkg" 943 assertProjectTargetProblems 944 "targets/empty-pkg" config 945 CmdTest.selectPackageTargets 946 CmdTest.selectComponentTarget 947 [ ( TargetProblemNoTargets, mkTargetPackage "p-0.1" ) 948 ] 949 950 reportSubCase "no tests" 951 assertProjectTargetProblems 952 "targets/simple" 953 config 954 CmdTest.selectPackageTargets 955 CmdTest.selectComponentTarget 956 [ ( CmdTest.noTestsProblem, mkTargetPackage "p-0.1" ) 957 , ( CmdTest.noTestsProblem, mkTargetPackage "q-0.1" ) 958 ] 959 960 reportSubCase "not a test" 961 assertProjectTargetProblems 962 "targets/variety" 963 config 964 CmdTest.selectPackageTargets 965 CmdTest.selectComponentTarget $ 966 [ ( const (CmdTest.notTestProblem 967 "p-0.1" (CLibName LMainLibName)) 968 , mkTargetComponent "p-0.1" (CLibName LMainLibName) ) 969 970 , ( const (CmdTest.notTestProblem 971 "p-0.1" (CExeName "an-exe")) 972 , mkTargetComponent "p-0.1" (CExeName "an-exe") ) 973 974 , ( const (CmdTest.notTestProblem 975 "p-0.1" (CFLibName "libp")) 976 , mkTargetComponent "p-0.1" (CFLibName "libp") ) 977 978 , ( const (CmdTest.notTestProblem 979 "p-0.1" (CBenchName "a-benchmark")) 980 , mkTargetComponent "p-0.1" (CBenchName "a-benchmark") ) 981 ] ++ 982 [ ( const (CmdTest.isSubComponentProblem 983 "p-0.1" cname (ModuleTarget modname)) 984 , mkTargetModule "p-0.1" cname modname ) 985 | (cname, modname) <- [ (CTestName "a-testsuite", "TestModule") 986 , (CBenchName "a-benchmark", "BenchModule") 987 , (CExeName "an-exe", "ExeModule") 988 , ((CLibName LMainLibName), "P") 989 ] 990 ] ++ 991 [ ( const (CmdTest.isSubComponentProblem 992 "p-0.1" cname (FileTarget fname)) 993 , mkTargetFile "p-0.1" cname fname) 994 | (cname, fname) <- [ (CTestName "a-testsuite", "Test.hs") 995 , (CBenchName "a-benchmark", "Bench.hs") 996 , (CExeName "an-exe", "Main.hs") 997 ] 998 ] 999 1000 1001testTargetProblemsBench :: ProjectConfig -> (String -> IO ()) -> Assertion 1002testTargetProblemsBench config reportSubCase = do 1003 1004 reportSubCase "disabled by config" 1005 assertProjectTargetProblems 1006 "targets/benchmarks-disabled" 1007 config { 1008 projectConfigLocalPackages = (projectConfigLocalPackages config) { 1009 packageConfigBenchmarks = toFlag False 1010 } 1011 } 1012 CmdBench.selectPackageTargets 1013 CmdBench.selectComponentTarget 1014 [ ( flip TargetProblemNoneEnabled 1015 [ AvailableTarget "p-0.1" (CBenchName "user-disabled") 1016 TargetDisabledByUser True 1017 , AvailableTarget "p-0.1" (CBenchName "solver-disabled") 1018 TargetDisabledByUser True 1019 ] 1020 , mkTargetPackage "p-0.1" ) 1021 ] 1022 1023 reportSubCase "disabled by solver & buildable false" 1024 assertProjectTargetProblems 1025 "targets/benchmarks-disabled" 1026 config 1027 CmdBench.selectPackageTargets 1028 CmdBench.selectComponentTarget 1029 [ ( flip TargetProblemNoneEnabled 1030 [ AvailableTarget "p-0.1" (CBenchName "user-disabled") 1031 TargetDisabledBySolver True 1032 , AvailableTarget "p-0.1" (CBenchName "solver-disabled") 1033 TargetDisabledBySolver True 1034 ] 1035 , mkTargetPackage "p-0.1" ) 1036 1037 , ( flip TargetProblemNoneEnabled 1038 [ AvailableTarget "q-0.1" (CBenchName "buildable-false") 1039 TargetNotBuildable True 1040 ] 1041 , mkTargetPackage "q-0.1" ) 1042 ] 1043 1044 reportSubCase "empty-pkg" 1045 assertProjectTargetProblems 1046 "targets/empty-pkg" config 1047 CmdBench.selectPackageTargets 1048 CmdBench.selectComponentTarget 1049 [ ( TargetProblemNoTargets, mkTargetPackage "p-0.1" ) 1050 ] 1051 1052 reportSubCase "no benchmarks" 1053 assertProjectTargetProblems 1054 "targets/simple" 1055 config 1056 CmdBench.selectPackageTargets 1057 CmdBench.selectComponentTarget 1058 [ ( CmdBench.noBenchmarksProblem, mkTargetPackage "p-0.1" ) 1059 , ( CmdBench.noBenchmarksProblem, mkTargetPackage "q-0.1" ) 1060 ] 1061 1062 reportSubCase "not a benchmark" 1063 assertProjectTargetProblems 1064 "targets/variety" 1065 config 1066 CmdBench.selectPackageTargets 1067 CmdBench.selectComponentTarget $ 1068 [ ( const (CmdBench.componentNotBenchmarkProblem 1069 "p-0.1" (CLibName LMainLibName)) 1070 , mkTargetComponent "p-0.1" (CLibName LMainLibName) ) 1071 1072 , ( const (CmdBench.componentNotBenchmarkProblem 1073 "p-0.1" (CExeName "an-exe")) 1074 , mkTargetComponent "p-0.1" (CExeName "an-exe") ) 1075 1076 , ( const (CmdBench.componentNotBenchmarkProblem 1077 "p-0.1" (CFLibName "libp")) 1078 , mkTargetComponent "p-0.1" (CFLibName "libp") ) 1079 1080 , ( const (CmdBench.componentNotBenchmarkProblem 1081 "p-0.1" (CTestName "a-testsuite")) 1082 , mkTargetComponent "p-0.1" (CTestName "a-testsuite") ) 1083 ] ++ 1084 [ ( const (CmdBench.isSubComponentProblem 1085 "p-0.1" cname (ModuleTarget modname)) 1086 , mkTargetModule "p-0.1" cname modname ) 1087 | (cname, modname) <- [ (CTestName "a-testsuite", "TestModule") 1088 , (CBenchName "a-benchmark", "BenchModule") 1089 , (CExeName "an-exe", "ExeModule") 1090 , ((CLibName LMainLibName), "P") 1091 ] 1092 ] ++ 1093 [ ( const (CmdBench.isSubComponentProblem 1094 "p-0.1" cname (FileTarget fname)) 1095 , mkTargetFile "p-0.1" cname fname) 1096 | (cname, fname) <- [ (CTestName "a-testsuite", "Test.hs") 1097 , (CBenchName "a-benchmark", "Bench.hs") 1098 , (CExeName "an-exe", "Main.hs") 1099 ] 1100 ] 1101 1102 1103testTargetProblemsHaddock :: ProjectConfig -> (String -> IO ()) -> Assertion 1104testTargetProblemsHaddock config reportSubCase = do 1105 1106 reportSubCase "all-disabled" 1107 assertProjectTargetProblems 1108 "targets/all-disabled" 1109 config 1110 (let haddockFlags = mkHaddockFlags False True True False 1111 in CmdHaddock.selectPackageTargets haddockFlags) 1112 CmdHaddock.selectComponentTarget 1113 [ ( flip TargetProblemNoneEnabled 1114 [ AvailableTarget "p-0.1" (CBenchName "user-disabled") 1115 TargetDisabledByUser True 1116 , AvailableTarget "p-0.1" (CTestName "solver-disabled") 1117 TargetDisabledBySolver True 1118 , AvailableTarget "p-0.1" (CExeName "buildable-false") 1119 TargetNotBuildable True 1120 , AvailableTarget "p-0.1" (CLibName LMainLibName) 1121 TargetNotBuildable True 1122 ] 1123 , mkTargetPackage "p-0.1" ) 1124 ] 1125 1126 reportSubCase "empty-pkg" 1127 assertProjectTargetProblems 1128 "targets/empty-pkg" config 1129 (let haddockFlags = mkHaddockFlags False False False False 1130 in CmdHaddock.selectPackageTargets haddockFlags) 1131 CmdHaddock.selectComponentTarget 1132 [ ( TargetProblemNoTargets, mkTargetPackage "p-0.1" ) 1133 ] 1134 1135 reportSubCase "enabled component kinds" 1136 -- When we explicitly enable all the component kinds then selecting the 1137 -- whole package selects those component kinds too 1138 (_,elaboratedPlan,_) <- planProject "targets/variety" config 1139 let haddockFlags = mkHaddockFlags True True True True 1140 in assertProjectDistinctTargets 1141 elaboratedPlan 1142 (CmdHaddock.selectPackageTargets haddockFlags) 1143 CmdHaddock.selectComponentTarget 1144 [ mkTargetPackage "p-0.1" ] 1145 [ ("p-0.1-inplace", (CLibName LMainLibName)) 1146 , ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") 1147 , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") 1148 , ("p-0.1-inplace-an-exe", CExeName "an-exe") 1149 , ("p-0.1-inplace-libp", CFLibName "libp") 1150 ] 1151 1152 reportSubCase "disabled component kinds" 1153 -- When we explicitly disable all the component kinds then selecting the 1154 -- whole package only selects the library 1155 let haddockFlags = mkHaddockFlags False False False False 1156 in assertProjectDistinctTargets 1157 elaboratedPlan 1158 (CmdHaddock.selectPackageTargets haddockFlags) 1159 CmdHaddock.selectComponentTarget 1160 [ mkTargetPackage "p-0.1" ] 1161 [ ("p-0.1-inplace", (CLibName LMainLibName)) ] 1162 1163 reportSubCase "requested component kinds" 1164 -- When we selecting the package with an explicit filter then it does not 1165 -- matter if the config was to disable all the component kinds 1166 let haddockFlags = mkHaddockFlags False False False False 1167 in assertProjectDistinctTargets 1168 elaboratedPlan 1169 (CmdHaddock.selectPackageTargets haddockFlags) 1170 CmdHaddock.selectComponentTarget 1171 [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just FLibKind) 1172 , TargetPackage TargetExplicitNamed ["p-0.1"] (Just ExeKind) 1173 , TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) 1174 , TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind) 1175 ] 1176 [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") 1177 , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") 1178 , ("p-0.1-inplace-an-exe", CExeName "an-exe") 1179 , ("p-0.1-inplace-libp", CFLibName "libp") 1180 ] 1181 where 1182 mkHaddockFlags flib exe test bench = 1183 defaultHaddockFlags { 1184 haddockForeignLibs = toFlag flib, 1185 haddockExecutables = toFlag exe, 1186 haddockTestSuites = toFlag test, 1187 haddockBenchmarks = toFlag bench 1188 } 1189 1190assertProjectDistinctTargets 1191 :: forall err. (Eq err, Show err) => 1192 ElaboratedInstallPlan 1193 -> (forall k. TargetSelector -> [AvailableTarget k] -> Either (TargetProblem err) [k]) 1194 -> (forall k. SubComponentTarget -> AvailableTarget k -> Either (TargetProblem err) k ) 1195 -> [TargetSelector] 1196 -> [(UnitId, ComponentName)] 1197 -> Assertion 1198assertProjectDistinctTargets elaboratedPlan 1199 selectPackageTargets 1200 selectComponentTarget 1201 targetSelectors 1202 expectedTargets 1203 | Right targets <- results 1204 = distinctTargetComponents targets @?= Set.fromList expectedTargets 1205 1206 | otherwise 1207 = assertFailure $ "assertProjectDistinctTargets: expected " 1208 ++ "(Right targets) but got " ++ show results 1209 where 1210 results = resolveTargets 1211 selectPackageTargets 1212 selectComponentTarget 1213 elaboratedPlan 1214 Nothing 1215 targetSelectors 1216 1217 1218assertProjectTargetProblems 1219 :: forall err. (Eq err, Show err) => 1220 FilePath -> ProjectConfig 1221 -> (forall k. TargetSelector 1222 -> [AvailableTarget k] 1223 -> Either (TargetProblem err) [k]) 1224 -> (forall k. SubComponentTarget 1225 -> AvailableTarget k 1226 -> Either (TargetProblem err) k ) 1227 -> [(TargetSelector -> TargetProblem err, TargetSelector)] 1228 -> Assertion 1229assertProjectTargetProblems testdir config 1230 selectPackageTargets 1231 selectComponentTarget 1232 cases = do 1233 (_,elaboratedPlan,_) <- planProject testdir config 1234 assertTargetProblems 1235 elaboratedPlan 1236 selectPackageTargets 1237 selectComponentTarget 1238 cases 1239 1240 1241assertTargetProblems 1242 :: forall err. (Eq err, Show err) => 1243 ElaboratedInstallPlan 1244 -> (forall k. TargetSelector -> [AvailableTarget k] -> Either (TargetProblem err) [k]) 1245 -> (forall k. SubComponentTarget -> AvailableTarget k -> Either (TargetProblem err) k ) 1246 -> [(TargetSelector -> TargetProblem err, TargetSelector)] 1247 -> Assertion 1248assertTargetProblems elaboratedPlan selectPackageTargets selectComponentTarget = 1249 mapM_ (uncurry assertTargetProblem) 1250 where 1251 assertTargetProblem expected targetSelector = 1252 let res = resolveTargets selectPackageTargets selectComponentTarget 1253 elaboratedPlan Nothing 1254 [targetSelector] in 1255 case res of 1256 Left [problem] -> 1257 problem @?= expected targetSelector 1258 1259 unexpected -> 1260 assertFailure $ "expected resolveTargets result: (Left [problem]) " 1261 ++ "but got: " ++ show unexpected 1262 1263 1264testExceptionInFindingPackage :: ProjectConfig -> Assertion 1265testExceptionInFindingPackage config = do 1266 BadPackageLocations _ locs <- expectException "BadPackageLocations" $ 1267 void $ planProject testdir config 1268 case locs of 1269 [BadLocGlobEmptyMatch "./*.cabal"] -> return () 1270 _ -> assertFailure "expected BadLocGlobEmptyMatch" 1271 cleanProject testdir 1272 where 1273 testdir = "exception/no-pkg" 1274 1275 1276testExceptionInFindingPackage2 :: ProjectConfig -> Assertion 1277testExceptionInFindingPackage2 config = do 1278 BadPackageLocations _ locs <- expectException "BadPackageLocations" $ 1279 void $ planProject testdir config 1280 case locs of 1281 [BadPackageLocationFile (BadLocDirNoCabalFile ".")] -> return () 1282 _ -> assertFailure $ "expected BadLocDirNoCabalFile, got " ++ show locs 1283 cleanProject testdir 1284 where 1285 testdir = "exception/no-pkg2" 1286 1287 1288testExceptionInProjectConfig :: ProjectConfig -> Assertion 1289testExceptionInProjectConfig config = do 1290 BadPerPackageCompilerPaths ps <- expectException "BadPerPackageCompilerPaths" $ 1291 void $ planProject testdir config 1292 case ps of 1293 [(pn,"ghc")] | "foo" == pn -> return () 1294 _ -> assertFailure $ "expected (PackageName \"foo\",\"ghc\"), got " 1295 ++ show ps 1296 cleanProject testdir 1297 where 1298 testdir = "exception/bad-config" 1299 1300 1301testExceptionInConfigureStep :: ProjectConfig -> Assertion 1302testExceptionInConfigureStep config = do 1303 (plan, res) <- executePlan =<< planProject testdir config 1304 (_pkga1, failure) <- expectPackageFailed plan res pkgidA1 1305 case buildFailureReason failure of 1306 ConfigureFailed _ -> return () 1307 _ -> assertFailure $ "expected ConfigureFailed, got " ++ show failure 1308 cleanProject testdir 1309 where 1310 testdir = "exception/configure" 1311 pkgidA1 = PackageIdentifier "a" (mkVersion [1]) 1312 1313 1314testExceptionInBuildStep :: ProjectConfig -> Assertion 1315testExceptionInBuildStep config = do 1316 (plan, res) <- executePlan =<< planProject testdir config 1317 (_pkga1, failure) <- expectPackageFailed plan res pkgidA1 1318 expectBuildFailed failure 1319 where 1320 testdir = "exception/build" 1321 pkgidA1 = PackageIdentifier "a" (mkVersion [1]) 1322 1323testSetupScriptStyles :: ProjectConfig -> (String -> IO ()) -> Assertion 1324testSetupScriptStyles config reportSubCase = do 1325 1326 reportSubCase (show SetupCustomExplicitDeps) 1327 1328 plan0@(_,_,sharedConfig) <- planProject testdir1 config 1329 1330 let isOSX (Platform _ OSX) = True 1331 isOSX _ = False 1332 -- Skip the Custom tests when the shipped Cabal library is buggy 1333 unless (isOSX (pkgConfigPlatform sharedConfig) 1334 && compilerVersion (pkgConfigCompiler sharedConfig) < mkVersion [7,10]) $ do 1335 1336 (plan1, res1) <- executePlan plan0 1337 pkg1 <- expectPackageInstalled plan1 res1 pkgidA 1338 elabSetupScriptStyle pkg1 @?= SetupCustomExplicitDeps 1339 hasDefaultSetupDeps pkg1 @?= Just False 1340 marker1 <- readFile (basedir </> testdir1 </> "marker") 1341 marker1 @?= "ok" 1342 removeFile (basedir </> testdir1 </> "marker") 1343 1344 -- implicit deps implies 'Cabal < 2' which conflicts w/ GHC 8.2 or later 1345 when (compilerVersion (pkgConfigCompiler sharedConfig) < mkVersion [8,2]) $ do 1346 reportSubCase (show SetupCustomImplicitDeps) 1347 (plan2, res2) <- executePlan =<< planProject testdir2 config 1348 pkg2 <- expectPackageInstalled plan2 res2 pkgidA 1349 elabSetupScriptStyle pkg2 @?= SetupCustomImplicitDeps 1350 hasDefaultSetupDeps pkg2 @?= Just True 1351 marker2 <- readFile (basedir </> testdir2 </> "marker") 1352 marker2 @?= "ok" 1353 removeFile (basedir </> testdir2 </> "marker") 1354 1355 reportSubCase (show SetupNonCustomInternalLib) 1356 (plan3, res3) <- executePlan =<< planProject testdir3 config 1357 pkg3 <- expectPackageInstalled plan3 res3 pkgidA 1358 elabSetupScriptStyle pkg3 @?= SetupNonCustomInternalLib 1359{- 1360 --TODO: the SetupNonCustomExternalLib case is hard to test since it 1361 -- requires a version of Cabal that's later than the one we're testing 1362 -- e.g. needs a .cabal file that specifies cabal-version: >= 2.0 1363 -- and a corresponding Cabal package that we can use to try and build a 1364 -- default Setup.hs. 1365 reportSubCase (show SetupNonCustomExternalLib) 1366 (plan4, res4) <- executePlan =<< planProject testdir4 config 1367 pkg4 <- expectPackageInstalled plan4 res4 pkgidA 1368 pkgSetupScriptStyle pkg4 @?= SetupNonCustomExternalLib 1369-} 1370 where 1371 testdir1 = "build/setup-custom1" 1372 testdir2 = "build/setup-custom2" 1373 testdir3 = "build/setup-simple" 1374 pkgidA = PackageIdentifier "a" (mkVersion [0,1]) 1375 -- The solver fills in default setup deps explicitly, but marks them as such 1376 hasDefaultSetupDeps = fmap defaultSetupDepends 1377 . setupBuildInfo . elabPkgDescription 1378 1379-- | Test the behaviour with and without @--keep-going@ 1380-- 1381testBuildKeepGoing :: ProjectConfig -> Assertion 1382testBuildKeepGoing config = do 1383 -- P is expected to fail, Q does not depend on P but without 1384 -- parallel build and without keep-going then we don't build Q yet. 1385 (plan1, res1) <- executePlan =<< planProject testdir (config `mappend` keepGoing False) 1386 (_, failure1) <- expectPackageFailed plan1 res1 "p-0.1" 1387 expectBuildFailed failure1 1388 _ <- expectPackageConfigured plan1 res1 "q-0.1" 1389 1390 -- With keep-going then we should go on to successfully build Q 1391 (plan2, res2) <- executePlan 1392 =<< planProject testdir (config `mappend` keepGoing True) 1393 (_, failure2) <- expectPackageFailed plan2 res2 "p-0.1" 1394 expectBuildFailed failure2 1395 _ <- expectPackageInstalled plan2 res2 "q-0.1" 1396 return () 1397 where 1398 testdir = "build/keep-going" 1399 keepGoing kg = 1400 mempty { 1401 projectConfigBuildOnly = mempty { 1402 projectConfigKeepGoing = toFlag kg 1403 } 1404 } 1405 1406-- | Test we can successfully build packages from local tarball files. 1407-- 1408testBuildLocalTarball :: ProjectConfig -> Assertion 1409testBuildLocalTarball config = do 1410 -- P is a tarball package, Q is a local dir package that depends on it. 1411 (plan, res) <- executePlan =<< planProject testdir config 1412 _ <- expectPackageInstalled plan res "p-0.1" 1413 _ <- expectPackageInstalled plan res "q-0.1" 1414 return () 1415 where 1416 testdir = "build/local-tarball" 1417 1418-- | See <https://github.com/haskell/cabal/issues/3324> 1419-- 1420-- This test just doesn't seem to work on Windows, 1421-- due filesystem woes. 1422-- 1423testRegressionIssue3324 :: ProjectConfig -> Assertion 1424testRegressionIssue3324 config = when (buildOS /= Windows) $ do 1425 -- expected failure first time due to missing dep 1426 (plan1, res1) <- executePlan =<< planProject testdir config 1427 (_pkgq, failure) <- expectPackageFailed plan1 res1 "q-0.1" 1428 expectBuildFailed failure 1429 1430 -- add the missing dep, now it should work 1431 let qcabal = basedir </> testdir </> "q" </> "q.cabal" 1432 withFileFinallyRestore qcabal $ do 1433 tryFewTimes $ BS.appendFile qcabal (" build-depends: p\n") 1434 (plan2, res2) <- executePlan =<< planProject testdir config 1435 _ <- expectPackageInstalled plan2 res2 "p-0.1" 1436 _ <- expectPackageInstalled plan2 res2 "q-0.1" 1437 return () 1438 where 1439 testdir = "regression/3324" 1440 1441 1442--------------------------------- 1443-- Test utils to plan and build 1444-- 1445 1446basedir :: FilePath 1447basedir = "tests" </> "IntegrationTests2" 1448 1449dirActions :: FilePath -> TS.DirActions IO 1450dirActions testdir = 1451 defaultDirActions { 1452 TS.doesFileExist = \p -> 1453 TS.doesFileExist defaultDirActions (virtcwd </> p), 1454 1455 TS.doesDirectoryExist = \p -> 1456 TS.doesDirectoryExist defaultDirActions (virtcwd </> p), 1457 1458 TS.canonicalizePath = \p -> 1459 TS.canonicalizePath defaultDirActions (virtcwd </> p), 1460 1461 TS.getCurrentDirectory = 1462 TS.canonicalizePath defaultDirActions virtcwd 1463 } 1464 where 1465 virtcwd = basedir </> testdir 1466 1467type ProjDetails = (DistDirLayout, 1468 CabalDirLayout, 1469 ProjectConfig, 1470 [PackageSpecifier UnresolvedSourcePackage], 1471 BuildTimeSettings) 1472 1473configureProject :: FilePath -> ProjectConfig -> IO ProjDetails 1474configureProject testdir cliConfig = do 1475 cabalDir <- getCabalDir 1476 let cabalDirLayout = defaultCabalDirLayout cabalDir 1477 1478 projectRootDir <- canonicalizePath (basedir </> testdir) 1479 isexplict <- doesFileExist (projectRootDir </> "cabal.project") 1480 let projectRoot 1481 | isexplict = ProjectRootExplicit projectRootDir 1482 (projectRootDir </> "cabal.project") 1483 | otherwise = ProjectRootImplicit projectRootDir 1484 distDirLayout = defaultDistDirLayout projectRoot Nothing 1485 1486 -- Clear state between test runs. The state remains if the previous run 1487 -- ended in an exception (as we leave the files to help with debugging). 1488 cleanProject testdir 1489 1490 (projectConfig, localPackages) <- 1491 rebuildProjectConfig verbosity 1492 distDirLayout 1493 cliConfig 1494 1495 let buildSettings = resolveBuildTimeSettings 1496 verbosity cabalDirLayout 1497 projectConfig 1498 1499 return (distDirLayout, 1500 cabalDirLayout, 1501 projectConfig, 1502 localPackages, 1503 buildSettings) 1504 1505type PlanDetails = (ProjDetails, 1506 ElaboratedInstallPlan, 1507 ElaboratedSharedConfig) 1508 1509planProject :: FilePath -> ProjectConfig -> IO PlanDetails 1510planProject testdir cliConfig = do 1511 1512 projDetails@ 1513 (distDirLayout, 1514 cabalDirLayout, 1515 projectConfig, 1516 localPackages, 1517 _buildSettings) <- configureProject testdir cliConfig 1518 1519 (elaboratedPlan, _, elaboratedShared, _, _) <- 1520 rebuildInstallPlan verbosity 1521 distDirLayout cabalDirLayout 1522 projectConfig 1523 localPackages 1524 1525 return (projDetails, 1526 elaboratedPlan, 1527 elaboratedShared) 1528 1529executePlan :: PlanDetails -> IO (ElaboratedInstallPlan, BuildOutcomes) 1530executePlan ((distDirLayout, cabalDirLayout, _, _, buildSettings), 1531 elaboratedPlan, 1532 elaboratedShared) = do 1533 1534 let targets :: Map.Map UnitId [ComponentTarget] 1535 targets = 1536 Map.fromList 1537 [ (unitid, [ComponentTarget cname WholeComponent]) 1538 | ts <- Map.elems (availableTargets elaboratedPlan) 1539 , AvailableTarget { 1540 availableTargetStatus = TargetBuildable (unitid, cname) _ 1541 } <- ts 1542 ] 1543 elaboratedPlan' = pruneInstallPlanToTargets 1544 TargetActionBuild targets 1545 elaboratedPlan 1546 1547 pkgsBuildStatus <- 1548 rebuildTargetsDryRun distDirLayout elaboratedShared 1549 elaboratedPlan' 1550 1551 let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages 1552 pkgsBuildStatus elaboratedPlan' 1553 1554 buildOutcomes <- 1555 rebuildTargets verbosity 1556 distDirLayout 1557 (cabalStoreDirLayout cabalDirLayout) 1558 elaboratedPlan'' 1559 elaboratedShared 1560 pkgsBuildStatus 1561 -- Avoid trying to use act-as-setup mode: 1562 buildSettings { buildSettingNumJobs = 1 } 1563 1564 return (elaboratedPlan'', buildOutcomes) 1565 1566cleanProject :: FilePath -> IO () 1567cleanProject testdir = do 1568 alreadyExists <- doesDirectoryExist distDir 1569 when alreadyExists $ removePathForcibly distDir 1570 where 1571 projectRoot = ProjectRootImplicit (basedir </> testdir) 1572 distDirLayout = defaultDistDirLayout projectRoot Nothing 1573 distDir = distDirectory distDirLayout 1574 1575 1576verbosity :: Verbosity 1577verbosity = minBound --normal --verbose --maxBound --minBound 1578 1579 1580 1581------------------------------------------- 1582-- Tasty integration to adjust the config 1583-- 1584 1585withProjectConfig :: (ProjectConfig -> TestTree) -> TestTree 1586withProjectConfig testtree = 1587 askOption $ \ghcPath -> 1588 testtree (mkProjectConfig ghcPath) 1589 1590mkProjectConfig :: GhcPath -> ProjectConfig 1591mkProjectConfig (GhcPath ghcPath) = 1592 mempty { 1593 projectConfigShared = mempty { 1594 projectConfigHcPath = maybeToFlag ghcPath 1595 }, 1596 projectConfigBuildOnly = mempty { 1597 projectConfigNumJobs = toFlag (Just 1) 1598 } 1599 } 1600 where 1601 maybeToFlag = maybe mempty toFlag 1602 1603 1604data GhcPath = GhcPath (Maybe FilePath) 1605 deriving Typeable 1606 1607instance IsOption GhcPath where 1608 defaultValue = GhcPath Nothing 1609 optionName = Tagged "with-ghc" 1610 optionHelp = Tagged "The ghc compiler to use" 1611 parseValue = Just . GhcPath . Just 1612 1613projectConfigOptionDescriptions :: [OptionDescription] 1614projectConfigOptionDescriptions = [Option (Proxy :: Proxy GhcPath)] 1615 1616 1617--------------------------------------- 1618-- HUint style utils for this context 1619-- 1620 1621expectException :: Exception e => String -> IO a -> IO e 1622expectException expected action = do 1623 res <- try action 1624 case res of 1625 Left e -> return e 1626 Right _ -> throwIO $ HUnitFailure Nothing $ "expected an exception " ++ expected 1627 1628expectPackagePreExisting :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId 1629 -> IO InstalledPackageInfo 1630expectPackagePreExisting plan buildOutcomes pkgid = do 1631 planpkg <- expectPlanPackage plan pkgid 1632 case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of 1633 (InstallPlan.PreExisting pkg, Nothing) 1634 -> return pkg 1635 (_, buildResult) -> unexpectedBuildResult "PreExisting" planpkg buildResult 1636 1637expectPackageConfigured :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId 1638 -> IO ElaboratedConfiguredPackage 1639expectPackageConfigured plan buildOutcomes pkgid = do 1640 planpkg <- expectPlanPackage plan pkgid 1641 case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of 1642 (InstallPlan.Configured pkg, Nothing) 1643 -> return pkg 1644 (_, buildResult) -> unexpectedBuildResult "Configured" planpkg buildResult 1645 1646expectPackageInstalled :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId 1647 -> IO ElaboratedConfiguredPackage 1648expectPackageInstalled plan buildOutcomes pkgid = do 1649 planpkg <- expectPlanPackage plan pkgid 1650 case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of 1651 (InstallPlan.Configured pkg, Just (Right _result)) -- result isn't used by any test 1652 -> return pkg 1653 -- package can be installed in the global .store! 1654 -- (when installing from tarball!) 1655 (InstallPlan.Installed pkg, Nothing) 1656 -> return pkg 1657 (_, buildResult) -> unexpectedBuildResult "Installed" planpkg buildResult 1658 1659expectPackageFailed :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId 1660 -> IO (ElaboratedConfiguredPackage, BuildFailure) 1661expectPackageFailed plan buildOutcomes pkgid = do 1662 planpkg <- expectPlanPackage plan pkgid 1663 case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of 1664 (InstallPlan.Configured pkg, Just (Left failure)) 1665 -> return (pkg, failure) 1666 (_, buildResult) -> unexpectedBuildResult "Failed" planpkg buildResult 1667 1668unexpectedBuildResult :: String -> ElaboratedPlanPackage 1669 -> Maybe (Either BuildFailure BuildResult) -> IO a 1670unexpectedBuildResult expected planpkg buildResult = 1671 throwIO $ HUnitFailure Nothing $ 1672 "expected to find " ++ display (packageId planpkg) ++ " in the " 1673 ++ expected ++ " state, but it is actually in the " ++ actual ++ " state." 1674 where 1675 actual = case (buildResult, planpkg) of 1676 (Nothing, InstallPlan.PreExisting{}) -> "PreExisting" 1677 (Nothing, InstallPlan.Configured{}) -> "Configured" 1678 (Just (Right _), InstallPlan.Configured{}) -> "Installed" 1679 (Just (Left _), InstallPlan.Configured{}) -> "Failed" 1680 (Nothing, InstallPlan.Installed{}) -> "Installed globally" 1681 _ -> "Impossible! " ++ show buildResult ++ show planpkg 1682 1683expectPlanPackage :: ElaboratedInstallPlan -> PackageId 1684 -> IO ElaboratedPlanPackage 1685expectPlanPackage plan pkgid = 1686 case [ pkg 1687 | pkg <- InstallPlan.toList plan 1688 , packageId pkg == pkgid ] of 1689 [pkg] -> return pkg 1690 [] -> throwIO $ HUnitFailure Nothing $ 1691 "expected to find " ++ display pkgid 1692 ++ " in the install plan but it's not there" 1693 _ -> throwIO $ HUnitFailure Nothing $ 1694 "expected to find only one instance of " ++ display pkgid 1695 ++ " in the install plan but there's several" 1696 1697expectBuildFailed :: BuildFailure -> IO () 1698expectBuildFailed (BuildFailure _ (BuildFailed _)) = return () 1699expectBuildFailed (BuildFailure _ reason) = 1700 assertFailure $ "expected BuildFailed, got " ++ show reason 1701 1702--------------------------------------- 1703-- Other utils 1704-- 1705 1706-- | Allow altering a file during a test, but then restore it afterwards 1707-- 1708-- We read into the memory, as filesystems are tricky. (especially Windows) 1709-- 1710withFileFinallyRestore :: FilePath -> IO a -> IO a 1711withFileFinallyRestore file action = do 1712 originalContents <- BS.readFile file 1713 action `finally` handle onIOError (tryFewTimes $ BS.writeFile file originalContents) 1714 where 1715 onIOError :: IOException -> IO () 1716 onIOError e = putStrLn $ "WARNING: Cannot restore " ++ file ++ "; " ++ show e 1717 1718-- Hopefully works around some Windows file-locking things. 1719-- Use with care: 1720-- 1721-- Try action 4 times, with small sleep in between, 1722-- retrying if it fails for 'IOException' reason. 1723-- 1724tryFewTimes :: forall a. IO a -> IO a 1725tryFewTimes action = go (3 :: Int) where 1726 go :: Int -> IO a 1727 go !n | n <= 0 = action 1728 | otherwise = action `catch` onIOError n 1729 1730 onIOError :: Int -> IOException -> IO a 1731 onIOError n e = do 1732 hPutStrLn stderr $ "Trying " ++ show n ++ " after " ++ show e 1733 threadDelay 10000 1734 go (n - 1) 1735