Merge pull request #7397 from Mikolaj/master

Add regression test for #5782, which requires extending test harness to v2-install

Author: Mikolaj

cabal-testsuite/PackageTests/Regression/T5782Diamond/cabal.out

@@ -0,0 +1,6 @@
+# issue5782 E
+"AAA"
+# issue5782 E
+"BBB"
+# issue5782 E
+"CCC"

cabal-testsuite/PackageTests/Regression/T5782Diamond/cabal.project

@@ -0,0 +1 @@
+packages: issue5782

cabal-testsuite/PackageTests/Regression/T5782Diamond/cabal.test.hs

@@ -0,0 +1,45 @@
+-- When Module.f is changed, with cabal <= 3.2 this non-deterministically fails
+-- to compile and, if it doesn't fail, it also non-deterministically gives
+-- a wrong answer (ignoring the change to Module.f in the output, despite
+-- recompiling, so probably the wrong library is linked in); when running
+-- manually on my machine, three changes to Module.hs are enough to trigger
+-- the error, often two are enough, even with cabal 3.2, even to get
+-- compilation error
+--   "Ambiguous module name `Module': it was found in multiple packages: issue5782-0.1 issue5782-0.1"
+-- not only the wrong result from exe run.
+--
+-- The dummy "--installdir=." is needed for cabal <= 3.2
+-- and also to match cabal output on different OSes
+-- (default installdir is different on various OSes).
+--
+-- `withShorterPathForNewBuildStore` is needed to avoid some path mismatches, etc.,
+-- in the output, but MacOS still insists on processing internal libraries
+-- in a different order and Windows additionally still can't recognize
+-- the paths match. Hence `recordMode DoNotRecord` to mute the output,
+-- which is fine in this case, because the problem manifests either
+-- as failed compilation or wrong exe output, which I do check.
+
+import Test.Cabal.Prelude
+main = withShorterPathForNewBuildStore $ \storeDir ->
+  cabalTest $
+    withSourceCopy . withDelay $ do
+        writeSourceFile "issue5782/src/Module.hs" "module Module where\nf = \"AAA\""
+        recordMode DoNotRecord $
+          cabalG ["--store-dir=" ++ storeDir, "--installdir=" ++ storeDir, "--overwrite-policy=always"] "v2-install" ["issue5782"]
+        withPlan $
+            runPlanExe' "issue5782" "E" []
+                >>= assertOutputContains "AAA"
+        delay
+        writeSourceFile "issue5782/src/Module.hs" "module Module where\nf = \"BBB\""
+        recordMode DoNotRecord $
+          cabalG ["--store-dir=" ++ storeDir, "--installdir=" ++ storeDir, "--overwrite-policy=always"] "v2-install" ["issue5782"]
+        withPlan $
+            runPlanExe' "issue5782" "E" []
+                >>= assertOutputContains "BBB"
+        writeSourceFile "issue5782/src/Module.hs" "module Module where\nf = \"CCC\""
+        delay  -- different spot to try another scenario
+        recordMode DoNotRecord $
+          cabalG ["--store-dir=" ++ storeDir, "--installdir=" ++ storeDir, "--overwrite-policy=always"] "v2-install" ["issue5782"]
+        withPlan $
+            runPlanExe' "issue5782" "E" []
+                >>= assertOutputContains "CCC"

cabal-testsuite/PackageTests/Regression/T5782Diamond/issue5782/Main.hs

@@ -0,0 +1,3 @@
+import Module
+
+main = print f

cabal-testsuite/PackageTests/Regression/T5782Diamond/issue5782/issue5782.cabal

@@ -0,0 +1,28 @@
+cabal-version: 2.2
+
+name: issue5782
+version: 0.1
+build-type: Simple
+
+library a
+  hs-source-dirs: src
+  exposed-modules: Module
+  build-depends: base
+  default-language: Haskell2010
+
+library
+  hs-source-dirs: src2
+  build-depends: a, base
+  default-language: Haskell2010
+  reexported-modules: Module
+
+library b
+  hs-source-dirs: src2
+  build-depends: a, base
+  default-language: Haskell2010
+  reexported-modules: Module
+
+executable E
+  main-is:            Main.hs
+  build-depends:      issue5782, b, base
+  default-language: Haskell2010

cabal-testsuite/PackageTests/Regression/T5782Diamond/issue5782/src/.gitkeep

@@ -3,6 +3,7 @@
 -- | Utilities for understanding @plan.json@.
 module Test.Cabal.Plan (
     Plan,
+    DistDirOrBinFile(..),
     planDistDir,
 ) where
 
@@ -20,7 +21,7 @@ data Plan = Plan { planInstallPlan :: [InstallItem] }
 
 data InstallItem
     = APreExisting
-    | AConfiguredGlobal
+    | AConfiguredGlobal ConfiguredGlobal
     | AConfiguredInplace ConfiguredInplace
 
 -- local or inplace package
@@ -29,6 +30,11 @@ data ConfiguredInplace = ConfiguredInplace
     , configuredInplacePackageName   :: PackageName
     , configuredInplaceComponentName :: Maybe ComponentName }
 
+data ConfiguredGlobal = ConfiguredGlobal
+    { configuredGlobalBinFile       :: Maybe FilePath
+    , configuredGlobalPackageName   :: PackageName
+    , configuredGlobalComponentName :: Maybe ComponentName }
+
 instance FromJSON Plan where
     parseJSON (Object v) = fmap Plan (v .: "install-plan")
     parseJSON invalid = typeMismatch "Plan" invalid
@@ -41,7 +47,7 @@ instance FromJSON InstallItem where
             "configured"   -> do
                 s <- v .: "style"
                 case s :: String of
-                  "global"  -> return AConfiguredGlobal
+                  "global"  -> AConfiguredGlobal `fmap` parseJSON obj
                   "inplace" -> AConfiguredInplace `fmap` parseJSON obj
                   "local"   -> AConfiguredInplace `fmap` parseJSON obj
                   _         -> fail $ "unrecognized value of 'style' field: " ++ s
@@ -56,6 +62,14 @@ instance FromJSON ConfiguredInplace where
         return (ConfiguredInplace dist_dir pkg_name component_name)
     parseJSON invalid = typeMismatch "ConfiguredInplace" invalid
 
+instance FromJSON ConfiguredGlobal where
+    parseJSON (Object v) = do
+        bin_file <- v .:? "bin-file"
+        pkg_name <- v .: "pkg-name"
+        component_name <- v .:? "component-name"
+        return (ConfiguredGlobal bin_file pkg_name component_name)
+    parseJSON invalid = typeMismatch "ConfiguredGlobal" invalid
+
 instance FromJSON PackageName where
     parseJSON (String t) = return (mkPackageName (Text.unpack t))
     parseJSON invalid = typeMismatch "PackageName" invalid
@@ -68,21 +82,30 @@ instance FromJSON ComponentName where
       where s = Text.unpack t
     parseJSON invalid = typeMismatch "ComponentName" invalid
 
-planDistDir :: Plan -> PackageName -> ComponentName -> FilePath
+data DistDirOrBinFile = DistDir FilePath | BinFile FilePath
+
+planDistDir :: Plan -> PackageName -> ComponentName -> DistDirOrBinFile
 planDistDir plan pkg_name cname =
     case concatMap p (planInstallPlan plan) of
         [x] -> x
         []  -> error $ "planDistDir: component " ++ prettyShow cname
                     ++ " of package " ++ prettyShow pkg_name ++ " either does not"
-                    ++ " exist in the install plan or does not have a dist-dir"
+                    ++ " exist in the install plan or does not have a dist-dir nor bin-file"
         _   -> error $ "planDistDir: found multiple copies of component " ++ prettyShow cname
                     ++ " of package " ++ prettyShow pkg_name ++ " in install plan"
   where
     p APreExisting      = []
-    p AConfiguredGlobal = []
+    p (AConfiguredGlobal conf) = do
+        guard (configuredGlobalPackageName conf == pkg_name)
+        guard $ case configuredGlobalComponentName conf of
+                    Nothing     -> True
+                    Just cname' -> cname == cname'
+        case configuredGlobalBinFile conf of
+            Nothing -> []
+            Just bin_file -> return $ BinFile bin_file
     p (AConfiguredInplace conf) = do
         guard (configuredInplacePackageName conf == pkg_name)
         guard $ case configuredInplaceComponentName conf of
                     Nothing     -> True
                     Just cname' -> cname == cname'
-        return (configuredInplaceDistDir conf)
+        return $ DistDir $ configuredInplaceDistDir conf

cabal-testsuite/src/Test/Cabal/Plan.hs

@@ -335,11 +335,14 @@ runPlanExe' :: String {- package name -} -> String {- component name -}
             -> [String] -> TestM Result
 runPlanExe' pkg_name cname args = do
     Just plan <- testPlan `fmap` getTestEnv
-    let dist_dir = planDistDir plan (mkPackageName pkg_name)
-                        (CExeName (mkUnqualComponentName cname))
+    let distDirOrBinFile = planDistDir plan (mkPackageName pkg_name)
+                               (CExeName (mkUnqualComponentName cname))
+        exePath = case distDirOrBinFile of
+          DistDir dist_dir -> dist_dir </> "build" </> cname </> cname
+          BinFile bin_file -> bin_file
     defaultRecordMode RecordAll $ do
     recordHeader [pkg_name, cname]
-    runM (dist_dir </> "build" </> cname </> cname) args Nothing
+    runM exePath args Nothing
 
 ------------------------------------------------------------------------
 -- * Running ghc-pkg