From f330202c1bff748710769914bb86dde56dac10a9 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Fri, 5 Jun 2020 19:26:47 +0100 Subject: [PATCH] Fix ambiguous file target selectors causing an internal error These should have been returning an error message but instead were causing an internal error because disambiguateTargetSelectors was rendering syntax and rematching on it, which isn't equivalent. Due to the way syntaxForm1File renders, it does not add a FileStatus to its TargetStringFileStatus and so cannot be matched upon again. The fix is to just copy over the FileStatus from the match input. This fixes #6874 --- Cabal/Distribution/Compat/Prelude.hs | 6 ++- .../Distribution/Client/TargetSelector.hs | 41 +++++++++++++++++-- cabal-install/tests/IntegrationTests2.hs | 12 ++++++ 3 files changed, 54 insertions(+), 5 deletions(-) diff --git a/Cabal/Distribution/Compat/Prelude.hs b/Cabal/Distribution/Compat/Prelude.hs index 3def1af44a8..edc7eb3386e 100644 --- a/Cabal/Distribution/Compat/Prelude.hs +++ b/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" #-} diff --git a/cabal-install/Distribution/Client/TargetSelector.hs b/cabal-install/Distribution/Client/TargetSelector.hs index 33ac305a7ba..e08cdc92347 100644 --- a/cabal-install/Distribution/Client/TargetSelector.hs +++ b/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 diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index 04dd3339315..1e0854c0eed 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/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 =