{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Distribution.Client.CmdTarget
  ( targetCommand
  , targetAction
  ) where

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

import qualified Data.Map as Map
import Distribution.Client.CmdBuild (selectComponentTarget, selectPackageTargets)
import Distribution.Client.CmdErrorMessages
import Distribution.Client.InstallPlan
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.NixStyleOptions
  ( NixStyleFlags (..)
  , defaultNixStyleFlags
  , nixStyleOptions
  )
import Distribution.Client.ProjectOrchestration
import Distribution.Client.ProjectPlanning
import Distribution.Client.Setup
  ( ConfigFlags (..)
  , GlobalFlags
  )
import Distribution.Client.TargetProblem
  ( TargetProblem'
  )
import Distribution.Package
import Distribution.Simple.Command
  ( CommandUI (..)
  , usageAlternatives
  )
import Distribution.Simple.Flag (fromFlagOrDefault)
import Distribution.Simple.Utils
  ( noticeDoc
  , safeHead
  , wrapText
  )
import Distribution.Verbosity
  ( defaultVerbosityHandles
  , mkVerbosity
  , normal
  )
import Text.PrettyPrint
import qualified Text.PrettyPrint as Pretty

-------------------------------------------------------------------------------
-- Command
-------------------------------------------------------------------------------

targetCommand :: CommandUI (NixStyleFlags ())
targetCommand :: CommandUI (NixStyleFlags ())
targetCommand =
  CommandUI
    { commandName :: [Char]
commandName = [Char]
"v2-target"
    , commandSynopsis :: [Char]
commandSynopsis = [Char]
"Target a subset of all targets."
    , commandUsage :: [Char] -> [Char]
commandUsage = [Char] -> [[Char]] -> [Char] -> [Char]
usageAlternatives [Char]
"v2-target" [[Char]
"[TARGETS]"]
    , commandDescription :: Maybe ([Char] -> [Char])
commandDescription =
        ([Char] -> [Char]) -> Maybe ([Char] -> [Char])
forall a. a -> Maybe a
Just (([Char] -> [Char]) -> Maybe ([Char] -> [Char]))
-> (Doc -> [Char] -> [Char]) -> Doc -> Maybe ([Char] -> [Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
forall a b. a -> b -> a
const ([Char] -> [Char] -> [Char])
-> (Doc -> [Char]) -> Doc -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Char]
render (Doc -> Maybe ([Char] -> [Char]))
-> Doc -> Maybe ([Char] -> [Char])
forall a b. (a -> b) -> a -> b
$
          [Doc] -> Doc
vcat
            [ Doc
intro
            , [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate ([Char] -> Doc
text [Char]
"\n") [Doc
targetForms, Doc
ctypes, Doc
Pretty.empty]
            , Doc
caution
            , Doc
unique
            ]
    , commandNotes :: Maybe ([Char] -> [Char])
commandNotes = ([Char] -> [Char]) -> Maybe ([Char] -> [Char])
forall a. a -> Maybe a
Just (([Char] -> [Char]) -> Maybe ([Char] -> [Char]))
-> ([Char] -> [Char]) -> Maybe ([Char] -> [Char])
forall a b. (a -> b) -> a -> b
$ \[Char]
pname -> Doc -> [Char]
render ([Char] -> Doc
examples [Char]
pname) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
    , commandDefaultFlags :: NixStyleFlags ()
commandDefaultFlags = () -> NixStyleFlags ()
forall a. a -> NixStyleFlags a
defaultNixStyleFlags ()
    , commandOptions :: ShowOrParseArgs -> [OptionField (NixStyleFlags ())]
commandOptions = (ShowOrParseArgs -> [OptionField ()])
-> ShowOrParseArgs -> [OptionField (NixStyleFlags ())]
forall a.
(ShowOrParseArgs -> [OptionField a])
-> ShowOrParseArgs -> [OptionField (NixStyleFlags a)]
nixStyleOptions ([OptionField ()] -> ShowOrParseArgs -> [OptionField ()]
forall a b. a -> b -> a
const [])
    }
  where
    intro :: Doc
intro =
      [Char] -> Doc
text ([Char] -> Doc) -> ([Char] -> [Char]) -> [Char] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
wrapText ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$
        [Char]
"Discover targets in a project for use with other commands taking [TARGETS].\n\n"
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"This command, like many others, takes [TARGETS]. Taken together, these will"
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" select for a set of targets in the project. When none are supplied, the"
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" command acts as if 'all' was supplied."
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" Targets in the returned subset are shown sorted and fully-qualified."

    targetForms :: Doc
targetForms =
      [Doc] -> Doc
vcat
        [ [Char] -> Doc
text [Char]
"A [TARGETS] item can be one of these target forms:"
        , Int -> Doc -> Doc
nest Int
1 (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
            (Char -> Doc
char Char
'-' Doc -> Doc -> Doc
<+>)
              (Doc -> Doc) -> [Doc] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ [Char] -> Doc
text [Char]
"a package target (e.g. [pkg:]package)"
                  , [Char] -> Doc
text [Char]
"a component target (e.g. [package:][ctype:]component)"
                  , [Char] -> Doc
text [Char]
"all packages (e.g. all)"
                  , [Char] -> Doc
text [Char]
"components of a particular type (e.g. package:ctypes or all:ctypes)"
                  , [Char] -> Doc
text [Char]
"a module target: (e.g. [package:][ctype:]module)"
                  , [Char] -> Doc
text [Char]
"a filepath target: (e.g. [package:][ctype:]filepath)"
                  ]
        ]

    ctypes :: Doc
ctypes =
      [Doc] -> Doc
vcat
        [ [Char] -> Doc
text [Char]
"The ctypes, in short form and (long form), can be one of:"
        , Int -> Doc -> Doc
nest Int
1 (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
            (Char -> Doc
char Char
'-' Doc -> Doc -> Doc
<+>)
              (Doc -> Doc) -> [Doc] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ Doc
"libs" Doc -> Doc -> Doc
<+> Doc -> Doc
parens Doc
"libraries"
                  , Doc
"exes" Doc -> Doc -> Doc
<+> Doc -> Doc
parens Doc
"executables"
                  , Doc
"tests"
                  , Doc
"benches" Doc -> Doc -> Doc
<+> Doc -> Doc
parens Doc
"benchmarks"
                  , Doc
"flibs" Doc -> Doc -> Doc
<+> Doc -> Doc
parens Doc
"foreign-libraries"
                  ]
        ]

    caution :: Doc
caution =
      [Char] -> Doc
text ([Char] -> Doc) -> ([Char] -> [Char]) -> [Char] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
wrapText ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$
        [Char]
"WARNING: For a package, all, module or filepath target, cabal target [TARGETS] \
        \ will only show 'libs' and 'exes' of the [TARGETS] by default. To also show \
        \ tests and benchmarks, enable them with '--enable-tests' and \
        \ '--enable-benchmarks'."

    unique :: Doc
unique =
      [Char] -> Doc
text ([Char] -> Doc) -> ([Char] -> [Char]) -> [Char] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
wrapText ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$
        [Char]
"NOTE: For commands expecting a unique TARGET, a fully-qualified target is the safe \
        \ way to go but it may be convenient to type out a shorter TARGET. For example, if the \
        \ set of 'cabal target all:exes' has one item then 'cabal list-bin all:exes' will \
        \ work too."

    examples :: [Char] -> Doc
examples [Char]
pname =
      [Doc] -> Doc
vcat
        [ [Char] -> Doc
text [Char]
"Examples" Doc -> Doc -> Doc
Pretty.<> Doc
colon
        , Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
            [Doc] -> Doc
vcat
              [ [Doc] -> Doc
vcat
                  [ [Char] -> Doc
text [Char]
pname Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"v2-target all"
                  , Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"Targets of the package in the current directory or all packages in the project"
                  ]
              , [Doc] -> Doc
vcat
                  [ [Char] -> Doc
text [Char]
pname Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"v2-target pkgname"
                  , Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"Targets of the package named pkgname in the project"
                  ]
              , [Doc] -> Doc
vcat
                  [ [Char] -> Doc
text [Char]
pname Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"v2-target ./pkgfoo"
                  , Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"Targets of the package in the ./pkgfoo directory"
                  ]
              , [Doc] -> Doc
vcat
                  [ [Char] -> Doc
text [Char]
pname Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"v2-target cname"
                  , Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"Targets of the component named cname in the project"
                  ]
              ]
        ]

-------------------------------------------------------------------------------
-- Action
-------------------------------------------------------------------------------

targetAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
targetAction :: NixStyleFlags () -> [[Char]] -> GlobalFlags -> IO ()
targetAction flags :: NixStyleFlags ()
flags@NixStyleFlags{()
TestFlags
HaddockFlags
ConfigFlags
BenchmarkFlags
ConfigExFlags
InstallFlags
ProjectFlags
configFlags :: ConfigFlags
configExFlags :: ConfigExFlags
installFlags :: InstallFlags
haddockFlags :: HaddockFlags
testFlags :: TestFlags
benchmarkFlags :: BenchmarkFlags
projectFlags :: ProjectFlags
extraFlags :: ()
benchmarkFlags :: forall a. NixStyleFlags a -> BenchmarkFlags
configExFlags :: forall a. NixStyleFlags a -> ConfigExFlags
configFlags :: forall a. NixStyleFlags a -> ConfigFlags
extraFlags :: forall a. NixStyleFlags a -> a
haddockFlags :: forall a. NixStyleFlags a -> HaddockFlags
installFlags :: forall a. NixStyleFlags a -> InstallFlags
projectFlags :: forall a. NixStyleFlags a -> ProjectFlags
testFlags :: forall a. NixStyleFlags a -> TestFlags
..} [[Char]]
ts GlobalFlags
globalFlags = do
  ProjectBaseContext
    { distDirLayout
    , cabalDirLayout
    , projectConfig
    , localPackages
    } <-
    Verbosity
-> ProjectConfig -> CurrentCommand -> IO ProjectBaseContext
establishProjectBaseContext Verbosity
verbosity ProjectConfig
cliConfig CurrentCommand
OtherCommand

  (_, elaboratedPlan, _, _, _) <-
    rebuildInstallPlan
      verbosity
      distDirLayout
      cabalDirLayout
      projectConfig
      localPackages
      Nothing

  targetSelectors <-
    either (reportTargetSelectorProblems verbosity) return
      =<< readTargetSelectors localPackages Nothing targetStrings

  targets :: TargetsMap <-
    either (reportBuildTargetProblems verbosity) return $
      resolveTargetsFromSolver
        selectPackageTargets
        selectComponentTarget
        elaboratedPlan
        Nothing
        targetSelectors

  printTargetForms verbosity targetStrings targets elaboratedPlan
  where
    verbosity :: Verbosity
verbosity =
      VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (VerbosityFlags -> Verbosity) -> VerbosityFlags -> Verbosity
forall a b. (a -> b) -> a -> b
$
        VerbosityFlags -> Flag VerbosityFlags -> VerbosityFlags
forall a. a -> Flag a -> a
fromFlagOrDefault VerbosityFlags
normal (ConfigFlags -> Flag VerbosityFlags
configVerbosity ConfigFlags
configFlags)
    targetStrings :: [[Char]]
targetStrings = if [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
ts then [[Char]
"all"] else [[Char]]
ts
    cliConfig :: ProjectConfig
cliConfig =
      GlobalFlags
-> NixStyleFlags () -> ClientInstallFlags -> ProjectConfig
forall a.
GlobalFlags
-> NixStyleFlags a -> ClientInstallFlags -> ProjectConfig
commandLineFlagsToProjectConfig
        GlobalFlags
globalFlags
        NixStyleFlags ()
flags
        ClientInstallFlags
forall a. Monoid a => a
mempty

reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a
reportBuildTargetProblems :: forall a. Verbosity -> [TargetProblem'] -> IO a
reportBuildTargetProblems Verbosity
verbosity = Verbosity -> [Char] -> [TargetProblem'] -> IO a
forall a. Verbosity -> [Char] -> [TargetProblem'] -> IO a
reportTargetProblems Verbosity
verbosity [Char]
"target"

printTargetForms :: Verbosity -> [String] -> TargetsMap -> ElaboratedInstallPlan -> IO ()
printTargetForms :: Verbosity
-> [[Char]] -> TargetsMap -> ElaboratedInstallPlan -> IO ()
printTargetForms Verbosity
verbosity [[Char]]
targetStrings TargetsMap
targets ElaboratedInstallPlan
elaboratedPlan =
  Verbosity -> Doc -> IO ()
noticeDoc Verbosity
verbosity (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$
    [Doc] -> Doc
vcat
      [ [Char] -> Doc
text [Char]
"Fully qualified target forms" Doc -> Doc -> Doc
Pretty.<> Doc
colon
      , Int -> Doc -> Doc
nest Int
1 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat [[Char] -> Doc
text [Char]
"-" Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
tf | [Char]
tf <- [[Char]]
targetForms]
      , Doc
found
      ]
  where
    found :: Doc
found =
      let n :: Int
n = TargetsMap -> Int
forall a. Map UnitId a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length TargetsMap
targets
          t :: [Char]
t = if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then [Char]
"target" else [Char]
"targets"
          query :: [Char]
query = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " [[Char]]
targetStrings
       in [Char] -> Doc
text [Char]
"Found" Doc -> Doc -> Doc
<+> Int -> Doc
int Int
n Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
t Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"matching" Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
query Doc -> Doc -> Doc
Pretty.<> Char -> Doc
char Char
'.'

    localPkgs :: [ElaboratedConfiguredPackage]
localPkgs =
      [ElaboratedConfiguredPackage
x | Configured x :: ElaboratedConfiguredPackage
x@ElaboratedConfiguredPackage{elabLocalToProject :: ElaboratedConfiguredPackage -> Bool
elabLocalToProject = Bool
True} <- ElaboratedInstallPlan
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList ElaboratedInstallPlan
elaboratedPlan]

    targetForm :: ComponentTarget -> ElaboratedConfiguredPackage -> [Char]
targetForm ComponentTarget
ct ElaboratedConfiguredPackage
x =
      let pkgId :: PackageId
pkgId@PackageIdentifier{pkgName :: PackageId -> PackageName
pkgName = PackageName
n} = ElaboratedConfiguredPackage -> PackageId
elabPkgSourceId ElaboratedConfiguredPackage
x
       in Doc -> [Char]
render (Doc -> [Char]) -> Doc -> [Char]
forall a b. (a -> b) -> a -> b
$ PackageName -> Doc
forall a. Pretty a => a -> Doc
pretty PackageName
n Doc -> Doc -> Doc
Pretty.<> Doc
colon Doc -> Doc -> Doc
Pretty.<> [Char] -> Doc
text (PackageId -> ComponentTarget -> [Char]
showComponentTarget PackageId
pkgId ComponentTarget
ct)

    targetForms :: [[Char]]
targetForms =
      [[Char]] -> [[Char]]
forall a. Ord a => [a] -> [a]
sort ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$
        [Maybe [Char]] -> [[Char]]
forall a. [Maybe a] -> [a]
catMaybes
          [ ComponentTarget -> ElaboratedConfiguredPackage -> [Char]
targetForm ComponentTarget
ct (ElaboratedConfiguredPackage -> [Char])
-> Maybe ElaboratedConfiguredPackage -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ElaboratedConfiguredPackage
pkg
          | (UnitId
u :: UnitId, [(ComponentTarget, NonEmpty TargetSelector)]
xs) <- TargetsMap
-> [(UnitId, [(ComponentTarget, NonEmpty TargetSelector)])]
forall k a. Map k a -> [(k, a)]
Map.toAscList TargetsMap
targets
          , let pkg :: Maybe ElaboratedConfiguredPackage
pkg = [ElaboratedConfiguredPackage] -> Maybe ElaboratedConfiguredPackage
forall a. [a] -> Maybe a
safeHead ([ElaboratedConfiguredPackage]
 -> Maybe ElaboratedConfiguredPackage)
-> [ElaboratedConfiguredPackage]
-> Maybe ElaboratedConfiguredPackage
forall a b. (a -> b) -> a -> b
$ (ElaboratedConfiguredPackage -> Bool)
-> [ElaboratedConfiguredPackage] -> [ElaboratedConfiguredPackage]
forall a. (a -> Bool) -> [a] -> [a]
filter ((UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
u) (UnitId -> Bool)
-> (ElaboratedConfiguredPackage -> UnitId)
-> ElaboratedConfiguredPackage
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElaboratedConfiguredPackage -> UnitId
elabUnitId) [ElaboratedConfiguredPackage]
localPkgs
          , (ComponentTarget
ct :: ComponentTarget, NonEmpty TargetSelector
_) <- [(ComponentTarget, NonEmpty TargetSelector)]
xs
          ]