diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index 72c09023ef0..9e4b21ce20c 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -530,6 +530,7 @@ library Distribution.Utils.NubList Distribution.Utils.ShortText Distribution.Utils.Progress + Distribution.Utils.Json Distribution.Verbosity Distribution.Verbosity.Internal Distribution.Version @@ -609,7 +610,6 @@ library Distribution.Simple.GHC.EnvironmentParser Distribution.Simple.GHC.Internal Distribution.Simple.GHC.ImplInfo - Distribution.Simple.Utils.Json Distribution.ZinzaPrelude Paths_Cabal @@ -689,7 +689,7 @@ test-suite unit-tests Distribution.Described Distribution.Utils.CharSet Distribution.Utils.GrammarRegex - + main-is: UnitTests.hs build-depends: array, diff --git a/Cabal/Distribution/Simple.hs b/Cabal/Distribution/Simple.hs index 5543765a10d..156ce1180bf 100644 --- a/Cabal/Distribution/Simple.hs +++ b/Cabal/Distribution/Simple.hs @@ -108,6 +108,8 @@ import Data.List (unionBy, (\\)) import Distribution.PackageDescription.Parsec +import qualified Data.Text.IO as T + -- | A simple implementation of @main@ for a Cabal setup script. -- It reads the package description file using IO, and performs the -- action specified on the command line. @@ -265,31 +267,34 @@ buildAction hooks flags args = do hooks flags' { buildArgs = args } args showBuildInfoAction :: UserHooks -> ShowBuildInfoFlags -> Args -> IO () -showBuildInfoAction hooks (ShowBuildInfoFlags flags fileOutput) args = do - distPref <- findDistPrefOrDefault (buildDistPref flags) - let verbosity = fromFlag $ buildVerbosity flags +showBuildInfoAction hooks flags args = do + let buildFlags = buildInfoBuildFlags flags + distPref <- findDistPrefOrDefault (buildDistPref buildFlags) + let verbosity = fromFlag $ buildVerbosity buildFlags lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { buildDistPref = toFlag distPref - , buildCabalFilePath = maybeToFlag (cabalFilePath lbi) - } + let buildFlags' = + buildFlags { buildDistPref = toFlag distPref + , buildCabalFilePath = maybeToFlag (cabalFilePath lbi) + } progs <- reconfigurePrograms verbosity - (buildProgramPaths flags') - (buildProgramArgs flags') + (buildProgramPaths buildFlags') + (buildProgramArgs buildFlags') (withPrograms lbi) - pbi <- preBuild hooks args flags' + pbi <- preBuild hooks args buildFlags' let lbi' = lbi { withPrograms = progs } pkg_descr0 = localPkgDescr lbi' pkg_descr = updatePackageDescription pbi pkg_descr0 -- TODO: Somehow don't ignore build hook? - buildInfoString <- showBuildInfo pkg_descr lbi' flags - case fileOutput of - Nothing -> putStr buildInfoString - Just fp -> writeFile fp buildInfoString + buildInfoText <- showBuildInfo pkg_descr lbi' flags + + case buildInfoOutputFile flags of + Nothing -> T.putStr buildInfoText + Just fp -> T.writeFile fp buildInfoText - postBuild hooks args flags' pkg_descr lbi' + postBuild hooks args buildFlags' pkg_descr lbi' replAction :: UserHooks -> ReplFlags -> Args -> IO () replAction hooks flags args = do diff --git a/Cabal/Distribution/Simple/Build.hs b/Cabal/Distribution/Simple/Build.hs index c7e5ebfdb92..c38e47d8fea 100644 --- a/Cabal/Distribution/Simple/Build.hs +++ b/Cabal/Distribution/Simple/Build.hs @@ -31,6 +31,7 @@ module Distribution.Simple.Build ( import Prelude () import Distribution.Compat.Prelude import Distribution.Utils.Generic +import Distribution.Utils.Json import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.ComponentRequestedSpec @@ -76,7 +77,6 @@ import Distribution.Simple.Configure import Distribution.Simple.Register import Distribution.Simple.Test.LibV09 import Distribution.Simple.Utils -import Distribution.Simple.Utils.Json import Distribution.System import Distribution.Pretty @@ -89,6 +89,7 @@ import Control.Monad import qualified Data.Set as Set import System.FilePath ( (), (<.>), takeDirectory ) import System.Directory ( getCurrentDirectory ) +import qualified Data.Text as Text -- ----------------------------------------------------------------------------- -- |Build the libraries and executables in this package. @@ -133,15 +134,24 @@ build pkg_descr lbi flags suffixes = do showBuildInfo :: PackageDescription -- ^ Mostly information from the .cabal file - -> LocalBuildInfo -- ^ Configuration information - -> BuildFlags -- ^ Flags that the user passed to build - -> IO String + -> LocalBuildInfo -- ^ Configuration information + -> ShowBuildInfoFlags -- ^ Flags that the user passed to build + -> IO Text.Text showBuildInfo pkg_descr lbi flags = do - let verbosity = fromFlag (buildVerbosity flags) - targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs flags) + let buildFlags = buildInfoBuildFlags flags + verbosity = fromFlag (buildVerbosity buildFlags) + targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs buildFlags) + pwd <- getCurrentDirectory let targetsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) - doc = mkBuildInfo pkg_descr lbi flags targetsToBuild - return $ renderJson doc "" + result + | fromFlag (buildInfoComponentsOnly flags) = + let components = map (mkComponentInfo pwd pkg_descr lbi . targetCLBI) + targetsToBuild + in Text.unlines $ map (flip renderJson mempty) components + | otherwise = + let json = mkBuildInfo pwd pkg_descr lbi buildFlags targetsToBuild + in renderJson json mempty + return result repl :: PackageDescription -- ^ Mostly information from the .cabal file diff --git a/Cabal/Distribution/Simple/BuildTarget.hs b/Cabal/Distribution/Simple/BuildTarget.hs index 8d1ce3687c1..b702e16ec38 100644 --- a/Cabal/Distribution/Simple/BuildTarget.hs +++ b/Cabal/Distribution/Simple/BuildTarget.hs @@ -66,7 +66,7 @@ import System.Directory ( doesFileExist, doesDirectoryExist ) import qualified Data.Map as Map -- | Take a list of 'String' build targets, and parse and validate them --- into actual 'TargetInfo's to be built/registered/whatever. +-- into actual 'TargetInfo's to be built\/registered\/whatever. readTargetInfos :: Verbosity -> PackageDescription -> LocalBuildInfo -> [String] -> IO [TargetInfo] readTargetInfos verbosity pkg_descr lbi args = do build_targets <- readBuildTargets verbosity pkg_descr args diff --git a/Cabal/Distribution/Simple/Haddock.hs b/Cabal/Distribution/Simple/Haddock.hs index 119455c6385..07d898c6321 100644 --- a/Cabal/Distribution/Simple/Haddock.hs +++ b/Cabal/Distribution/Simple/Haddock.hs @@ -559,7 +559,9 @@ runHaddock verbosity tmpFileOpts comp platform haddockProg args renderArgs verbosity tmpFileOpts haddockVersion comp platform args $ \(flags,result)-> do - runProgram verbosity haddockProg flags + haddockOut <- getProgramOutput verbosity haddockProg flags + unless (verbosity <= silent) $ + putStr haddockOut notice verbosity $ "Documentation created: " ++ result diff --git a/Cabal/Distribution/Simple/Setup.hs b/Cabal/Distribution/Simple/Setup.hs index 4f1e06e0b73..a03c0cf0f35 100644 --- a/Cabal/Distribution/Simple/Setup.hs +++ b/Cabal/Distribution/Simple/Setup.hs @@ -2217,15 +2217,18 @@ optionNumJobs get set = -- ------------------------------------------------------------ data ShowBuildInfoFlags = ShowBuildInfoFlags - { buildInfoBuildFlags :: BuildFlags - , buildInfoOutputFile :: Maybe FilePath + { buildInfoBuildFlags :: BuildFlags + , buildInfoOutputFile :: Maybe FilePath + , buildInfoComponentsOnly :: Flag Bool + -- ^ If 'True' then only print components, each separated by a newline } deriving (Show, Typeable) defaultShowBuildFlags :: ShowBuildInfoFlags defaultShowBuildFlags = ShowBuildInfoFlags - { buildInfoBuildFlags = defaultBuildFlags - , buildInfoOutputFile = Nothing + { buildInfoBuildFlags = defaultBuildFlags + , buildInfoOutputFile = Nothing + , buildInfoComponentsOnly = Flag False } showBuildInfoCommand :: ProgramDb -> CommandUI ShowBuildInfoFlags @@ -2262,8 +2265,12 @@ showBuildInfoCommand progDb = CommandUI ++ [ option [] ["buildinfo-json-output"] "Write the result to the given file instead of stdout" - buildInfoOutputFile (\pf flags -> flags { buildInfoOutputFile = pf }) + buildInfoOutputFile (\v flags -> flags { buildInfoOutputFile = v }) (reqArg' "FILE" Just (maybe [] pure)) + , option [] ["buildinfo-components-only"] + "Print out only the component info, each separated by a newline" + buildInfoComponentsOnly (\v flags -> flags { buildInfoComponentsOnly = v}) + trueArg ] } diff --git a/Cabal/Distribution/Simple/ShowBuildInfo.hs b/Cabal/Distribution/Simple/ShowBuildInfo.hs index 74f5de2d41b..d6e9c73102f 100644 --- a/Cabal/Distribution/Simple/ShowBuildInfo.hs +++ b/Cabal/Distribution/Simple/ShowBuildInfo.hs @@ -2,7 +2,7 @@ -- This module defines a simple JSON-based format for exporting basic -- information about a Cabal package and the compiler configuration Cabal -- would use to build it. This can be produced with the --- @cabal new-show-build-info@ command. +-- @cabal show-build-info@ command. -- -- -- This format is intended for consumption by external tooling and should @@ -54,7 +54,12 @@ -- Note: At the moment this is only supported when using the GHC compiler. -- -module Distribution.Simple.ShowBuildInfo (mkBuildInfo) where +{-# LANGUAGE OverloadedStrings #-} + +module Distribution.Simple.ShowBuildInfo + ( mkBuildInfo, mkBuildInfo', mkCompilerInfo, mkComponentInfo ) where + +import qualified Data.Text as T import Distribution.Compat.Prelude import Prelude () @@ -70,7 +75,7 @@ import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program import Distribution.Simple.Setup import Distribution.Simple.Utils (cabalVersion) -import Distribution.Simple.Utils.Json +import Distribution.Utils.Json import Distribution.Types.TargetInfo import Distribution.Text import Distribution.Pretty @@ -78,68 +83,79 @@ import Distribution.Pretty -- | Construct a JSON document describing the build information for a -- package. mkBuildInfo - :: PackageDescription -- ^ Mostly information from the .cabal file + :: FilePath -- ^ The source directory of the package + -> PackageDescription -- ^ Mostly information from the .cabal file -> LocalBuildInfo -- ^ Configuration information -> BuildFlags -- ^ Flags that the user passed to build -> [TargetInfo] -> Json -mkBuildInfo pkg_descr lbi _flags targetsToBuild = info - where - targetToNameAndLBI target = - (componentLocalName $ targetCLBI target, targetCLBI target) - componentsToBuild = map targetToNameAndLBI targetsToBuild - (.=) :: String -> Json -> (String, Json) - k .= v = (k, v) +mkBuildInfo wdir pkg_descr lbi _flags targetsToBuild = + JsonObject $ + mkBuildInfo' (mkCompilerInfo (withPrograms lbi) (compiler lbi)) + (map (mkComponentInfo wdir pkg_descr lbi . targetCLBI) targetsToBuild) - info = JsonObject - [ "cabal-version" .= JsonString (display cabalVersion) - , "compiler" .= mkCompilerInfo - , "components" .= JsonArray (map mkComponentInfo componentsToBuild) - ] +-- | A variant of 'mkBuildInfo' if you need to call 'mkCompilerInfo' and +-- 'mkComponentInfo' yourself. +mkBuildInfo' + :: Json -- ^ The 'Json' from 'mkCompilerInfo' + -> [Json] -- ^ The 'Json' from 'mkComponentInfo' + -> [(T.Text, Json)] +mkBuildInfo' cmplrInfo componentInfos = + [ "cabal-version" .= JsonString (T.pack (display cabalVersion)) + , "compiler" .= cmplrInfo + , "components" .= JsonArray componentInfos + ] - mkCompilerInfo = JsonObject - [ "flavour" .= JsonString (prettyShow $ compilerFlavor $ compiler lbi) - , "compiler-id" .= JsonString (showCompilerId $ compiler lbi) - , "path" .= path - ] - where - path = maybe JsonNull (JsonString . programPath) - $ (flavorToProgram . compilerFlavor $ compiler lbi) - >>= flip lookupProgram (withPrograms lbi) +mkCompilerInfo :: ProgramDb -> Compiler -> Json +mkCompilerInfo programDb cmplr = JsonObject + [ "flavour" .= JsonString (T.pack (prettyShow $ compilerFlavor cmplr)) + , "compiler-id" .= JsonString (T.pack (showCompilerId cmplr)) + , "path" .= path + ] + where + path = maybe JsonNull (JsonString . T.pack . programPath) + $ (flavorToProgram . compilerFlavor $ cmplr) + >>= flip lookupProgram programDb - flavorToProgram :: CompilerFlavor -> Maybe Program - flavorToProgram GHC = Just ghcProgram - flavorToProgram GHCJS = Just ghcjsProgram - flavorToProgram UHC = Just uhcProgram - flavorToProgram JHC = Just jhcProgram - flavorToProgram _ = Nothing + flavorToProgram :: CompilerFlavor -> Maybe Program + flavorToProgram GHC = Just ghcProgram + flavorToProgram GHCJS = Just ghcjsProgram + flavorToProgram UHC = Just uhcProgram + flavorToProgram JHC = Just jhcProgram + flavorToProgram _ = Nothing - mkComponentInfo (name, clbi) = JsonObject - [ "type" .= JsonString compType - , "name" .= JsonString (prettyShow name) - , "unit-id" .= JsonString (prettyShow $ componentUnitId clbi) - , "compiler-args" .= JsonArray (map JsonString $ getCompilerArgs bi lbi clbi) - , "modules" .= JsonArray (map (JsonString . display) modules) - , "src-files" .= JsonArray (map JsonString sourceFiles) - , "src-dirs" .= JsonArray (map JsonString $ hsSourceDirs bi) - ] - where - bi = componentBuildInfo comp - comp = fromMaybe (error $ "mkBuildInfo: no component " ++ prettyShow name) $ lookupComponent pkg_descr name - compType = case comp of - CLib _ -> "lib" - CExe _ -> "exe" - CTest _ -> "test" - CBench _ -> "bench" - CFLib _ -> "flib" - modules = case comp of - CLib lib -> explicitLibModules lib - CExe exe -> exeModules exe - _ -> [] - sourceFiles = case comp of - CLib _ -> [] - CExe exe -> [modulePath exe] - _ -> [] +mkComponentInfo :: FilePath -> PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> Json +mkComponentInfo wdir pkg_descr lbi clbi = JsonObject $ + [ "type" .= JsonString compType + , "name" .= JsonString (T.pack $ prettyShow name) + , "unit-id" .= JsonString (T.pack $ prettyShow $ componentUnitId clbi) + , "compiler-args" .= JsonArray (map JsonString $ getCompilerArgs bi lbi clbi) + , "modules" .= JsonArray (map (JsonString . T.pack . display) modules) + , "src-files" .= JsonArray (map (JsonString . T.pack) sourceFiles) + , "hs-src-dirs" .= JsonArray (map (JsonString . T.pack) $ hsSourceDirs bi) + , "src-dir" .= JsonString (T.pack wdir) + ] <> cabalFile + where + name = componentLocalName clbi + bi = componentBuildInfo comp + comp = fromMaybe (error $ "mkBuildInfo: no component " ++ prettyShow name) $ lookupComponent pkg_descr name + compType = case comp of + CLib _ -> "lib" + CExe _ -> "exe" + CTest _ -> "test" + CBench _ -> "bench" + CFLib _ -> "flib" + modules = case comp of + CLib lib -> explicitLibModules lib + CExe exe -> exeModules exe + _ -> [] + sourceFiles = case comp of + CLib _ -> [] + CExe exe -> [modulePath exe] + _ -> [] + cabalFile + | Just fp <- pkgDescrFile lbi = [("cabal-file", JsonString (T.pack fp))] + | otherwise = [] -- | Get the command-line arguments that would be passed -- to the compiler to build the given component. @@ -147,7 +163,7 @@ getCompilerArgs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo - -> [String] + -> [T.Text] getCompilerArgs bi lbi clbi = case compilerFlavor $ compiler lbi of GHC -> ghc @@ -156,6 +172,7 @@ getCompilerArgs bi lbi clbi = "build arguments for compiler "++show c where -- This is absolutely awful - ghc = GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts + ghc = T.pack <$> + GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts where baseOpts = GHC.componentGhcOptions normal lbi bi clbi (buildDir lbi) diff --git a/Cabal/Distribution/Simple/Utils/Json.hs b/Cabal/Distribution/Simple/Utils/Json.hs deleted file mode 100644 index f90f2f38aa2..00000000000 --- a/Cabal/Distribution/Simple/Utils/Json.hs +++ /dev/null @@ -1,46 +0,0 @@ --- | Utility json lib for Cabal --- TODO: Remove it again. -module Distribution.Simple.Utils.Json - ( Json(..) - , renderJson - ) where - -data Json = JsonArray [Json] - | JsonBool !Bool - | JsonNull - | JsonNumber !Int - | JsonObject [(String, Json)] - | JsonString !String - -renderJson :: Json -> ShowS -renderJson (JsonArray objs) = - surround "[" "]" $ intercalate "," $ map renderJson objs -renderJson (JsonBool True) = showString "true" -renderJson (JsonBool False) = showString "false" -renderJson JsonNull = showString "null" -renderJson (JsonNumber n) = shows n -renderJson (JsonObject attrs) = - surround "{" "}" $ intercalate "," $ map render attrs - where - render (k,v) = (surround "\"" "\"" $ showString' k) . showString ":" . renderJson v -renderJson (JsonString s) = surround "\"" "\"" $ showString' s - -surround :: String -> String -> ShowS -> ShowS -surround begin end middle = showString begin . middle . showString end - -showString' :: String -> ShowS -showString' xs = showStringWorker xs - where - showStringWorker :: String -> ShowS - showStringWorker ('\"':as) = showString "\\\"" . showStringWorker as - showStringWorker ('\\':as) = showString "\\\\" . showStringWorker as - showStringWorker ('\'':as) = showString "\\\'" . showStringWorker as - showStringWorker (x:as) = showString [x] . showStringWorker as - showStringWorker [] = showString "" - -intercalate :: String -> [ShowS] -> ShowS -intercalate sep = go - where - go [] = id - go [x] = x - go (x:xs) = x . showString' sep . go xs diff --git a/Cabal/Distribution/Utils/Json.hs b/Cabal/Distribution/Utils/Json.hs new file mode 100644 index 00000000000..15573c9c05a --- /dev/null +++ b/Cabal/Distribution/Utils/Json.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Extremely simple JSON helper. Don't do anything too fancy with this! +module Distribution.Utils.Json + ( Json(..) + , (.=) + , renderJson + ) where + +import Data.Text (Text) +import qualified Data.Text as Text + +data Json = JsonArray [Json] + | JsonBool !Bool + | JsonNull + | JsonNumber !Int + | JsonObject [(Text, Json)] + | JsonRaw !Text + | JsonString !Text + +-- | A type to mirror 'ShowS' +type ShowT = Text -> Text + +renderJson :: Json -> ShowT +renderJson (JsonArray objs) = + surround "[" "]" $ intercalate "," $ map renderJson objs +renderJson (JsonBool True) = showText "true" +renderJson (JsonBool False) = showText "false" +renderJson JsonNull = showText "null" +renderJson (JsonNumber n) = showText $ Text.pack (show n) +renderJson (JsonObject attrs) = + surround "{" "}" $ intercalate "," $ map render attrs + where + render (k,v) = (surround "\"" "\"" $ showText' k) . showText ":" . renderJson v +renderJson (JsonString s) = surround "\"" "\"" $ showText' s +renderJson (JsonRaw s) = showText s + +surround :: Text -> Text -> ShowT -> ShowT +surround begin end middle = showText begin . middle . showText end + +showText :: Text -> ShowT +showText = (<>) + +showText' :: Text -> ShowT +showText' xs = showStringWorker xs + where + showStringWorker :: Text -> ShowT + showStringWorker t = + case Text.uncons t of + Just ('\r', as) -> showText "\\r" . showStringWorker as + Just ('\n', as) -> showText "\\n" . showStringWorker as + Just ('\"', as) -> showText "\\\"" . showStringWorker as + Just ('\\', as) -> showText "\\\\" . showStringWorker as + Just (x, as) -> showText (Text.singleton x) . showStringWorker as + Nothing -> showText "" + +intercalate :: Text -> [ShowT] -> ShowT +intercalate sep = go + where + go [] = id + go [x] = x + go (x:xs) = x . showText' sep . go xs + +(.=) :: Text -> Json -> (Text, Json) +k .= v = (k, v) diff --git a/cabal-install/Distribution/Client/CmdBench.hs b/cabal-install/Distribution/Client/CmdBench.hs index 629df6fb172..a66ed7b86ab 100644 --- a/cabal-install/Distribution/Client/CmdBench.hs +++ b/cabal-install/Distribution/Client/CmdBench.hs @@ -87,7 +87,8 @@ benchAction flags@NixStyleFlags {..} targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) (Just BenchKind) targetStrings + =<< readTargetSelectors (localPackages baseCtx) + (Just BenchKind) flags targetStrings buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do @@ -120,7 +121,7 @@ benchAction flags@NixStyleFlags {..} targetStrings globalFlags = do runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - cliConfig = commandLineFlagsToProjectConfig globalFlags flags + cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here -- | This defines what a 'TargetSelector' means for the @bench@ command. diff --git a/cabal-install/Distribution/Client/CmdBuild.hs b/cabal-install/Distribution/Client/CmdBuild.hs index 2fe43f596d1..ea086a80151 100644 --- a/cabal-install/Distribution/Client/CmdBuild.hs +++ b/cabal-install/Distribution/Client/CmdBuild.hs @@ -106,7 +106,8 @@ buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings glo targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings + =<< readTargetSelectors (localPackages baseCtx) + Nothing flags targetStrings buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do diff --git a/cabal-install/Distribution/Client/CmdErrorMessages.hs b/cabal-install/Distribution/Client/CmdErrorMessages.hs index 32abb2395cb..bbd2058a719 100644 --- a/cabal-install/Distribution/Client/CmdErrorMessages.hs +++ b/cabal-install/Distribution/Client/CmdErrorMessages.hs @@ -21,7 +21,7 @@ import Distribution.Client.TargetSelector import Distribution.Client.TargetProblem ( TargetProblem(..), TargetProblem' ) import Distribution.Client.TargetSelector - ( ComponentKind(..), ComponentKindFilter, TargetSelector(..), + ( ComponentKind(..), TargetSelector(..), componentKind, showTargetSelector ) import Distribution.Package @@ -170,7 +170,7 @@ targetSelectorRefersToPkgs (TargetPackageNamed _ mkfilter) = isNothing mkfilter targetSelectorRefersToPkgs TargetComponent{} = False targetSelectorRefersToPkgs TargetComponentUnknown{} = False -targetSelectorFilter :: TargetSelector -> Maybe ComponentKindFilter +targetSelectorFilter :: TargetSelector -> Maybe ComponentKind targetSelectorFilter (TargetPackage _ _ mkfilter) = mkfilter targetSelectorFilter (TargetPackageNamed _ mkfilter) = mkfilter targetSelectorFilter (TargetAllPackages mkfilter) = mkfilter diff --git a/cabal-install/Distribution/Client/CmdHaddock.hs b/cabal-install/Distribution/Client/CmdHaddock.hs index 50d8d745208..04a83dd0e88 100644 --- a/cabal-install/Distribution/Client/CmdHaddock.hs +++ b/cabal-install/Distribution/Client/CmdHaddock.hs @@ -76,7 +76,8 @@ haddockAction flags@NixStyleFlags {..} targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig HaddockCommand targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings + =<< readTargetSelectors (localPackages baseCtx) Nothing flags + targetStrings buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do diff --git a/cabal-install/Distribution/Client/CmdInstall.hs b/cabal-install/Distribution/Client/CmdInstall.hs index 5e431d8f7aa..37756908ab4 100644 --- a/cabal-install/Distribution/Client/CmdInstall.hs +++ b/cabal-install/Distribution/Client/CmdInstall.hs @@ -240,8 +240,8 @@ installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targe else do targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages localBaseCtx) - Nothing targetStrings'' + =<< readTargetSelectors (localPackages localBaseCtx) Nothing flags + targetStrings'' (specs, selectors) <- getSpecsAndTargetSelectors @@ -430,7 +430,7 @@ getSpecsAndTargetSelectors -> [TargetSelector] -> DistDirLayout -> ProjectBaseContext - -> Maybe ComponentKindFilter + -> Maybe ComponentKind -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector]) getSpecsAndTargetSelectors verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter = withInstallPlan reducedVerbosity localBaseCtx $ \elaboratedPlan _ -> do diff --git a/cabal-install/Distribution/Client/CmdListBin.hs b/cabal-install/Distribution/Client/CmdListBin.hs index fbdef44e70b..d4f611ccfb9 100644 --- a/cabal-install/Distribution/Client/CmdListBin.hs +++ b/cabal-install/Distribution/Client/CmdListBin.hs @@ -77,7 +77,7 @@ listbinAction flags@NixStyleFlags{..} args globalFlags = do -- elaborate target selectors targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors localPkgs Nothing [target] + =<< readTargetSelectors localPkgs Nothing flags [target] buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do diff --git a/cabal-install/Distribution/Client/CmdRepl.hs b/cabal-install/Distribution/Client/CmdRepl.hs index ed9c90be8fd..ec0ea8b9dcf 100644 --- a/cabal-install/Distribution/Client/CmdRepl.hs +++ b/cabal-install/Distribution/Client/CmdRepl.hs @@ -204,7 +204,7 @@ replCommand = Client.installCommand { replAction :: NixStyleFlags (ReplFlags, EnvFlags) -> [String] -> GlobalFlags -> IO () replAction flags@NixStyleFlags { extraFlags = (replFlags, envFlags), ..} targetStrings globalFlags = do let - with = withProject cliConfig verbosity targetStrings + with = withProject flags cliConfig verbosity targetStrings without config = withoutProject (config <> cliConfig) verbosity targetStrings (baseCtx, targetSelectors, finalizer, replType) <- @@ -338,13 +338,14 @@ data ReplType = ProjectRepl -- 7.6, though. 🙁 deriving (Show, Eq) -withProject :: ProjectConfig -> Verbosity -> [String] +withProject :: NixStyleFlags a -> ProjectConfig -> Verbosity -> [String] -> IO (ProjectBaseContext, [TargetSelector], IO (), ReplType) -withProject cliConfig verbosity targetStrings = do +withProject flags cliConfig verbosity targetStrings = do baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) (Just LibKind) targetStrings + =<< readTargetSelectors (localPackages baseCtx) (Just LibKind) + flags targetStrings return (baseCtx, targetSelectors, return (), ProjectRepl) diff --git a/cabal-install/Distribution/Client/CmdRun.hs b/cabal-install/Distribution/Client/CmdRun.hs index 3d98380f04c..66d361b0cdc 100644 --- a/cabal-install/Distribution/Client/CmdRun.hs +++ b/cabal-install/Distribution/Client/CmdRun.hs @@ -182,7 +182,7 @@ runAction flags@NixStyleFlags {..} targetStrings globalFlags = do else reportTargetSelectorProblems verbosity err (baseCtx', targetSelectors) <- - readTargetSelectors (localPackages baseCtx) (Just ExeKind) (take 1 targetStrings) + readTargetSelectors (localPackages baseCtx) (Just ExeKind) flags (take 1 targetStrings) >>= \case Left err@(TargetSelectorNoTargetsInProject:_) | (script:_) <- targetStrings -> scriptOrError script err diff --git a/cabal-install/Distribution/Client/CmdSdist.hs b/cabal-install/Distribution/Client/CmdSdist.hs index adbe04afd07..4efd7a03793 100644 --- a/cabal-install/Distribution/Client/CmdSdist.hs +++ b/cabal-install/Distribution/Client/CmdSdist.hs @@ -19,7 +19,7 @@ import Distribution.Client.NixStyleOptions ( NixStyleFlags (..), defaultNixStyleFlags ) import Distribution.Client.TargetSelector ( TargetSelector(..), ComponentKind - , readTargetSelectors, reportTargetSelectorProblems ) + , readTargetSelectors', reportTargetSelectorProblems ) import Distribution.Client.Setup ( GlobalFlags(..) ) import Distribution.Solver.Types.SourcePackage @@ -142,7 +142,7 @@ sdistAction (ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do let localPkgs = localPackages baseCtx targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors localPkgs Nothing targetStrings + =<< readTargetSelectors' localPkgs Nothing targetStrings -- elaborate path, create target directory mOutputPath' <- case mOutputPath of diff --git a/cabal-install/Distribution/Client/CmdShowBuildInfo.hs b/cabal-install/Distribution/Client/CmdShowBuildInfo.hs new file mode 100644 index 00000000000..489a3b7768b --- /dev/null +++ b/cabal-install/Distribution/Client/CmdShowBuildInfo.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE RecordWildCards, OverloadedStrings #-} +-- | cabal-install CLI command: show-build-info +-- +module Distribution.Client.CmdShowBuildInfo ( + -- * The @show-build-info@ CLI and action + showBuildInfoCommand, + showBuildInfoAction + ) where + +import Distribution.Client.Compat.Prelude + (catMaybes, fromMaybe ) +import Distribution.Client.ProjectOrchestration +import Distribution.Client.CmdErrorMessages +import Distribution.Client.TargetProblem + ( TargetProblem (..), TargetProblem' ) + +import Distribution.Client.Setup + ( GlobalFlags ) +import Distribution.Simple.Setup + (Flag(..), haddockVerbosity, configVerbosity, fromFlagOrDefault ) +import Distribution.Simple.Command + ( CommandUI(..), option, reqArg', usageAlternatives ) +import Distribution.Verbosity + (Verbosity, silent ) +import Distribution.Simple.Utils + (wrapText, die' ) +import Distribution.Types.UnitId + ( mkUnitId ) +import Distribution.Pretty + ( prettyShow ) + +import qualified Data.Map as Map +import qualified Distribution.Simple.Setup as Cabal +import Distribution.Client.ProjectBuilding.Types +import Distribution.Client.ProjectPlanning.Types +import Distribution.Client.NixStyleOptions + ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) +import Distribution.Client.DistDirLayout + (distProjectRootDirectory ) + +import Distribution.Simple.ShowBuildInfo +import Distribution.Utils.Json + +import Control.Monad (forM_, unless) +import Data.Either +import qualified Data.Text as T +import qualified Data.Text.IO as T + +showBuildInfoCommand :: CommandUI (NixStyleFlags ShowBuildInfoFlags) +showBuildInfoCommand = CommandUI { + commandName = "show-build-info", + commandSynopsis = "Show project build information", + commandUsage = usageAlternatives "show-build-info" [ "[TARGETS] [FLAGS]" ], + commandDescription = Just $ \_ -> wrapText $ + "Provides detailed json output for the given package.\n" + ++ "Contains information about the different build components and compiler flags.\n", + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " show-build-info\n" + ++ " Shows build information about the current package\n" + ++ " " ++ pname ++ " show-build-info .\n" + ++ " Shows build information about the current package\n" + ++ " " ++ pname ++ " show-build-info ./pkgname \n" + ++ " Shows build information about the package located in './pkgname'\n" + ++ cmdCommonHelpTextNewBuildBeta, + commandOptions = nixStyleOptions $ \_ -> + [ option [] ["buildinfo-json-output"] + "Write the result to the given file instead of stdout" + buildInfoOutputFile (\pf flags -> flags { buildInfoOutputFile = pf }) + (reqArg' "FILE" Just (maybe [] pure)), + option [] ["unit-ids-json"] + "Show build-info only for selected unit-id's." + buildInfoUnitIds (\pf flags -> flags { buildInfoUnitIds = pf }) + (reqArg' "UNIT-ID" (Just . words) (fromMaybe [])) + ], + commandDefaultFlags = defaultNixStyleFlags defaultShowBuildInfoFlags + } + +data ShowBuildInfoFlags = ShowBuildInfoFlags + { buildInfoOutputFile :: Maybe FilePath + , buildInfoUnitIds :: Maybe [String] + } + +defaultShowBuildInfoFlags :: ShowBuildInfoFlags +defaultShowBuildInfoFlags = ShowBuildInfoFlags + { buildInfoOutputFile = Nothing + , buildInfoUnitIds = Nothing + } + +-- | The @show-build-info@ exports information about a package and the compiler +-- configuration used to build it as JSON, that can be used by other tooling. +-- See "Distribution.Simple.ShowBuildInfo" for more information. +showBuildInfoAction :: NixStyleFlags ShowBuildInfoFlags -> [String] -> GlobalFlags -> IO () +showBuildInfoAction flags@NixStyleFlags { extraFlags = (ShowBuildInfoFlags fileOutput unitIdStrs), ..} + targetStrings globalFlags = do + baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand + let baseCtx' = baseCtx + { buildSettings = (buildSettings baseCtx) { buildSettingDryRun = True } + } + + targetSelectors <- either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages baseCtx') Nothing flags targetStrings + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx' $ \elaboratedPlan -> do + -- Interpret the targets on the command line as build targets + -- (as opposed to say repl or haddock targets). + + targets' <- either (reportShowBuildInfoTargetProblems verbosity) return + $ resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + let unitIds = map mkUnitId <$> unitIdStrs + + -- Check that all the unit ids exist + forM_ (fromMaybe [] unitIds) $ \ui -> + unless (Map.member ui targets') $ + die' verbosity ("No unit " ++ prettyShow ui) + + -- Filter out targets that aren't in the specified unit ids + let targets = Map.filterWithKey (\k _ -> maybe True (elem k) unitIds) targets' + elaboratedPlan' = pruneInstallPlanToTargets + TargetActionBuildInfo + targets + elaboratedPlan + + return (elaboratedPlan', targets) + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + + -- We can ignore the errors here, since runProjectPostBuildPhase should + -- have already died and reported them if they exist + let (_errs, buildResults) = partitionEithers $ Map.elems buildOutcomes + + let componentBuildInfos = + concatMap T.lines $ -- Component infos are returned each on a newline + catMaybes (buildResultBuildInfo <$> buildResults) + + let compilerInfo = mkCompilerInfo + (pkgConfigCompilerProgs (elaboratedShared buildCtx)) + (pkgConfigCompiler (elaboratedShared buildCtx)) + + components = map JsonRaw componentBuildInfos + fields = mkBuildInfo' compilerInfo components + json = JsonObject $ fields <> + [ ("project-root", JsonString (T.pack (distProjectRootDirectory (distDirLayout baseCtx)))) + ] + res = renderJson json "" + + case fileOutput of + Nothing -> T.putStrLn res + Just fp -> T.writeFile fp res + + where + -- Default to silent verbosity otherwise it will pollute our json output + verbosity = fromFlagOrDefault silent (configVerbosity configFlags) + -- Also shut up haddock since it dumps warnings to stdout + flags' = flags { haddockFlags = haddockFlags { haddockVerbosity = Flag silent } + , configFlags = configFlags { Cabal.configTests = Flag True + , Cabal.configBenchmarks = Flag True + } + } + cliConfig = commandLineFlagsToProjectConfig globalFlags flags' + mempty -- ClientInstallFlags, not needed here + +-- | This defines what a 'TargetSelector' means for the @show-build-info@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @show-build-info@ command select all components. Unlike the @build@ +-- command, we want to show info for tests and benchmarks even without the +-- @--enable-tests@\/@--enable-benchmarks@ flag set. +selectPackageTargets :: TargetSelector + -> [AvailableTarget k] -> Either TargetProblem' [k] +selectPackageTargets targetSelector targets + + -- If there are any buildable targets then we select those + | not (null targetsBuildable) + = Right targetsBuildable + + -- If there are targets but none are buildable then we report those + | not (null targets) + = Left (TargetProblemNoneEnabled targetSelector targets') + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + targets' = forgetTargetsDetail targets + targetsBuildable = selectBuildableTargets targets + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @show-build-info@ command we just need the basic checks on being buildable etc. +-- +selectComponentTarget :: SubComponentTarget + -> AvailableTarget k -> Either TargetProblem' k +selectComponentTarget = selectComponentTargetBasic + + +reportShowBuildInfoTargetProblems :: Verbosity -> [TargetProblem'] -> IO a +reportShowBuildInfoTargetProblems verbosity problems = + reportTargetProblems verbosity "show-build-info" problems diff --git a/cabal-install/Distribution/Client/CmdTest.hs b/cabal-install/Distribution/Client/CmdTest.hs index cc1f49ed398..6ebf2215aee 100644 --- a/cabal-install/Distribution/Client/CmdTest.hs +++ b/cabal-install/Distribution/Client/CmdTest.hs @@ -99,7 +99,8 @@ testAction flags@NixStyleFlags {..} targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) (Just TestKind) targetStrings + =<< readTargetSelectors (localPackages baseCtx) + (Just TestKind) flags targetStrings buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs index 139eed29425..b1b6d054cd9 100644 --- a/cabal-install/Distribution/Client/Config.hs +++ b/cabal-install/Distribution/Client/Config.hs @@ -428,7 +428,9 @@ instance Semigroup SavedConfig where configAllowOlder = combineMonoid savedConfigureExFlags configAllowOlder, configWriteGhcEnvironmentFilesPolicy - = combine configWriteGhcEnvironmentFilesPolicy + = combine configWriteGhcEnvironmentFilesPolicy, + configPickFirstTarget + = combine configPickFirstTarget } where combine = combine' savedConfigureExFlags diff --git a/cabal-install/Distribution/Client/ProjectBuilding.hs b/cabal-install/Distribution/Client/ProjectBuilding.hs index 134e2249999..24b3299c134 100644 --- a/cabal-install/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/Distribution/Client/ProjectBuilding.hs @@ -97,6 +97,7 @@ import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text.IO as T import Control.Exception (Handler (..), SomeAsyncException, assert, catches, handle) import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory) @@ -456,9 +457,10 @@ checkPackageFileMonitorChanged PackageFileMonitor{..} (MonitorUnchanged buildResult _, MonitorUnchanged _ _) -> return $ Right BuildResult { - buildResultDocs = docsResult, - buildResultTests = testsResult, - buildResultLogFile = Nothing + buildResultDocs = docsResult, + buildResultTests = testsResult, + buildResultLogFile = Nothing, + buildResultBuildInfo = Nothing } where (docsResult, testsResult) = buildResult @@ -1052,9 +1054,10 @@ buildAndInstallUnpackedPackage verbosity noticeProgress ProgressCompleted return BuildResult { - buildResultDocs = docsResult, - buildResultTests = testsResult, - buildResultLogFile = mlogFile + buildResultDocs = docsResult, + buildResultTests = testsResult, + buildResultLogFile = mlogFile, + buildResultBuildInfo = Nothing } where @@ -1299,10 +1302,23 @@ buildInplaceUnpackedPackage verbosity Tar.createTarGzFile dest docDir name notice verbosity $ "Documentation tarball created: " ++ dest + -- Build info phase + buildInfo <- whenBuildInfo $ + -- Write the json to a temporary file to read it, since stdout can get + -- cluttered + withTempDirectory verbosity distTempDirectory "build-info" $ \dir -> do + let fp = dir "out" + setupInteractive + buildInfoCommand + (\v -> (buildInfoFlags v) { Cabal.buildInfoOutputFile = Just fp }) + buildInfoArgs + Just <$> T.readFile fp + return BuildResult { buildResultDocs = docsResult, buildResultTests = testsResult, - buildResultLogFile = Nothing + buildResultLogFile = Nothing, + buildResultBuildInfo = buildInfo } where @@ -1340,6 +1356,10 @@ buildInplaceUnpackedPackage verbosity | hasValidHaddockTargets pkg = action | otherwise = return () + whenBuildInfo action + | null (elabBuildInfoTargets pkg) = return Nothing + | otherwise = action + whenReRegister action = case buildStatus of -- We registered the package already @@ -1384,6 +1404,10 @@ buildInplaceUnpackedPackage verbosity haddockArgs v = flip filterHaddockArgs v $ setupHsHaddockArgs pkg + buildInfoCommand = Cabal.showBuildInfoCommand defaultProgramDb + buildInfoFlags _ = setupHsShowBuildInfoFlags pkg pkgshared verbosity builddir + buildInfoArgs _ = setupHsShowBuildInfoArgs pkg + scriptOptions = setupHsScriptOptions rpkg plan pkgshared distDirLayout srcdir builddir isParallelBuild cacheLock diff --git a/cabal-install/Distribution/Client/ProjectBuilding/Types.hs b/cabal-install/Distribution/Client/ProjectBuilding/Types.hs index f9ac571f3b6..65fc6149ba5 100644 --- a/cabal-install/Distribution/Client/ProjectBuilding/Types.hs +++ b/cabal-install/Distribution/Client/ProjectBuilding/Types.hs @@ -32,6 +32,8 @@ import Distribution.Package (UnitId, PackageId) import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.Simple.LocalBuildInfo (ComponentName) +import Data.Text (Text) + ------------------------------------------------------------------------------ -- Pre-build status: result of the dry run @@ -173,9 +175,10 @@ type BuildOutcome = Either BuildFailure BuildResult -- | Information arising from successfully building a single package. -- data BuildResult = BuildResult { - buildResultDocs :: DocsResult, - buildResultTests :: TestsResult, - buildResultLogFile :: Maybe FilePath + buildResultDocs :: DocsResult, + buildResultTests :: TestsResult, + buildResultLogFile :: Maybe FilePath, + buildResultBuildInfo :: Maybe Text } deriving Show diff --git a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs index 39a0342aa08..df1d2319c72 100644 --- a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs @@ -83,7 +83,7 @@ import qualified Distribution.Deprecated.ParseUtils as ParseUtils import Distribution.Deprecated.ParseUtils ( ParseResult(..), PError(..), syntaxError, PWarning(..) , commaNewLineListFieldParsec, newLineListField, parseTokenQ - , parseHaskellString, showToken + , parseHaskellString, showToken , simpleFieldParsec ) import Distribution.Client.ParseUtils @@ -603,7 +603,9 @@ convertToLegacySharedConfig configAllowOlder = projectConfigAllowOlder, configAllowNewer = projectConfigAllowNewer, configWriteGhcEnvironmentFilesPolicy - = projectConfigWriteGhcEnvironmentFilesPolicy + = projectConfigWriteGhcEnvironmentFilesPolicy, + configPickFirstTarget + = mempty } installFlags = InstallFlags { diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index f331b6eff18..351553f1cca 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning.hs @@ -57,6 +57,8 @@ module Distribution.Client.ProjectPlanning ( setupHsRegisterFlags, setupHsHaddockFlags, setupHsHaddockArgs, + setupHsShowBuildInfoFlags, + setupHsShowBuildInfoArgs, packageHashInputs, @@ -1776,6 +1778,7 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB elabBenchTargets = [] elabReplTarget = Nothing elabHaddockTargets = [] + elabBuildInfoTargets = [] elabBuildHaddocks = perPkgOptionFlag pkgid False packageConfigDocumentation @@ -2565,6 +2568,7 @@ data TargetAction = TargetActionConfigure | TargetActionTest | TargetActionBench | TargetActionHaddock + | TargetActionBuildInfo -- | Given a set of per-package\/per-component targets, take the subset of the -- install plan needed to build those targets. Also, update the package config @@ -2642,6 +2646,7 @@ setRootTargets targetAction perPkgTargetsMap = (Just tgts, TargetActionHaddock) -> foldr setElabHaddockTargets (elab { elabHaddockTargets = tgts , elabBuildHaddocks = True }) tgts + (Just tgts, TargetActionBuildInfo) -> elab { elabBuildInfoTargets = tgts } (Just _, TargetActionRepl) -> error "pruneInstallPlanToTargets: multiple repl targets" @@ -2684,6 +2689,7 @@ pruneInstallPlanPass1 pkgs = , null (elabBenchTargets elab) , isNothing (elabReplTarget elab) , null (elabHaddockTargets elab) + , null (elabBuildInfoTargets elab) ] then Just (installedUnitId elab) else Nothing @@ -3594,6 +3600,22 @@ setupHsHaddockArgs :: ElaboratedConfiguredPackage -> [String] setupHsHaddockArgs elab = map (showComponentTarget (packageId elab)) (elabHaddockTargets elab) +setupHsShowBuildInfoFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.ShowBuildInfoFlags +setupHsShowBuildInfoFlags pkg config verbosity builddir = + Cabal.ShowBuildInfoFlags { + buildInfoBuildFlags = setupHsBuildFlags pkg config verbosity builddir, + buildInfoOutputFile = Nothing, + buildInfoComponentsOnly = toFlag True + } + +setupHsShowBuildInfoArgs :: ElaboratedConfiguredPackage -> [String] +setupHsShowBuildInfoArgs elab = + map (showComponentTarget (packageId elab)) (elabBuildInfoTargets elab) + {- setupHsTestFlags :: ElaboratedConfiguredPackage -> ElaboratedSharedConfig diff --git a/cabal-install/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/Distribution/Client/ProjectPlanning/Types.hs index 1d0e1c5d0ab..bf379a42035 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning/Types.hs @@ -317,6 +317,7 @@ data ElaboratedConfiguredPackage elabBenchTargets :: [ComponentTarget], elabReplTarget :: Maybe ComponentTarget, elabHaddockTargets :: [ComponentTarget], + elabBuildInfoTargets :: [ComponentTarget], elabBuildHaddocks :: Bool, diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index 81b2709989c..6f33029cb03 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -23,7 +23,7 @@ module Distribution.Client.Setup , configureExCommand, ConfigExFlags(..), defaultConfigExFlags , buildCommand, BuildFlags(..) , filterTestFlags - , replCommand, testCommand, benchmarkCommand, testOptions, benchmarkOptions + , replCommand, testCommand, showBuildInfoCommand, benchmarkCommand, testOptions, benchmarkOptions , configureExOptions, reconfigureCommand , installCommand, InstallFlags(..), installOptions, defaultInstallFlags , filterHaddockArgs, filterHaddockFlags, haddockOptions @@ -100,6 +100,7 @@ import Distribution.Simple.Setup , HaddockFlags(..) , CleanFlags(..), DoctestFlags(..) , CopyFlags(..), RegisterFlags(..) + , ShowBuildInfoFlags(..) , readPackageDbList, showPackageDbList , BooleanFlag(..), optionVerbosity , boolOpt, boolOpt', trueArg, falseArg @@ -184,6 +185,7 @@ globalCommand commands = CommandUI { , "outdated" , "haddock" , "hscolour" + , "show-build-info" , "exec" , "new-build" , "new-configure" @@ -270,6 +272,7 @@ globalCommand commands = CommandUI { , addCmd "upload" , addCmd "report" , par + , addCmd "show-build-info" , addCmd "freeze" , addCmd "gen-bounds" , addCmd "outdated" @@ -608,12 +611,15 @@ data ConfigExFlags = ConfigExFlags { configAllowNewer :: Maybe AllowNewer, configAllowOlder :: Maybe AllowOlder, configWriteGhcEnvironmentFilesPolicy - :: Flag WriteGhcEnvironmentFilesPolicy + :: Flag WriteGhcEnvironmentFilesPolicy, + configPickFirstTarget + :: Flag Bool } deriving (Eq, Show, Generic) defaultConfigExFlags :: ConfigExFlags -defaultConfigExFlags = mempty { configSolver = Flag defaultSolver } +defaultConfigExFlags = mempty { configSolver = Flag defaultSolver + , configPickFirstTarget = Flag False } configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags) configureExCommand = configureCommand { @@ -681,6 +687,13 @@ configureExOptions _showOrParseArgs src = (reqArg "always|never|ghc8.4.4+" writeGhcEnvironmentFilesPolicyParser writeGhcEnvironmentFilesPolicyPrinter) + + , option [] ["pick-first-target"] + ("If there's an amibguity in the target selector, then resolve it by" + ++ " choosing the first") + configPickFirstTarget + (\v flags -> flags { configPickFirstTarget = v}) + trueArg ] @@ -2659,7 +2672,7 @@ parsePackageArgs = traverse p where Right pvc -> Right pvc Left err -> Left $ show arg ++ " is not valid syntax for a package name or" - ++ " package dependency. " ++ err + ++ " package dependency. " ++ err showRemoteRepo :: RemoteRepo -> String showRemoteRepo = prettyShow @@ -2681,3 +2694,17 @@ relevantConfigValuesText :: [String] -> String relevantConfigValuesText vs = "Relevant global configuration keys:\n" ++ concat [" " ++ v ++ "\n" |v <- vs] + + +-- ------------------------------------------------------------ +-- * Commands to support show-build-info +-- ------------------------------------------------------------ + +showBuildInfoCommand :: CommandUI ShowBuildInfoFlags +showBuildInfoCommand = parent { + commandDefaultFlags = commandDefaultFlags parent, + commandOptions = + \showOrParseArgs -> commandOptions parent showOrParseArgs + } + where + parent = Cabal.showBuildInfoCommand defaultProgramDb diff --git a/cabal-install/Distribution/Client/TargetProblem.hs b/cabal-install/Distribution/Client/TargetProblem.hs index 14004d50abd..eb059b1ecb0 100644 --- a/cabal-install/Distribution/Client/TargetProblem.hs +++ b/cabal-install/Distribution/Client/TargetProblem.hs @@ -45,8 +45,8 @@ data TargetProblem a | TargetProblemNoSuchPackage PackageId | TargetProblemNoSuchComponent PackageId ComponentName - -- | A custom target problem | CustomTargetProblem a + -- ^ A custom target problem deriving (Eq, Show, Functor) -- | Type alias for a 'TargetProblem' with no user-defined problems/errors. diff --git a/cabal-install/Distribution/Client/TargetSelector.hs b/cabal-install/Distribution/Client/TargetSelector.hs index df01de1f25f..ceb906e29d8 100644 --- a/cabal-install/Distribution/Client/TargetSelector.hs +++ b/cabal-install/Distribution/Client/TargetSelector.hs @@ -19,13 +19,13 @@ module Distribution.Client.TargetSelector ( TargetSelector(..), TargetImplicitCwd(..), ComponentKind(..), - ComponentKindFilter, SubComponentTarget(..), QualLevel(..), componentKind, -- * Reading target selectors readTargetSelectors, + readTargetSelectors', TargetSelectorProblem(..), reportTargetSelectorProblems, showTargetSelector, @@ -66,6 +66,12 @@ import Distribution.Simple.LocalBuildInfo , pkgComponents, componentName, componentBuildInfo ) import Distribution.Types.ForeignLib +import Distribution.Client.NixStyleOptions +import Distribution.Client.Setup + ( ConfigExFlags(..) ) +import Distribution.Simple.Setup + ( fromFlagOrDefault ) + import Distribution.Simple.Utils ( die', lowercase, ordNub ) import Distribution.Client.Utils @@ -130,18 +136,18 @@ data TargetSelector = -- These are always packages that are local to the project. In the case -- that there is more than one, they all share the same directory location. -- - TargetPackage TargetImplicitCwd [PackageId] (Maybe ComponentKindFilter) + TargetPackage TargetImplicitCwd [PackageId] (Maybe ComponentKind) -- | A package specified by name. This may refer to @extra-packages@ from -- the @cabal.project@ file, or a dependency of a known project package or -- could refer to a package from a hackage archive. It needs further -- context to resolve to a specific package. -- - | TargetPackageNamed PackageName (Maybe ComponentKindFilter) + | TargetPackageNamed PackageName (Maybe ComponentKind) -- | All packages, or all components of a particular kind in all packages. -- - | TargetAllPackages (Maybe ComponentKindFilter) + | TargetAllPackages (Maybe ComponentKind) -- | A specific component in a package within the project. -- @@ -167,7 +173,17 @@ data TargetImplicitCwd = TargetImplicitCwd | TargetExplicitNamed data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind deriving (Eq, Ord, Enum, Show) -type ComponentKindFilter = ComponentKind +-- | Whenever there is an ambiguous TargetSelector from some user input, how +-- should it be resolved? +data AmbiguityResolver = + -- | Treat ambiguity as an error + AmbiguityResolverNone + -- | Choose the first target + | AmbiguityResolverFirst + -- | Choose the target component with the specific kind + | AmbiguityResolverKind ComponentKind + | AmbiguityResolverKindFirst ComponentKind + deriving (Eq, Ord, Show) -- | Either the component as a whole or detail about a file or module target -- within a component. @@ -199,30 +215,54 @@ instance Structured SubComponentTarget -- the available packages (and their locations). -- readTargetSelectors :: [PackageSpecifier (SourcePackage (PackageLocation a))] - -> Maybe ComponentKindFilter + -> Maybe ComponentKind -- ^ This parameter is used when there are ambiguous selectors. -- If it is 'Just', then we attempt to resolve ambiguitiy - -- by applying it, since otherwise there is no way to allow - -- contextually valid yet syntactically ambiguous selectors. + -- by applying it, since otherwise there is no way to + -- allow contextually valid yet syntactically ambiguous + -- selectors. -- (#4676, #5461) + -> NixStyleFlags b + -- ^ Used in case @--pick-first-target@ was passed. -> [String] -> IO (Either [TargetSelectorProblem] [TargetSelector]) -readTargetSelectors = readTargetSelectorsWith defaultDirActions +readTargetSelectors pkgs mfilter NixStyleFlags{configExFlags} + = readTargetSelectorsWith defaultDirActions pkgs mfilter + (fromFlagOrDefault False (configPickFirstTarget configExFlags)) + + +-- | Same as 'readTargetSelectors' but in case you don't have 'NixStyleFlags'. +readTargetSelectors' :: [PackageSpecifier (SourcePackage (PackageLocation a))] + -> Maybe ComponentKind + -> [String] + -> IO (Either [TargetSelectorProblem] [TargetSelector]) +readTargetSelectors' pkgs mfilter = + readTargetSelectorsWith defaultDirActions pkgs mfilter False readTargetSelectorsWith :: (Applicative m, Monad m) => DirActions m -> [PackageSpecifier (SourcePackage (PackageLocation a))] - -> Maybe ComponentKindFilter + -> Maybe ComponentKind + -- ^ Filter the target to resolve ambiguity? + -> Bool + -- ^ Pick the first target to resolve ambiguity? -> [String] -> m (Either [TargetSelectorProblem] [TargetSelector]) -readTargetSelectorsWith dirActions@DirActions{} pkgs mfilter targetStrs = +readTargetSelectorsWith dirActions@DirActions{} pkgs mfilter pickFirst targetStrs = case parseTargetStrings targetStrs of ([], usertargets) -> do usertargets' <- traverse (getTargetStringFileStatus dirActions) usertargets knowntargets <- getKnownTargets dirActions pkgs - case resolveTargetSelectors knowntargets usertargets' mfilter of + case resolveTargetSelectors knowntargets usertargets' resolver of ([], btargets) -> return (Right btargets) (problems, _) -> return (Left problems) (strs, _) -> return (Left (map TargetSelectorUnrecognised strs)) + where + resolver + | Just kind <- mfilter + , pickFirst = AmbiguityResolverKindFirst kind + | Just kind <- mfilter = AmbiguityResolverKind kind + | pickFirst = AmbiguityResolverFirst + | otherwise = AmbiguityResolverNone data DirActions m = DirActions { @@ -457,7 +497,7 @@ copyFileStatus src dst = -- resolveTargetSelectors :: KnownTargets -> [TargetStringFileStatus] - -> Maybe ComponentKindFilter + -> AmbiguityResolver -> ([TargetSelectorProblem], [TargetSelector]) -- default local dir target if there's no given target: @@ -478,10 +518,10 @@ resolveTargetSelectors knowntargets targetStrs mfilter = $ targetStrs resolveTargetSelector :: KnownTargets - -> Maybe ComponentKindFilter + -> AmbiguityResolver -> TargetStringFileStatus -> Either TargetSelectorProblem TargetSelector -resolveTargetSelector knowntargets@KnownTargets{..} mfilter targetStrStatus = +resolveTargetSelector knowntargets@KnownTargets{..} resolver targetStrStatus = case findMatch (matcher targetStrStatus) of Unambiguous _ @@ -496,10 +536,27 @@ resolveTargetSelector knowntargets@KnownTargets{..} mfilter targetStrStatus = | projectIsEmpty -> Left TargetSelectorNoTargetsInProject | otherwise -> Left (classifyMatchErrors errs) + -- Try to resolve the ambiguity with a kind filter Ambiguous _ targets - | Just kfilter <- mfilter + | AmbiguityResolverKind kfilter <- resolver , [target] <- applyKindFilter kfilter targets -> Right target + -- If we have a filter and want to pick from the first + Ambiguous _ targets + | AmbiguityResolverKindFirst kfilter <- resolver + , target:_ <- applyKindFilter kfilter targets -> Right target + + -- Same case as above, except there weren't any filter matches + Ambiguous _ targets + | AmbiguityResolverKindFirst _ <- resolver + , target:_ <- targets -> Right target + + -- Just pick the first of any + Ambiguous _ targets + | AmbiguityResolverFirst <- resolver + , target:_ <- targets -> Right target + + -- A truly, unresolvable ambiguity Ambiguous exactMatch targets -> case disambiguateTargetSelectors matcher targetStrStatus exactMatch @@ -559,7 +616,7 @@ resolveTargetSelector knowntargets@KnownTargets{..} mfilter targetStrStatus = = innerErr (Just (kind,thing)) m innerErr c m = (c,m) - applyKindFilter :: ComponentKindFilter -> [TargetSelector] -> [TargetSelector] + applyKindFilter :: ComponentKind -> [TargetSelector] -> [TargetSelector] applyKindFilter kfilter = filter go where go (TargetPackage _ _ (Just filter')) = kfilter == filter' diff --git a/cabal-install/Distribution/Client/Utils.hs b/cabal-install/Distribution/Client/Utils.hs index 0ff2aa1c45a..43e49419c3b 100644 --- a/cabal-install/Distribution/Client/Utils.hs +++ b/cabal-install/Distribution/Client/Utils.hs @@ -104,8 +104,8 @@ removeExistingFile path = do -- it will clean up the file afterwards, it's lenient if the file is -- moved\/deleted. -- -withTempFileName :: FilePath - -> String +withTempFileName :: FilePath -- ^ Directory to create file in + -> String -- ^ Template for the file name -> (FilePath -> IO a) -> IO a withTempFileName tmpDir template action = Exception.bracket diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 5612816e4f8..1d03ae9b57c 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -174,6 +174,7 @@ executable cabal Distribution.Client.CmdListBin Distribution.Client.CmdRepl Distribution.Client.CmdRun + Distribution.Client.CmdShowBuildInfo Distribution.Client.CmdSdist Distribution.Client.CmdTest Distribution.Client.CmdUpdate diff --git a/cabal-install/cabal-install.cabal.dev b/cabal-install/cabal-install.cabal.dev index 8bdfc353862..a0b858f5182 100644 --- a/cabal-install/cabal-install.cabal.dev +++ b/cabal-install/cabal-install.cabal.dev @@ -166,6 +166,7 @@ library cabal-lib-client Distribution.Client.CmdListBin Distribution.Client.CmdRepl Distribution.Client.CmdRun + Distribution.Client.CmdShowBuildInfo Distribution.Client.CmdSdist Distribution.Client.CmdTest Distribution.Client.CmdUpdate diff --git a/cabal-install/cabal-install.cabal.prod b/cabal-install/cabal-install.cabal.prod index 5612816e4f8..1d03ae9b57c 100644 --- a/cabal-install/cabal-install.cabal.prod +++ b/cabal-install/cabal-install.cabal.prod @@ -174,6 +174,7 @@ executable cabal Distribution.Client.CmdListBin Distribution.Client.CmdRepl Distribution.Client.CmdRun + Distribution.Client.CmdShowBuildInfo Distribution.Client.CmdSdist Distribution.Client.CmdTest Distribution.Client.CmdUpdate diff --git a/cabal-install/cabal-install.cabal.zinza b/cabal-install/cabal-install.cabal.zinza index a436fe6f6cd..2de02969552 100644 --- a/cabal-install/cabal-install.cabal.zinza +++ b/cabal-install/cabal-install.cabal.zinza @@ -110,6 +110,7 @@ Version: 3.3.0.0 Distribution.Client.CmdListBin Distribution.Client.CmdRepl Distribution.Client.CmdRun + Distribution.Client.CmdShowBuildInfo Distribution.Client.CmdSdist Distribution.Client.CmdTest Distribution.Client.CmdUpdate diff --git a/cabal-install/main/Main.hs b/cabal-install/main/Main.hs index 04e1658ce70..a6e0d845848 100644 --- a/cabal-install/main/Main.hs +++ b/cabal-install/main/Main.hs @@ -80,6 +80,7 @@ import qualified Distribution.Client.List as List import qualified Distribution.Client.CmdConfigure as CmdConfigure import qualified Distribution.Client.CmdUpdate as CmdUpdate import qualified Distribution.Client.CmdBuild as CmdBuild +import qualified Distribution.Client.CmdShowBuildInfo as CmdShowBuildInfo import qualified Distribution.Client.CmdRepl as CmdRepl import qualified Distribution.Client.CmdFreeze as CmdFreeze import qualified Distribution.Client.CmdHaddock as CmdHaddock @@ -253,7 +254,9 @@ mainWorker args = do , hiddenCmd actAsSetupCommand actAsSetupAction , hiddenCmd manpageCommand (manpageAction commandSpecs) , regularCmd CmdListBin.listbinCommand CmdListBin.listbinAction - + -- ghc-mod supporting commands + , hiddenCmd CmdShowBuildInfo.showBuildInfoCommand + CmdShowBuildInfo.showBuildInfoAction ] ++ concat [ newCmd CmdConfigure.configureCommand CmdConfigure.configureAction , newCmd CmdUpdate.updateCommand CmdUpdate.updateAction @@ -711,7 +714,7 @@ listAction listFlags extraArgs globalFlags = do , configHcPath = listHcPath listFlags } globalFlags' = savedGlobalFlags config `mappend` globalFlags - compProgdb <- if listNeedsCompiler listFlags + compProgdb <- if listNeedsCompiler listFlags then do (comp, _, progdb) <- configCompilerAux' configFlags return (Just (comp, progdb)) diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index 6a6d8706c35..6ec4d7712fb 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -157,21 +157,22 @@ testExceptionFindProjectRoot = do testTargetSelectors :: (String -> IO ()) -> Assertion testTargetSelectors reportSubCase = do (_, _, _, localPackages, _) <- configureProject testdir config - let readTargetSelectors' = readTargetSelectorsWith (dirActions testdir) + let readTargetSelectors'' = readTargetSelectorsWith (dirActions testdir) localPackages Nothing + False reportSubCase "cwd" - do Right ts <- readTargetSelectors' [] + do Right ts <- readTargetSelectors'' [] ts @?= [TargetPackage TargetImplicitCwd ["p-0.1"] Nothing] reportSubCase "all" - do Right ts <- readTargetSelectors' + do Right ts <- readTargetSelectors'' ["all", ":all"] ts @?= replicate 2 (TargetAllPackages Nothing) reportSubCase "filter" - do Right ts <- readTargetSelectors' + do Right ts <- readTargetSelectors'' [ "libs", ":cwd:libs" , "flibs", ":cwd:flibs" , "exes", ":cwd:exes" @@ -183,7 +184,7 @@ testTargetSelectors reportSubCase = do ] reportSubCase "all:filter" - do Right ts <- readTargetSelectors' + do Right ts <- readTargetSelectors'' [ "all:libs", ":all:libs" , "all:flibs", ":all:flibs" , "all:exes", ":all:exes" @@ -195,14 +196,14 @@ testTargetSelectors reportSubCase = do ] reportSubCase "pkg" - do Right ts <- readTargetSelectors' + do Right ts <- readTargetSelectors'' [ ":pkg:p", ".", "./", "p.cabal" , "q", ":pkg:q", "q/", "./q/", "q/q.cabal"] ts @?= replicate 4 (mkTargetPackage "p-0.1") ++ replicate 5 (mkTargetPackage "q-0.1") reportSubCase "pkg:filter" - do Right ts <- readTargetSelectors' + do Right ts <- readTargetSelectors'' [ "p:libs", ".:libs", ":pkg:p:libs" , "p:flibs", ".:flibs", ":pkg:p:flibs" , "p:exes", ".:exes", ":pkg:p:exes" @@ -222,14 +223,14 @@ testTargetSelectors reportSubCase = do ] reportSubCase "component" - do Right ts <- readTargetSelectors' + do Right ts <- readTargetSelectors'' [ "p", "lib:p", "p:lib:p", ":pkg:p:lib:p" , "lib:q", "q:lib:q", ":pkg:q:lib:q" ] ts @?= replicate 4 (TargetComponent "p-0.1" (CLibName LMainLibName) WholeComponent) ++ replicate 3 (TargetComponent "q-0.1" (CLibName LMainLibName) WholeComponent) reportSubCase "module" - do Right ts <- readTargetSelectors' + do Right ts <- readTargetSelectors'' [ "P", "lib:p:P", "p:p:P", ":pkg:p:lib:p:module:P" , "QQ", "lib:q:QQ", "q:q:QQ", ":pkg:q:lib:q:module:QQ" , "pexe:PMain" -- p:P or q:QQ would be ambiguous here @@ -242,7 +243,7 @@ testTargetSelectors reportSubCase = do ] reportSubCase "file" - do Right ts <- readTargetSelectors' + do Right ts <- readTargetSelectors'' [ "./P.hs", "p:P.lhs", "lib:p:P.hsc", "p:p:P.hsc", ":pkg:p:lib:p:file:P.y" , "q/QQ.hs", "q:QQ.lhs", "lib:q:QQ.hsc", "q:q:QQ.hsc", @@ -273,7 +274,7 @@ testTargetSelectorBadSyntax = do , "foo:", "foo::bar" , "foo: ", "foo: :bar" , "a:b:c:d:e:f", "a:b:c:d:e:f:g:h" ] - Left errs <- readTargetSelectors localPackages Nothing targets + Left errs <- readTargetSelectors' localPackages Nothing targets zipWithM_ (@?=) errs (map TargetSelectorUnrecognised targets) cleanProject testdir where @@ -378,6 +379,14 @@ testTargetSelectorAmbiguous reportSubCase = do [ mkpkg "foo" [ mkexe "bar" `withModules` ["Bar"] `withHsSrcDirs` ["src"] , mkexe "bar2" `withModules` ["Bar"] `withHsSrcDirs` ["src"] ] ] + reportSubCase "ambiguous: --pick-first-target resolves" + assertUnambiguousPickFirst "Bar.hs" + [ mkTargetFile "foo" (CExeName "bar") "Bar" + , mkTargetFile "foo" (CExeName "bar2") "Bar" + ] + [ mkpkg "foo" [ mkexe "bar" `withModules` ["Bar"] + , mkexe "bar2" `withModules` ["Bar"] ] + ] -- non-exact case packages and components are ambiguous reportSubCase "ambiguous: non-exact-case pkg names" @@ -413,6 +422,7 @@ testTargetSelectorAmbiguous reportSubCase = do fakeDirActions (map SpecificSourcePackage pkgs) Nothing + False [str] case res of Left [TargetSelectorAmbiguous _ tss'] -> @@ -429,12 +439,29 @@ testTargetSelectorAmbiguous reportSubCase = do fakeDirActions (map SpecificSourcePackage pkgs) Nothing + False [str] case res of Right [ts'] -> ts' @?= ts _ -> assertFailure $ "expected Right [Target...], " ++ "got " ++ show res + assertUnambiguousPickFirst :: String + -> [TargetSelector] + -> [SourcePackage (PackageLocation a)] + -> Assertion + assertUnambiguousPickFirst str ts pkgs = do + res <- readTargetSelectorsWith + fakeDirActions + (map SpecificSourcePackage pkgs) + Nothing + True + [str] + case res of + Right [ts'] -> (ts' `elem` ts) @? "unexpected target selector" + _ -> assertFailure $ "expected Right [Target...], " + ++ "got " ++ show res + fakeDirActions = TS.DirActions { TS.doesFileExist = \_p -> return True, TS.doesDirectoryExist = \_p -> return True, @@ -511,15 +538,16 @@ instance IsString PackageIdentifier where testTargetSelectorNoCurrentPackage :: Assertion testTargetSelectorNoCurrentPackage = do (_, _, _, localPackages, _) <- configureProject testdir config - let readTargetSelectors' = readTargetSelectorsWith (dirActions testdir) + let readTargetSelectors'' = readTargetSelectorsWith (dirActions testdir) localPackages Nothing + False targets = [ "libs", ":cwd:libs" , "flibs", ":cwd:flibs" , "exes", ":cwd:exes" , "tests", ":cwd:tests" , "benchmarks", ":cwd:benchmarks"] - Left errs <- readTargetSelectors' targets + Left errs <- readTargetSelectors'' targets zipWithM_ (@?=) errs [ TargetSelectorNoCurrentPackage ts | target <- targets @@ -534,7 +562,7 @@ testTargetSelectorNoCurrentPackage = do testTargetSelectorNoTargets :: Assertion testTargetSelectorNoTargets = do (_, _, _, localPackages, _) <- configureProject testdir config - Left errs <- readTargetSelectors localPackages Nothing [] + Left errs <- readTargetSelectors' localPackages Nothing [] errs @?= [TargetSelectorNoTargetsInCwd] cleanProject testdir where @@ -545,7 +573,7 @@ testTargetSelectorNoTargets = do testTargetSelectorProjectEmpty :: Assertion testTargetSelectorProjectEmpty = do (_, _, _, localPackages, _) <- configureProject testdir config - Left errs <- readTargetSelectors localPackages Nothing [] + Left errs <- readTargetSelectors' localPackages Nothing [] errs @?= [TargetSelectorNoTargetsInProject] cleanProject testdir where diff --git a/cabal-testsuite/PackageTests/NewHaddock/Fails/cabal.out b/cabal-testsuite/PackageTests/NewHaddock/Fails/cabal.out index cbfc470cbba..860963efde9 100644 --- a/cabal-testsuite/PackageTests/NewHaddock/Fails/cabal.out +++ b/cabal-testsuite/PackageTests/NewHaddock/Fails/cabal.out @@ -12,4 +12,5 @@ In order, the following will be built: - example-1.0 (lib) (first run) Preprocessing library for example-1.0.. Running Haddock on library for example-1.0.. +cabal: '' exited with an error: cabal: Failed to build documentation for example-1.0-inplace. diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/A/A.cabal b/cabal-testsuite/PackageTests/ShowBuildInfo/A/A.cabal new file mode 100644 index 00000000000..5a1e2977b66 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/A/A.cabal @@ -0,0 +1,23 @@ +cabal-version: 2.4 +name: A +version: 0.1.0.0 +license: BSD-3-Clause + +library + exposed-modules: A + build-depends: base >=4 + hs-source-dirs: src + default-language: Haskell2010 + +executable A + main-is: Main.hs + build-depends: base >=4 + hs-source-dirs: src + default-language: Haskell2010 + +test-suite A-tests + type: exitcode-stdio-1.0 + main-is: Test.hs + build-depends: base >=4 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/A/Setup.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/A/Setup.hs new file mode 100644 index 00000000000..9a994af677b --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/A/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-all.out b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-all.out new file mode 100644 index 00000000000..6fbda9790b7 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-all.out @@ -0,0 +1 @@ +# cabal show-build-info diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-all.test.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-all.test.hs new file mode 100644 index 00000000000..aa2d0142358 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-all.test.hs @@ -0,0 +1,9 @@ +import Test.Cabal.Prelude +import Test.Cabal.DecodeShowBuildInfo + +main = cabalTest $ do + buildInfo <- runShowBuildInfo ["-v0"] -- hide verbose output so we can parse + let comps = components buildInfo + assertEqual "Components, exactly three" 3 (length comps) + assertEqual "Test components, exactly one" 1 $ + length $ filter (\c -> "test" == componentType c) comps diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-exe-exact.out b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-exe-exact.out new file mode 100644 index 00000000000..6fbda9790b7 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-exe-exact.out @@ -0,0 +1 @@ +# cabal show-build-info diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-exe-exact.test.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-exe-exact.test.hs new file mode 100644 index 00000000000..66c0d3bfd32 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-exe-exact.test.hs @@ -0,0 +1,18 @@ +import Test.Cabal.Prelude +import Test.Cabal.DecodeShowBuildInfo + +main = cabalTest $ do + buildInfo <- runShowBuildInfo ["exe:A", "-v0"] + assertEqual "Cabal Version" cabalVersionLibrary (cabalVersion buildInfo) + assertEqual "Compiler flavour" "ghc" (flavour $ compiler buildInfo) + assertBool "Compiler id" (and $ zipWith (==) "ghc" (compilerId $ compiler buildInfo)) + assertBool "Compiler path non-empty" (not . null . path $ compiler buildInfo) + assertEqual "Components, exactly one" 1 (length $ components buildInfo) + let [component] = components buildInfo + assertEqual "Component type" "exe" (componentType component) + assertEqual "Component name" "exe:A" (componentName component) + assertEqual "Component unit-id" "A-0.1.0.0-inplace-A" (componentUnitId component) + assertBool "Component compiler args are non-empty" (not . null $ componentCompilerArgs component) + assertEqual "Component modules" [] (componentModules component) + assertEqual "Component source files" ["Main.hs"] (componentSrcFiles component) + assertEqual "Component source directories" ["src"] (componentHsSrcDirs component) diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-multiple-exact-unit-id-file.out b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-multiple-exact-unit-id-file.out new file mode 100644 index 00000000000..6fbda9790b7 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-multiple-exact-unit-id-file.out @@ -0,0 +1 @@ +# cabal show-build-info diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-multiple-exact-unit-id-file.test.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-multiple-exact-unit-id-file.test.hs new file mode 100644 index 00000000000..1c710f65022 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-multiple-exact-unit-id-file.test.hs @@ -0,0 +1,36 @@ +import Test.Cabal.Prelude +import Test.Cabal.DecodeShowBuildInfo + +main = cabalTest $ withSourceCopy $ do + cwd <- fmap testCurrentDir getTestEnv + let fp = cwd "unit.json" + _ <- cabal' "show-build-info" ["--buildinfo-json-output=" ++ fp, "--unit-ids-json=A-0.1.0.0-inplace A-0.1.0.0-inplace-A", "-v0"] + buildInfo <- decodeBuildInfoFile fp + assertEqual "Cabal Version" cabalVersionLibrary (cabalVersion buildInfo) + assertEqual "Compiler flavour" "ghc" (flavour $ compiler buildInfo) + assertBool "Compiler id" (and $ zipWith (==) "ghc" (compilerId $ compiler buildInfo)) + assertBool "Compiler path non-empty" (not . null . path $ compiler buildInfo) + assertEqual "Components, exactly two" 2 (length $ components buildInfo) + let [libBuildInfo, exeBuildInfo] = components buildInfo + assertExe exeBuildInfo + assertLib libBuildInfo + where + assertExe :: ComponentInfo -> TestM () + assertExe component = do + assertEqual "Component type" "exe" (componentType component) + assertEqual "Component name" "exe:A" (componentName component) + assertEqual "Component unit-id" "A-0.1.0.0-inplace-A" (componentUnitId component) + assertBool "Component compiler args are non-empty" (not . null $ componentCompilerArgs component) + assertEqual "Component modules" [] (componentModules component) + assertEqual "Component source files" ["Main.hs"] (componentSrcFiles component) + assertEqual "Component source directories" ["src"] (componentHsSrcDirs component) + + assertLib :: ComponentInfo -> TestM () + assertLib component = do + assertEqual "Component type" "lib" (componentType component) + assertEqual "Component name" "lib" (componentName component) + assertEqual "Component unit-id" "A-0.1.0.0-inplace" (componentUnitId component) + assertBool "Component compiler args are non-empty" (not . null $ componentCompilerArgs component) + assertEqual "Component modules" ["A"] (componentModules component) + assertEqual "Component source files" [] (componentSrcFiles component) + assertEqual "Component source directories" ["src"] (componentHsSrcDirs component) diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-multiple-exact-unit-id.out b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-multiple-exact-unit-id.out new file mode 100644 index 00000000000..6fbda9790b7 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-multiple-exact-unit-id.out @@ -0,0 +1 @@ +# cabal show-build-info diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-multiple-exact-unit-id.test.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-multiple-exact-unit-id.test.hs new file mode 100644 index 00000000000..0816c11abd3 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-multiple-exact-unit-id.test.hs @@ -0,0 +1,32 @@ +import Test.Cabal.Prelude +import Test.Cabal.DecodeShowBuildInfo + +main = cabalTest $ do + buildInfo <- runShowBuildInfo ["--unit-ids-json=A-0.1.0.0-inplace A-0.1.0.0-inplace-A", "-v0"] + assertEqual "Cabal Version" cabalVersionLibrary (cabalVersion buildInfo) + assertEqual "Compiler flavour" "ghc" (flavour $ compiler buildInfo) + assertBool "Compiler id" (and $ zipWith (==) "ghc" (compilerId $ compiler buildInfo)) + assertBool "Compiler path non-empty" (not . null . path $ compiler buildInfo) + let [libBuildInfo, exeBuildInfo] = components buildInfo + assertExe exeBuildInfo + assertLib libBuildInfo + where + assertExe :: ComponentInfo -> TestM () + assertExe component = do + assertEqual "Component type" "exe" (componentType component) + assertEqual "Component name" "exe:A" (componentName component) + assertEqual "Component unit-id" "A-0.1.0.0-inplace-A" (componentUnitId component) + assertBool "Component compiler args are non-empty" (not . null $ componentCompilerArgs component) + assertEqual "Component modules" [] (componentModules component) + assertEqual "Component source files" ["Main.hs"] (componentSrcFiles component) + assertEqual "Component source directories" ["src"] (componentHsSrcDirs component) + + assertLib :: ComponentInfo -> TestM () + assertLib component = do + assertEqual "Component type" "lib" (componentType component) + assertEqual "Component name" "lib" (componentName component) + assertEqual "Component unit-id" "A-0.1.0.0-inplace" (componentUnitId component) + assertBool "Component compiler args are non-empty" (not . null $ componentCompilerArgs component) + assertEqual "Component modules" ["A"] (componentModules component) + assertEqual "Component source files" [] (componentSrcFiles component) + assertEqual "Component source directories" ["src"] (componentHsSrcDirs component) diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-multiple-exact.out b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-multiple-exact.out new file mode 100644 index 00000000000..6fbda9790b7 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-multiple-exact.out @@ -0,0 +1 @@ +# cabal show-build-info diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-multiple-exact.test.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-multiple-exact.test.hs new file mode 100644 index 00000000000..880fe8ac71b --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-multiple-exact.test.hs @@ -0,0 +1,32 @@ +import Test.Cabal.Prelude +import Test.Cabal.DecodeShowBuildInfo + +main = cabalTest $ do + buildInfo <- runShowBuildInfo ["exe:A", "lib:A", "-v0"] + assertEqual "Cabal Version" cabalVersionLibrary (cabalVersion buildInfo) + assertEqual "Compiler flavour" "ghc" (flavour $ compiler buildInfo) + assertBool "Compiler id" (and $ zipWith (==) "ghc" (compilerId $ compiler buildInfo)) + assertBool "Compiler path non-empty" (not . null . path $ compiler buildInfo) + let [libBuildInfo, exeBuildInfo] = components buildInfo + assertExe exeBuildInfo + assertLib libBuildInfo + where + assertExe :: ComponentInfo -> TestM () + assertExe component = do + assertEqual "Component type" "exe" (componentType component) + assertEqual "Component name" "exe:A" (componentName component) + assertEqual "Component unit-id" "A-0.1.0.0-inplace-A" (componentUnitId component) + assertBool "Component compiler args are non-empty" (not . null $ componentCompilerArgs component) + assertEqual "Component modules" [] (componentModules component) + assertEqual "Component source files" ["Main.hs"] (componentSrcFiles component) + assertEqual "Component source directories" ["src"] (componentHsSrcDirs component) + + assertLib :: ComponentInfo -> TestM () + assertLib component = do + assertEqual "Component type" "lib" (componentType component) + assertEqual "Component name" "lib" (componentName component) + assertEqual "Component unit-id" "A-0.1.0.0-inplace" (componentUnitId component) + assertBool "Component compiler args are non-empty" (not . null $ componentCompilerArgs component) + assertEqual "Component modules" ["A"] (componentModules component) + assertEqual "Component source files" [] (componentSrcFiles component) + assertEqual "Component source directories" ["src"] (componentHsSrcDirs component) diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-unknown.out b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-unknown.out new file mode 100644 index 00000000000..72752bfec16 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-unknown.out @@ -0,0 +1,11 @@ +# cabal show-build-info +cabal: Internal error in target matching. It should always be possible to find a syntax that's sufficiently qualified to give an unambiguous match. However when matching 'exe:B' we found exe:B (unknown-component) which does not have an unambiguous syntax. The possible syntax and the targets they match are as follows: +'exe:B' which matches exe:B (unknown-component), :pkg:exe:lib:exe:module:B (unknown-module), :pkg:exe:lib:exe:file:B (unknown-file) +# cabal show-build-info +Resolving dependencies... +cabal: No unit B-inplace-0.1.0.0 +# cabal show-build-info +cabal: No unit B-inplace-0.1.0.0 +# cabal show-build-info +cabal: Internal error in target matching. It should always be possible to find a syntax that's sufficiently qualified to give an unambiguous match. However when matching 'exe:B' we found exe:B (unknown-component) which does not have an unambiguous syntax. The possible syntax and the targets they match are as follows: +'exe:B' which matches exe:B (unknown-component), :pkg:exe:lib:exe:module:B (unknown-module), :pkg:exe:lib:exe:file:B (unknown-file) diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-unknown.test.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-unknown.test.hs new file mode 100644 index 00000000000..b07607b3779 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/A/build-info-unknown.test.hs @@ -0,0 +1,14 @@ +import Test.Cabal.Prelude + +main = cabalTest $ do + r <- fails $ cabal' "show-build-info" ["exe:B"] + assertOutputContains "Internal error in target matching." r + + r <- fails $ cabal' "show-build-info" ["--unit-ids-json=B-inplace-0.1.0.0"] + assertOutputContains "No unit B-inplace-0.1.0.0" r + + r <- fails $ cabal' "show-build-info" ["--unit-ids-json=A-0.1.0.0-inplace B-inplace-0.1.0.0"] + assertOutputContains "No unit B-inplace-0.1.0.0" r + + r <- fails $ cabal' "show-build-info" ["--unit-ids-json=A-0.1.0.0-inplace", "exe:B"] + assertOutputContains "Internal error in target matching." r diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/A/cabal.project b/cabal-testsuite/PackageTests/ShowBuildInfo/A/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/A/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/A/src/A.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/A/src/A.hs new file mode 100644 index 00000000000..6b02eec8ec0 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/A/src/A.hs @@ -0,0 +1,4 @@ +module A where + +foo :: Int -> Int +foo = id diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/A/src/Main.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/A/src/Main.hs new file mode 100644 index 00000000000..65ae4a05d5d --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/A/src/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "Hello, Haskell!" diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/A/src/Test.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/A/src/Test.hs new file mode 100644 index 00000000000..b918ddac664 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/A/src/Test.hs @@ -0,0 +1 @@ +main = putStrLn "testing" diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/B/B.cabal b/cabal-testsuite/PackageTests/ShowBuildInfo/B/B.cabal new file mode 100644 index 00000000000..1400971ae35 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/B/B.cabal @@ -0,0 +1,10 @@ +cabal-version: 2.4 +name: B +version: 0.1.0.0 +license: BSD-3-Clause + +library + exposed-modules: A + build-depends: base >=4.0.0.0, A + hs-source-dirs: src + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/B/Setup.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/B/Setup.hs new file mode 100644 index 00000000000..9a994af677b --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/B/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/B/build-info-lib-exact.out b/cabal-testsuite/PackageTests/ShowBuildInfo/B/build-info-lib-exact.out new file mode 100644 index 00000000000..6fbda9790b7 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/B/build-info-lib-exact.out @@ -0,0 +1 @@ +# cabal show-build-info diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/B/build-info-lib-exact.test.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/B/build-info-lib-exact.test.hs new file mode 100644 index 00000000000..c836df828ca --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/B/build-info-lib-exact.test.hs @@ -0,0 +1,18 @@ +import Test.Cabal.Prelude +import Test.Cabal.DecodeShowBuildInfo + +main = cabalTest $ do + buildInfo <- runShowBuildInfo ["lib:B", "-v0"] + assertEqual "Cabal Version" cabalVersionLibrary (cabalVersion buildInfo) + assertEqual "Compiler flavour" "ghc" (flavour $ compiler buildInfo) + assertBool "Compiler id" (and $ zipWith (==) "ghc" (compilerId $ compiler buildInfo)) + assertBool "Compiler path non-empty" (not . null . path $ compiler buildInfo) + assertEqual "Components, exactly one" 1 (length $ components buildInfo) + let [component] = components buildInfo + assertEqual "Component type" "lib" (componentType component) + assertEqual "Component name" "lib" (componentName component) + assertEqual "Component unit-id" "B-0.1.0.0-inplace" (componentUnitId component) + assertBool "Component compiler args are non-empty" (not . null $ componentCompilerArgs component) + assertEqual "Component modules" ["A"] (componentModules component) + assertEqual "Component source files" [] (componentSrcFiles component) + assertEqual "Component source directories" ["src"] (componentHsSrcDirs component) diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/B/cabal.project b/cabal-testsuite/PackageTests/ShowBuildInfo/B/cabal.project new file mode 100644 index 00000000000..b957b20d5c5 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/B/cabal.project @@ -0,0 +1,2 @@ +packages: . + ../A diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/B/src/A.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/B/src/A.hs new file mode 100644 index 00000000000..6b02eec8ec0 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/B/src/A.hs @@ -0,0 +1,4 @@ +module A where + +foo :: Int -> Int +foo = id diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/C/C.cabal b/cabal-testsuite/PackageTests/ShowBuildInfo/C/C.cabal new file mode 100644 index 00000000000..6fe31714e7a --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/C/C.cabal @@ -0,0 +1,15 @@ +cabal-version: 2.4 +name: C +version: 0.1.0.0 +license: BSD-3-Clause + +library + exposed-modules: Lib + build-depends: base + default-language: Haskell2010 + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Test.hs + build-depends: base, C + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/C/Lib.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/C/Lib.hs new file mode 100644 index 00000000000..12f5889322c --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/C/Lib.hs @@ -0,0 +1,3 @@ +module Lib where + +f = 42 diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/C/Test.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/C/Test.hs new file mode 100644 index 00000000000..76a9bdb5d48 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/C/Test.hs @@ -0,0 +1 @@ +main = pure () diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/C/build-info-all-internal-deps.out b/cabal-testsuite/PackageTests/ShowBuildInfo/C/build-info-all-internal-deps.out new file mode 100644 index 00000000000..6fbda9790b7 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/C/build-info-all-internal-deps.out @@ -0,0 +1 @@ +# cabal show-build-info diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/C/build-info-all-internal-deps.test.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/C/build-info-all-internal-deps.test.hs new file mode 100644 index 00000000000..db3e0adfd2b --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/C/build-info-all-internal-deps.test.hs @@ -0,0 +1,9 @@ +import Test.Cabal.Prelude +import Test.Cabal.DecodeShowBuildInfo + +main = cabalTest $ do + buildInfo <- runShowBuildInfo ["-v0"] + let comps = components buildInfo + assertEqual "Components, exactly three" 2 (length comps) + assertEqual "Test components, exactly one" 1 $ + length $ filter (\c -> "test" == componentType c) comps diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/C/cabal.project b/cabal-testsuite/PackageTests/ShowBuildInfo/C/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/C/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/Complex.cabal b/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/Complex.cabal new file mode 100644 index 00000000000..b104678143d --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/Complex.cabal @@ -0,0 +1,47 @@ +cabal-version: 2.4 +name: Complex +version: 0.1.0.0 +license: MIT + +library + build-depends: base + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: Lib + other-modules: Paths_Complex + + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + +executable Complex + main-is: Main.lhs + build-depends: base + hs-source-dirs: src + default-language: Haskell2010 + other-modules: Paths_Complex + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wredundant-constraints + -with-rtsopts=-T + +test-suite unit-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + build-depends: base + main-is: Main.hs + +test-suite func-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + build-depends: base + main-is: Main.hs + +benchmark complex-benchmarks + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_Complex + hs-source-dirs: + benchmark + ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N + build-depends: + base + , Complex + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/Setup.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/Setup.hs new file mode 100644 index 00000000000..9a994af677b --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/cabal.project b/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/exe.out b/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/exe.out new file mode 100644 index 00000000000..6fbda9790b7 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/exe.out @@ -0,0 +1 @@ +# cabal show-build-info diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/exe.test.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/exe.test.hs new file mode 100644 index 00000000000..990bd65bcb2 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/exe.test.hs @@ -0,0 +1,34 @@ +import Test.Cabal.Prelude +import Test.Cabal.DecodeShowBuildInfo + +main = cabalTest $ do + buildInfo <- runShowBuildInfo ["exe:Complex", "-v0"] + assertEqual "Cabal Version" cabalVersionLibrary (cabalVersion buildInfo) + assertEqual "Compiler flavour" "ghc" (flavour $ compiler buildInfo) + assertBool "Compiler id" (and $ zipWith (==) "ghc" (compilerId $ compiler buildInfo)) + assertBool "Compiler path non-empty" (not . null . path $ compiler buildInfo) + assertEqual "Components, exactly one" 1 (length $ components buildInfo) + let [component] = components buildInfo + assertEqual "Component type" "exe" (componentType component) + assertEqual "Component name" "exe:Complex" (componentName component) + assertEqual "Component unit-id" "Complex-0.1.0.0-inplace-Complex" (componentUnitId component) + assertBool "Component compiler args are non-empty" (not . null $ componentCompilerArgs component) + assertBool "Component ghc-options contains all specified in .cabal" + (all + (`elem` componentCompilerArgs component) + [ "-threaded" + , "-rtsopts" + , "-with-rtsopts=-N" + , "-with-rtsopts=-T" + , "-Wredundant-constraints" + ] + ) + assertBool "Component ghc-options does not contain -Wall" + (all + (`notElem` componentCompilerArgs component) + [ "-Wall" + ] + ) + assertEqual "Component modules" ["Paths_Complex"] (componentModules component) + assertEqual "Component source files" ["Main.lhs"] (componentSrcFiles component) + assertEqual "Component source directories" ["src"] (componentHsSrcDirs component) diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/lib.out b/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/lib.out new file mode 100644 index 00000000000..6fbda9790b7 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/lib.out @@ -0,0 +1 @@ +# cabal show-build-info diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/lib.test.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/lib.test.hs new file mode 100644 index 00000000000..51eaf075e6e --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/lib.test.hs @@ -0,0 +1,33 @@ +import Test.Cabal.Prelude +import Test.Cabal.DecodeShowBuildInfo + +main = cabalTest $ do + buildInfo <- runShowBuildInfo ["lib:Complex", "-v0"] + assertEqual "Cabal Version" cabalVersionLibrary (cabalVersion buildInfo) + assertEqual "Compiler flavour" "ghc" (flavour $ compiler buildInfo) + assertBool "Compiler id" (and $ zipWith (==) "ghc" (compilerId $ compiler buildInfo)) + assertBool "Compiler path non-empty" (not . null . path $ compiler buildInfo) + assertEqual "Components, exactly one" 1 (length $ components buildInfo) + let [component] = components buildInfo + assertEqual "Component type" "lib" (componentType component) + assertEqual "Component name" "lib" (componentName component) + assertEqual "Component unit-id" "Complex-0.1.0.0-inplace" (componentUnitId component) + assertBool "Component compiler args are non-empty" (not . null $ componentCompilerArgs component) + assertBool "Component ghc-options contains all specified in .cabal" + (all + (`elem` componentCompilerArgs component) + [ "-threaded" + , "-rtsopts" + , "-with-rtsopts=-N" + , "-Wall" + ] + ) + assertBool "Component ghc-options does not contain -Wredundant-constraints" + (all + (`notElem` componentCompilerArgs component) + [ "-Wredundant-constraints" + ] + ) + assertEqual "Component modules" ["Lib", "Paths_Complex"] (componentModules component) + assertEqual "Component source files" [] (componentSrcFiles component) + assertEqual "Component source directories" ["src"] (componentHsSrcDirs component) diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/src/Lib.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/src/Lib.hs new file mode 100644 index 00000000000..5d35e3e9617 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/src/Lib.hs @@ -0,0 +1,4 @@ +module Lib where + +foo :: Int -> Int +foo = (+1) \ No newline at end of file diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/src/Main.lhs b/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/src/Main.lhs new file mode 100644 index 00000000000..a1b75006b8d --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/src/Main.lhs @@ -0,0 +1,9 @@ +module Main where + +import Lib + +main :: IO () +main = do + let i = foo 5 + putStrLn "Hello, Haskell!" + print i diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/test/Main.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/test/Main.hs new file mode 100644 index 00000000000..b3549c2fe3d --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/Complex/test/Main.hs @@ -0,0 +1 @@ +main = return () diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/D/D.cabal b/cabal-testsuite/PackageTests/ShowBuildInfo/D/D.cabal new file mode 100644 index 00000000000..0af36bee5bb --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/D/D.cabal @@ -0,0 +1,9 @@ +cabal-version: 2.4 +name: D +version: 0.1.0.0 +license: BSD-3-Clause + +library + exposed-modules: Lib + build-depends: base, D1 + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/D/D1/D1.cabal b/cabal-testsuite/PackageTests/ShowBuildInfo/D/D1/D1.cabal new file mode 100644 index 00000000000..09118f6e84e --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/D/D1/D1.cabal @@ -0,0 +1,9 @@ +cabal-version: 2.4 +name: D1 +version: 0.1.0.0 +license: BSD-3-Clause + +library + exposed-modules: Lib1 + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/D/D1/Lib1.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/D/D1/Lib1.hs new file mode 100644 index 00000000000..50919006b5f --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/D/D1/Lib1.hs @@ -0,0 +1,3 @@ +module Lib1 where + +bar = 42 diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/D/Lib.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/D/Lib.hs new file mode 100644 index 00000000000..638711c17e5 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/D/Lib.hs @@ -0,0 +1,6 @@ +module Lib where + +-- Point of this is to make sure we can still get the build info even if one of +-- the components doesn't compile +foo :: String +foo = 42 diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/D/build-info-prune-deps.out b/cabal-testsuite/PackageTests/ShowBuildInfo/D/build-info-prune-deps.out new file mode 100644 index 00000000000..8a876417a2c --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/D/build-info-prune-deps.out @@ -0,0 +1,2 @@ +# cabal clean +# cabal show-build-info diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/D/build-info-prune-deps.test.hs b/cabal-testsuite/PackageTests/ShowBuildInfo/D/build-info-prune-deps.test.hs new file mode 100644 index 00000000000..e3c0edb3651 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/D/build-info-prune-deps.test.hs @@ -0,0 +1,8 @@ +import Test.Cabal.Prelude + +main = cabalTest $ do + -- Make sure the vendored dependency D1 gets built + cabal' "clean" [] + r <- cabal' "show-build-info" ["-v1", "D", "D1"] + assertOutputContains "Building library for D1-0.1.0.0.." r + assertOutputDoesNotContain "Building library for D-0.1.0.0.." r diff --git a/cabal-testsuite/PackageTests/ShowBuildInfo/D/cabal.project b/cabal-testsuite/PackageTests/ShowBuildInfo/D/cabal.project new file mode 100644 index 00000000000..e7083db0d01 --- /dev/null +++ b/cabal-testsuite/PackageTests/ShowBuildInfo/D/cabal.project @@ -0,0 +1,2 @@ +packages: . + ./D1 diff --git a/cabal-testsuite/cabal-testsuite.cabal b/cabal-testsuite/cabal-testsuite.cabal index b9bf0fa9e24..f99d320c733 100644 --- a/cabal-testsuite/cabal-testsuite.cabal +++ b/cabal-testsuite/cabal-testsuite.cabal @@ -39,6 +39,7 @@ library hs-source-dirs: src exposed-modules: Test.Cabal.CheckArMetadata + Test.Cabal.DecodeShowBuildInfo Test.Cabal.Monad Test.Cabal.OutputNormalizer Test.Cabal.Plan diff --git a/cabal-testsuite/src/Test/Cabal/DecodeShowBuildInfo.hs b/cabal-testsuite/src/Test/Cabal/DecodeShowBuildInfo.hs new file mode 100644 index 00000000000..5b33be70a7d --- /dev/null +++ b/cabal-testsuite/src/Test/Cabal/DecodeShowBuildInfo.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE DeriveGeneric #-} +module Test.Cabal.DecodeShowBuildInfo where + +import Test.Cabal.Prelude +import qualified Distribution.Simple.Utils as U (cabalVersion) +import Distribution.Text (display) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Aeson +import GHC.Generics + +runShowBuildInfo :: [String] -> TestM BuildInfo +runShowBuildInfo args = do + r <- cabal' "show-build-info" args + case eitherDecodeStrict (T.encodeUtf8 . T.pack $ resultOutput r) of + Left err -> fail $ "Could not parse show-build-info command: " ++ err + Right buildInfos -> return buildInfos + +decodeBuildInfoFile :: FilePath -> TestM BuildInfo +decodeBuildInfoFile fp = do + shouldExist fp + res <- liftIO $ eitherDecodeFileStrict fp + case res of + Left err -> fail $ "Could not parse show-build-info file: " ++ err + Right buildInfos -> return buildInfos + +data BuildInfo = BuildInfo + { cabalVersion :: String + , compiler :: CompilerInfo + , components :: [ComponentInfo] + } deriving (Generic, Show) + +data CompilerInfo = CompilerInfo + { flavour :: String + , compilerId :: String + , path :: String + } deriving (Generic, Show) + +data ComponentInfo = ComponentInfo + { componentType :: String + , componentName :: String + , componentUnitId :: String + , componentCompilerArgs :: [String] + , componentModules :: [String] + , componentSrcFiles :: [FilePath] + , componentHsSrcDirs :: [FilePath] + , componentSrcDir :: FilePath + } deriving (Generic, Show) + +instance ToJSON BuildInfo where + toEncoding = genericToEncoding defaultOptions +instance FromJSON BuildInfo where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '-' } + +instance ToJSON CompilerInfo where + toEncoding = genericToEncoding defaultOptions +instance FromJSON CompilerInfo where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '-' } + +instance ToJSON ComponentInfo where + toEncoding = genericToEncoding defaultOptions +instance FromJSON ComponentInfo where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = drop 10 . camelTo2 '-' } + +cabalVersionLibrary :: String +cabalVersionLibrary = display U.cabalVersion diff --git a/cabal-testsuite/src/Test/Cabal/Monad.hs b/cabal-testsuite/src/Test/Cabal/Monad.hs index 19695aaa37b..77f4f6fa5dc 100644 --- a/cabal-testsuite/src/Test/Cabal/Monad.hs +++ b/cabal-testsuite/src/Test/Cabal/Monad.hs @@ -411,6 +411,10 @@ mkNormalizerEnv = do list_out <- liftIO $ readProcess (programPath ghc_pkg_program) ["list", "--global", "--simple-output"] "" tmpDir <- liftIO $ getTemporaryDirectory + haddock <- let prog = fromJust $ lookupKnownProgram "haddock" (testProgramDb env) + in fmap (fst . fromJust) $ liftIO $ + programFindLocation prog (testVerbosity env) + [ProgramSearchPathDefault] return NormalizerEnv { normalizerRoot = addTrailingPathSeparator (testSourceDir env), @@ -423,8 +427,12 @@ mkNormalizerEnv = do normalizerKnownPackages = mapMaybe simpleParse (words list_out), normalizerPlatform - = testPlatform env + = testPlatform env, + normalizerHaddock + = haddock } + where + requireProgramM :: Program -> TestM ConfiguredProgram requireProgramM program = do diff --git a/cabal-testsuite/src/Test/Cabal/OutputNormalizer.hs b/cabal-testsuite/src/Test/Cabal/OutputNormalizer.hs index fd7457b3324..0fd04817508 100644 --- a/cabal-testsuite/src/Test/Cabal/OutputNormalizer.hs +++ b/cabal-testsuite/src/Test/Cabal/OutputNormalizer.hs @@ -14,6 +14,7 @@ import Distribution.System import qualified Data.Foldable as F import Text.Regex +import Data.List normalizeOutput :: NormalizerEnv -> String -> String normalizeOutput nenv = @@ -54,11 +55,41 @@ normalizeOutput nenv = else id) -- hackage-security locks occur non-deterministically . resub "(Released|Acquired|Waiting) .*hackage-security-lock\n" "" + -- Substitute the haddock binary with + -- Do this before the substitution + . resub (posixRegexEscape (normalizerHaddock nenv)) "" + . removeErrors where packageIdRegex pid = resub (posixRegexEscape (display pid) ++ "(-[A-Za-z0-9.-]+)?") (prettyShow (packageName pid) ++ "-") +{- Given +cabal: blah exited with an error: +Example.hs:6:11: error: + * Couldn't match expected type `Int' with actual type `Bool' + * In the expression: False + In an equation for `example': example = False +| +6 | example = False +| ^^^^^ +cabal: Failed to build documentation for example-1.0-inplace. + +this will remove the error in between the first line with "exited with an error" +and the closing "cabal:". Pretty nasty, but its needed to ignore errors from +external programs whose output might change. +-} +removeErrors :: String -> String +removeErrors s = unlines (go (lines s) False) + where + go [] _ = [] + go (x:xs) True + | any (`isPrefixOf` x) ["cabal:", "cabal.exe:"] = x:(go xs False) + | otherwise = go xs True + go (x:xs) False + | "exited with an error" `isInfixOf` x = x:(go xs True) + | otherwise = x:(go xs False) + data NormalizerEnv = NormalizerEnv { normalizerRoot :: FilePath , normalizerTmpDir :: FilePath @@ -66,6 +97,7 @@ data NormalizerEnv = NormalizerEnv , normalizerGhcVersion :: Version , normalizerKnownPackages :: [PackageId] , normalizerPlatform :: Platform + , normalizerHaddock :: FilePath } posixSpecialChars :: [Char]