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 =