Resolve targets to unit-ids instead of build-info

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.

Author: fendor

cabal-install/src/Distribution/Client/CmdStatus.hs

@@ -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
@@ -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
@@ -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
@@ -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
   }
@@ -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
@@ -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
 -- ----------------------------------------------------------------------------
@@ -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
@@ -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"