Merge pull request #6875 from bubba/fix-ambiguous-target-selector-int…

…ernal-error

Fix ambiguous file target selectors causing an internal error

Cabal/Distribution/Compat/Prelude.hs

@@ -137,7 +137,7 @@ module Distribution.Compat.Prelude (
     readMaybe,
 
     -- * Debug.Trace (as deprecated functions)
-    traceShow, traceShowId,
+    trace, traceShow, traceShowId,
     ) where
 
 -- We also could hide few partial function
@@ -303,6 +303,10 @@ foldl1 = Data.Foldable.foldl1
 -- Functions from Debug.Trace
 -- but with DEPRECATED pragma, so -Werror will scream on them.
 
+trace :: String -> a -> a
+trace = Debug.Trace.trace
+{-# DEPRECATED trace "Don't leave me in the code" #-}
+
 traceShowId :: Show a => a -> a
 traceShowId x = Debug.Trace.traceShow x x
 {-# DEPRECATED traceShowId "Don't leave me in the code" #-}

cabal-install/Distribution/Client/TargetSelector.hs

@@ -180,7 +180,8 @@ data SubComponentTarget =
      -- | A specific module within a component.
    | ModuleTarget ModuleName
 
-     -- | A specific file within a component.
+     -- | A specific file within a component. Note that this does not carry the
+     -- file extension.
    | FileTarget   FilePath
   deriving (Eq, Ord, Show, Generic)
 
@@ -428,6 +429,23 @@ forgetFileStatus t = case t of
     TargetStringFileStatus7 s1   s2 s3 s4
                                  s5 s6 s7 -> TargetString7 s1 s2 s3 s4 s5 s6 s7
 
+getFileStatus :: TargetStringFileStatus -> Maybe FileStatus
+getFileStatus (TargetStringFileStatus1 _ f)     = Just f
+getFileStatus (TargetStringFileStatus2 _ f _)   = Just f
+getFileStatus (TargetStringFileStatus3 _ f _ _) = Just f
+getFileStatus _                                 = Nothing
+
+setFileStatus :: FileStatus -> TargetStringFileStatus -> TargetStringFileStatus
+setFileStatus f (TargetStringFileStatus1 s1 _)       = TargetStringFileStatus1 s1 f
+setFileStatus f (TargetStringFileStatus2 s1 _ s2)    = TargetStringFileStatus2 s1 f s2
+setFileStatus f (TargetStringFileStatus3 s1 _ s2 s3) = TargetStringFileStatus3 s1 f s2 s3
+setFileStatus _ t                                    = t
+
+copyFileStatus :: TargetStringFileStatus -> TargetStringFileStatus -> TargetStringFileStatus
+copyFileStatus src dst =
+    case getFileStatus src of
+      Just f -> setFileStatus f dst
+      Nothing -> dst
 
 -- ------------------------------------------------------------
 -- * Resolving target strings to target selectors
@@ -576,7 +594,12 @@ data TargetSelectorProblem
    | TargetSelectorNoTargetsInProject
   deriving (Show, Eq)
 
-data QualLevel = QL1 | QL2 | QL3 | QLFull
+-- | Qualification levels.
+-- Given the filepath src/F, executable component A, and package foo:
+data QualLevel = QL1    -- ^ @src/F@
+               | QL2    -- ^ @foo:src/F | A:src/F@
+               | QL3    -- ^ @foo:A:src/F | exe:A:src/F@
+               | QLFull -- ^ @pkg:foo:exe:A:file:src/F@
   deriving (Eq, Enum, Show)
 
 disambiguateTargetSelectors
@@ -593,12 +616,19 @@ disambiguateTargetSelectors matcher matchInput exactMatch matchResults =
     -- So, here's the strategy. We take the original match results, and make a
     -- table of all their renderings at all qualification levels.
     -- Note there can be multiple renderings at each qualification level.
+
+    -- Note that renderTargetSelector won't immediately work on any file syntax
+    -- When rendering syntax, the FileStatus is always FileStatusNotExists,
+    -- which will never match on syntaxForm1File!
+    -- Because matchPackageDirectoryPrefix expects a FileStatusExistsFile.
+    -- So we need to copy over the file status from the input
+    -- TargetStringFileStatus, onto the new rendered TargetStringFileStatus
     matchResultsRenderings :: [(TargetSelector, [TargetStringFileStatus])]
     matchResultsRenderings =
       [ (matchResult, matchRenderings)
       | matchResult <- matchResults
       , let matchRenderings =
-              [ rendering
+              [ copyFileStatus matchInput rendering
               | ql <- [QL1 .. QLFull]
               , rendering <- renderTargetSelector ql matchResult ]
       ]
@@ -615,6 +645,8 @@ disambiguateTargetSelectors matcher matchInput exactMatch matchResults =
            then Map.insert matchInput (Match Exact 0 matchResults)
            else id)
       $ Map.Lazy.fromList
+        -- (matcher rendering) should *always* be a Match! Otherwise we will hit
+        -- the internal error later on.
           [ (rendering, matcher rendering)
           | rendering <- concatMap snd matchResultsRenderings ]
 
@@ -2127,7 +2159,8 @@ matchComponentModuleFile cs str = do
       , d <- cinfoSrcDirs c
       , m <- cinfoModules c
       ]
-      (dropExtension (normalise str))
+      (dropExtension (normalise str)) -- Drop the extension because FileTarget
+                                      -- is stored without the extension
 
 -- utils
 

cabal-install/tests/IntegrationTests2.hs

@@ -371,6 +371,14 @@ testTargetSelectorAmbiguous reportSubCase = do
       [ mkpkg "foo" [ mkexe "bar"  `withModules` ["Bar"]
                     , mkexe "bar2" `withModules` ["Bar"] ]
       ]
+    reportSubCase "ambiguous: file in multiple comps with path"
+    assertAmbiguous ("src" </> "Bar.hs")
+      [ mkTargetFile "foo" (CExeName "bar")  ("src" </> "Bar")
+      , mkTargetFile "foo" (CExeName "bar2") ("src" </> "Bar")
+      ]
+      [ mkpkg "foo" [ mkexe "bar"  `withModules` ["Bar"] `withHsSrcDirs` ["src"]
+                    , mkexe "bar2" `withModules` ["Bar"] `withHsSrcDirs` ["src"] ]
+      ]
 
     -- non-exact case packages and components are ambiguous
     reportSubCase "ambiguous: non-exact-case pkg names"
@@ -472,6 +480,10 @@ testTargetSelectorAmbiguous reportSubCase = do
     withCFiles exe files =
       exe { buildInfo = (buildInfo exe) { cSources = files } }
 
+    withHsSrcDirs :: Executable -> [FilePath] -> Executable
+    withHsSrcDirs exe srcDirs =
+      exe { buildInfo = (buildInfo exe) { hsSourceDirs = srcDirs }}
+
 
 mkTargetPackage :: PackageId -> TargetSelector
 mkTargetPackage pkgid =