Skip to content

Commit

Permalink
Resolve targets to unit-ids instead of build-info
Browse files Browse the repository at this point in the history 
This is more flexible than giving the user the build-info file directly,
since this information is redundant as it is located in plan.json.

There we can even express some more conditions. If the target is not a
local dependency, the user can check that. If the user needs the
build-info, then they can look it up in plan.json.
  • Loading branch information
@fendor
fendor committed Jul 15, 2022
1 parent 131b7d7 commit a1054af
Showing 1 changed file with 133 additions and 118 deletions.
251 changes: 133 additions & 118 deletions cabal-install/src/Distribution/Client/CmdStatus.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -17,33 +17,35 @@ module Distribution.Client.CmdStatus (
statusCommand, statusAction,
) where

import Control.Monad
( mapM )
import qualified Data.Map as Map

import Prelude ()
import Distribution.Client.Compat.Prelude

import Distribution.Client.DistDirLayout
import Distribution.Client.TargetProblem
import Distribution.Client.CmdErrorMessages
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.NixStyleOptions
( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
import Distribution.Client.ProjectOrchestration
import Distribution.Client.ProjectPlanning
import Distribution.Client.ProjectPlanning.Types
import Distribution.Client.Setup
( GlobalFlags, ConfigFlags(..), yesNoOpt )
import Distribution.Client.Types
( PackageSpecifier, PackageLocation )
import Distribution.Client.TargetSelector
( TargetSelectorProblem )
import Distribution.Client.Utils.Json
( (.=) )
import qualified Distribution.Client.Utils.Json as Json
import Distribution.Client.Version
( cabalInstallVersion )
import Distribution.InstalledPackageInfo
( InstalledPackageInfo )
import Distribution.Parsec (parsecCommaList, parsecToken)

import qualified Distribution.Compat.CharParsing as P
import Distribution.ReadE
( ReadE(ReadE), parsecToReadE )
import Distribution.Simple.BuildPaths (buildInfoPref)
import Distribution.Simple.Command
( CommandUI(..), option, reqArg, ShowOrParseArgs, OptionField )
import Distribution.Simple.Compiler
Expand All @@ -52,6 +54,8 @@ import Distribution.Simple.Flag
( Flag(..), fromFlagOrDefault )
import Distribution.Simple.Utils
( wrapText, die', withOutputMarker, ordNub )
import Distribution.Solver.Types.SourcePackage
import Distribution.Types.UnitId
import Distribution.Verbosity
( normal )
import Distribution.Version
Expand All @@ -68,14 +72,14 @@ statusCommand = CommandUI
"Query for available targets and project information such as project GHC."
, commandNotes = Just $ \pname ->
"Examples:\n"
++ " " ++ pname ++ " status --output-format=json --compiler-info\n"
++ " " ++ pname ++ " status --output-format=json --compiler\n"
++ " Print the compiler that is used for this project in the json format.\n"
++ " " ++ pname ++ " status --output-format=json --build-info=./src/Foo.hs\n"
++ " Print the location of the component \"src/Foo.hs\" belongs to.\n"
++ " " ++ pname ++ " status --output-format=json --build-info=./src/Foo.hs\n"
++ " Print both, compiler information and build-info location for the given target.\n"
++ " " ++ pname ++ " status --output-format=json --build-info=./src/Foo.hs --build-info=./test/Bar.hs\n"
++ " Print build-info location for multiple targets.\n"
++ " " ++ pname ++ " status --output-format=json --target=./src/Foo.hs\n"
++ " Print the unit-id of the component \"src/Foo.hs\" belongs to.\n"
++ " " ++ pname ++ " status --output-format=json --target=./src/Foo.hs\n"
++ " Print both, compiler information and unit-id for the given target.\n"
++ " " ++ pname ++ " status --output-format=json --target=./src/Foo.hs --target=./test/Bar.hs\n"
++ " Print unit-id location for multiple targets.\n"
, commandUsage = \pname ->
"Usage: " ++ pname ++ " status [FLAGS]\n"
, commandDefaultFlags = defaultNixStyleFlags defaultStatusFlags
Expand All @@ -92,14 +96,14 @@ data StatusOutputFormat
deriving (Eq, Ord, Show, Read)

data StatusFlags = StatusFlags
{ statusBuildInfo :: [String]
{ statusTargets :: [String]
, statusCompiler :: Flag Bool
, statusOutputFormat :: Flag StatusOutputFormat
} deriving (Eq, Show, Read)

defaultStatusFlags :: StatusFlags
defaultStatusFlags = StatusFlags
{ statusBuildInfo = mempty
{ statusTargets = mempty
, statusCompiler = mempty
, statusOutputFormat = mempty
}
Expand All @@ -125,23 +129,22 @@ statusOptions showOrParseArgs =
statusOutputFormatParser
statusOutputFormatPrinter
)
, option [] ["build-info"]
"List all available targets in the project"
statusBuildInfo (\v flags -> flags { statusBuildInfo = v ++ statusBuildInfo flags})
(reqArg "TARGET" buildInfoTargetReadE (fmap show))
, option [] ["compiler-info"]
, option [] ["target"]
"Given a target, obtain the unit-id in the build-plan"
statusTargets (\v flags -> flags { statusTargets = v ++ statusTargets flags})
(reqArg "TARGET" buildInfoTargetReadE id)
, option [] ["compiler"]
"Print information of the project compiler"
statusCompiler (\v flags -> flags { statusCompiler = v })
(yesNoOpt showOrParseArgs)
]
where
buildInfoTargetReadE :: ReadE [String]
buildInfoTargetReadE =
parsecToReadE
fmap pure $ parsecToReadE
-- This error should never be shown
("couldn't parse targets: " ++)
-- TODO: wrong parser, kills filepaths with spaces
(parsecCommaList parsecToken)
(P.munch1 (const True))

-------------------------------------------------------------------------------
-- Action
Expand All @@ -163,49 +166,112 @@ statusAction flags@NixStyleFlags { extraFlags = statusFlags, ..} cliTargetString
(projectConfig baseCtx)
(localPackages baseCtx)

let initialJson = Json.object
[ "cabal-version" .= jdisplay cabalInstallVersion
]

compilerJson <- if not $ fromFlagOrDefault False (statusCompiler statusFlags)
then pure $ Json.object [] -- Neutral element
compilerInformation <- if not $ fromFlagOrDefault False (statusCompiler statusFlags)
then pure Nothing
else do
let compiler = pkgConfigCompiler elabSharedConfig
compilerProg <- requireCompilerProg verbosity compiler
let progDb = pkgConfigCompilerProgs elabSharedConfig
(configuredCompilerProg, _) <- requireProgram verbosity compilerProg progDb
pure $ mkCompilerInfo configuredCompilerProg compiler
pure $ Just $ mkCompilerInfo configuredCompilerProg compiler

buildInfoJson <- if null (statusBuildInfo statusFlags)
then pure $ Json.object [] -- Neutral element
resolvedTargets <- if null (statusTargets statusFlags)
then pure Nothing
else do
let targetStrings = statusBuildInfo statusFlags
targetSelectors <- readTargetSelectors (localPackages baseCtx) Nothing targetStrings >>= \case
Left err -> reportTargetSelectorProblems verbosity err
Right sels -> pure sels

let targetStrings = statusTargets statusFlags
mtargetSelectors <- mapM (readTargetSelector (localPackages baseCtx) Nothing) targetStrings
let (unresolvable, targetSelectors) = partitionEithers
$ map (\(mts, str) -> case mts of
Left _ -> Left str
Right ts -> Right (ts, str)
)
$ zip mtargetSelectors targetStrings
-- Interpret the targets on the command line as build targets
-- (as opposed to say repl or haddock targets).
-- TODO: don't throw on targets that are invalid.
-- TODO: why might this still fail? should we try to avoid that?
targets <- either (reportBuildTargetProblems verbosity) return
$ resolveTargets
selectPackageTargets
selectComponentTarget
elaboratedPlan
Nothing
targetSelectors
(map fst targetSelectors)

pure $ mkBuildInfoJson (distDirLayout baseCtx) elabSharedConfig
elaboratedPlan targets targetSelectors targetStrings
pure $ Just $ mkBuildInfoJson elaboratedPlan targets (Map.fromList targetSelectors) unresolvable

let statusJson = mergeJsonObjects [initialJson, compilerJson, buildInfoJson]
let si = StatusInformation
{ siCabalVersion = cabalInstallVersion
, siCompiler = compilerInformation
, siTargetResolving = resolvedTargets
}

serialisedStatusInformation <- serialise verbosity (statusOutputFormat statusFlags) si

-- Final output
putStrLn $ withOutputMarker verbosity $ Json.encodeToString statusJson
putStrLn $ withOutputMarker verbosity serialisedStatusInformation
where
verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty

-- ----------------------------------------------------------------------------
-- Big Datatype that can be serialised to different formats
-- ----------------------------------------------------------------------------

data StatusInformation = StatusInformation
{ siCabalVersion :: Version
, siCompiler :: Maybe CompilerInformation
, siTargetResolving :: Maybe [ResolvedTarget]
}
deriving (Show, Read, Eq, Ord)

data CompilerInformation = CompilerInformation
{ ciFlavour :: CompilerFlavor
, ciCompilerId :: CompilerId
, ciPath :: FilePath
}
deriving (Show, Read, Eq, Ord)

data ResolvedTarget = ResolvedTarget
{ rtOriginalTarget :: String
-- | UnitId of the resolved target.
-- If 'Nothing', then the given target can not be resolved
-- to a target in this project.
, rtUnitId :: Maybe UnitId
}
deriving (Show, Read, Eq, Ord)

serialise :: Verbosity -> Flag StatusOutputFormat -> StatusInformation -> IO String
serialise verbosity NoFlag _ =
die' verbosity $ "Could not serialise Status information. "
++ "The flag '--output-format' is required."

serialise _ (Flag JSON) si = pure $ Json.encodeToString $ Json.object $
[ "cabal-version" .= jdisplay (siCabalVersion si)
]
++ prettyCompilerInfo (siCompiler si)
++ prettyTargetResolving (siTargetResolving si)
where
prettyCompilerInfo Nothing = []
prettyCompilerInfo (Just ci) =
[ "compiler" .= Json.object
[ "flavour" .= jdisplay (ciFlavour ci)
, "compiler-id" .= jdisplay (ciCompilerId ci)
, "path" .= Json.String (ciPath ci)
]
]

prettyTargetResolving Nothing = []
prettyTargetResolving (Just rts) =
[ "targets" .= Json.Array (fmap prettyResolvedTarget rts)
]
where
prettyResolvedTarget rt = Json.object
[ "target" .= Json.String (rtOriginalTarget rt)
, "unit-id" .= maybe Json.Null jdisplay (rtUnitId rt)
]


-- ----------------------------------------------------------------------------
-- Helpers for determining and serialising compiler information
-- ----------------------------------------------------------------------------
Expand All @@ -219,83 +285,29 @@ requireCompilerProg verbosity compiler =
"status: Unsupported compiler flavour: "
<> prettyShow flavour

mkCompilerInfo :: ConfiguredProgram -> Compiler -> Json.Value
mkCompilerInfo :: ConfiguredProgram -> Compiler -> CompilerInformation
mkCompilerInfo compilerProgram compiler =
Json.object
[ "compiler" .= Json.object
[ "flavour" .= Json.String (prettyShow $ compilerFlavor compiler)
, "compiler-id" .= Json.String (showCompilerId compiler)
, "path" .= Json.String (programPath compilerProgram)
]
]
CompilerInformation (compilerFlavor compiler) (compilerId compiler) (programPath compilerProgram)

-- ----------------------------------------------------------------------------
-- Helpers for determining and serialising build info
-- Helpers for determining and serialising the unit-id
-- ----------------------------------------------------------------------------

mkBuildInfoJson :: DistDirLayout -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> TargetsMap -> [TargetSelector] -> [String] -> Json.Value
mkBuildInfoJson distDirLayout elaboratedSharedConfig elaboratedPlan targetsMap targetSelectors targetStrings = Json.object
[ "build-info" .= Json.Array allTargetsJsons
mkBuildInfoJson :: ElaboratedInstallPlan -> TargetsMap -> Map TargetSelector String -> [String] -> [ResolvedTarget]
mkBuildInfoJson elaboratedPlan targetsMap tsMap unresolvableTargetStrings =
[ ResolvedTarget str (Just uid)
| uid <- Map.keys subsetInstallPlan
, (_, tss) <- targetsMap Map.! uid
, str <- ordNub $ map tsToOriginalTarget $ toList tss
]
++ map mkUnresolvedTarget unresolvableTargetStrings
where
allTargetsJsons =
[ planPackageToJ elab ts
| (uid, elab) <- Map.assocs subsetInstallPlan
, (_, tss) <- targetsMap Map.! uid
, ts <- ordNub $ toList tss
]

subsetInstallPlan = Map.restrictKeys (InstallPlan.toMap elaboratedPlan) (Map.keysSet targetsMap)

targetsTable = Map.fromList $ zip targetSelectors targetStrings

tsToOriginalTarget ts = targetsTable Map.! ts

planPackageToJ :: ElaboratedPlanPackage -> TargetSelector -> Json.Value
planPackageToJ pkg ts =
case pkg of
InstallPlan.PreExisting ipi -> installedPackageInfoToJ ipi
InstallPlan.Configured elab -> elaboratedPackageToJ elab ts
InstallPlan.Installed elab -> elaboratedPackageToJ elab ts
-- Note that the --build-info currently only uses the elaborated plan,
-- not the improved plan. So we will not get the Installed state for
-- that case, but the code supports it in case we want to use this
-- later in some use case where we want the status of the build.

-- TODO: what should we do if we run in this case?
-- Happens on `--build-info=containers` while we are not in the containers project.
installedPackageInfoToJ :: InstalledPackageInfo -> Json.Value
installedPackageInfoToJ _ipi =
-- Pre-existing packages lack configuration information such as their flag
-- settings or non-lib components. We only get pre-existing packages for
-- the global/core packages however, so this isn't generally a problem.
-- So these packages are never local to the project.
--
Json.object []

elaboratedPackageToJ :: ElaboratedConfiguredPackage -> TargetSelector -> Json.Value
elaboratedPackageToJ elab ts = Json.object
[ "target" .= Json.String (tsToOriginalTarget ts)
, "path" .= maybe Json.Null Json.String buildInfoFileLocation
]
where
dist_dir :: FilePath
dist_dir = distBuildDirectory distDirLayout
(elabDistDirParams elaboratedSharedConfig elab)

-- | Only add build-info file location if the Setup.hs CLI
-- is recent enough to be able to generate build info files.
-- Otherwise, write 'null'.
--
-- Consumers of `status` can use the nullability of this file location
-- to indicate that the given component uses `build-type: Custom`
-- with an old lib:Cabal version.
buildInfoFileLocation :: Maybe FilePath
buildInfoFileLocation
| elabSetupScriptCliVersion elab < mkVersion [3, 7, 0, 0]
= Nothing
| otherwise
= Just (buildInfoPref dist_dir)
tsToOriginalTarget ts = tsMap Map.! ts

mkUnresolvedTarget :: String -> ResolvedTarget
mkUnresolvedTarget s = ResolvedTarget s Nothing

-- ----------------------------------------------------------------------------
-- Target selectors and helpers
Expand Down Expand Up @@ -350,17 +362,20 @@ reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a
reportBuildTargetProblems verbosity problems =
reportTargetProblems verbosity "status" problems

readTargetSelector :: [PackageSpecifier (SourcePackage (PackageLocation a))]
-> Maybe ComponentKindFilter
-> String
-> IO (Either TargetSelectorProblem TargetSelector)
readTargetSelector pkgs mfilter targetStr =
readTargetSelectors pkgs mfilter [targetStr] >>= \case
Left [problem] -> pure $ Left problem
Right [ts] -> pure $ Right ts
_ -> error $ "CmdStatus.readTargetSelector: invariant broken, more than "
++ "one target passed *somehow*."

-- ----------------------------------------------------------------------------
-- JSON serialisation helpers
-- ----------------------------------------------------------------------------

jdisplay :: Pretty a => a -> Json.Value
jdisplay = Json.String . prettyShow

mergeJsonObjects :: [Json.Value] -> Json.Value
mergeJsonObjects = Json.object . foldl' go []
where
go acc (Json.Object objs) =
acc <> objs
go _ _ =
error "mergeJsonObjects: Only objects can be merged"

0 comments on commit a1054af

Please sign in to comment.