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