Target.hs

{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE MultiWayIf            #-}
{-# LANGUAGE NoFieldSelectors      #-}
{-# LANGUAGE OverloadedRecordDot   #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ViewPatterns          #-}

{-|
Module      : Stack.Build.Target
Description : Parsing command line targets.
License     : BSD-3-Clause

Parsing command line targets

There are two relevant data sources for performing this parsing: the project
configuration, and command line arguments. Project configurations includes the
snapshot (defining a LoadedSnapshot of global and snapshot packages), local
dependencies, and project packages. It also defines local flag overrides.

The command line arguments specify both additional local flag overrides and
targets in their raw form.

Flags are simple: we just combine CLI flags with config flags and make one big
map of flags, preferring CLI flags when present.

Raw targets can be a package name, a package name with component, just a
component, or a package name and version number. We first must resolve these raw
targets into both simple targets and additional dependencies. This works as
follows:

* If a component is specified, find a unique project package which defines that
  component, and convert it into a name+component target.

* Ensure that all name+component values refer to valid components in the given
  project package.

* For names, check if the name is present in the snapshot, local deps, or
  project packages. If it is not, then look up the most recent version in the
  package index and convert to a name+version.

* For name+version, first ensure that the name is not used by a project
  package. Next, if that name+version is present in the snapshot or local deps
  _and_ its location is PLIndex, we have the package. Otherwise, add to local
  deps with the appropriate PLIndex.

If in either of the last two bullets we added a package to local deps, print a
warning to the user recommending modifying the extra-deps.

Combine the various t'ResolveResult's together into t'Target' values, by
combining various components for a single package and ensuring that no
conflicting statements were made about targets.

At this point, we now have a Map from package name to SimpleTarget, and an
updated Map of local dependencies. We still have the aggregated flags, and the
snapshot and project packages.

Finally, we upgrade the snapshot by using calculatePackagePromotion.
-}

module Stack.Build.Target
  ( -- * Types
    Target (..)
  , NeedTargets (..)
  , parseTargets
    -- * Convenience helpers
  , gpdVersion
    -- * Test suite exports
  , parseRawTarget
  , RawTarget (..)
  , UnresolvedComponent (..)
  , ComponentName
  , ResolveResult
  ) where

import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import           Path ( isProperPrefixOf )
import           Path.Extra ( forgivingResolveDir, rejectMissingDir )
import           Path.IO ( getCurrentDir )
import           RIO.Process ( HasProcessContext )
import           Stack.SourceMap ( additionalDepPackage )
import           Stack.Prelude
import           Stack.Types.BuildConfig
                   ( BuildConfig (..), HasBuildConfig (..) )
import           Stack.Types.BuildOptsCLI ( BuildOptsCLI (..) )
import           Stack.Types.ComponentUtils ( unqualCompFromText )
import           Stack.Types.Config ( Config (..) )
import           Stack.Types.NamedComponent
                   ( NamedComponent (..), renderComponent )
import           Stack.Types.Build.Exception ( BuildPrettyException (..) )
import           Stack.Types.ProjectConfig ( ProjectConfig (..) )
import           Stack.Types.SourceMap
                   ( DepPackage (..), GlobalPackage (..), PackageType (..)
                   , ProjectPackage, SMActual (..), SMTargets (..)
                   , SMWanted (..), Target (..), ppComponents, ppRoot
                   )

-- | Do we need any targets? For example, `stack build` will fail if
-- no targets are provided.
data NeedTargets
  = NeedTargets
  | AllowNoTargets

--------------------------------------------------------------------------------
-- Get the RawInput
--------------------------------------------------------------------------------

-- | Raw target information passed on the command line.
newtype RawInput = RawInput { rawInput :: Text }

getRawInput ::
     BuildOptsCLI
  -> Map PackageName ProjectPackage
  -> ([Text], [RawInput])
getRawInput boptscli locals =
  let textTargets' = boptscli.targetsCLI
      textTargets =
        -- Handle the no targets case, which means we pass in the names of all
        -- project packages
        if null textTargets'
          then map (T.pack . packageNameString) (Map.keys locals)
          else textTargets'
  in  (textTargets', map RawInput textTargets)

--------------------------------------------------------------------------------
-- Turn RawInput into RawTarget
--------------------------------------------------------------------------------

-- | The name of a component, which applies to executables, test
-- suites, and benchmarks
type ComponentName = Text

-- | Either a fully resolved component, or a component name that could be
-- either an executable, test, or benchmark
data UnresolvedComponent
  = ResolvedComponent !NamedComponent
  | UnresolvedComponent !ComponentName
  deriving (Eq, Ord, Show)

-- | Raw command line input, without checking against any databases or list of
-- locals. Does not deal with directories
data RawTarget
  = RTPackageComponent !PackageName !UnresolvedComponent
  | RTComponent !ComponentName
  | RTPackage !PackageName
    -- Explicitly _not_ supporting revisions on the command line. If you want
    -- that, you should be modifying your stack.yaml! (In fact, you should
    -- probably do that anyway, we're just letting people be lazy, since we're
    -- Haskeletors.)
  | RTPackageIdentifier !PackageIdentifier
  deriving (Eq, Show)

-- | Same as @parseRawTarget@, but also takes directories into account.
parseRawTargetDirs ::
     MonadIO m
  => Path Abs Dir -- ^ current directory
  -> Map PackageName ProjectPackage
  -> RawInput -- ^ raw target information from the commandline
  -> m (Either StyleDoc [(RawInput, RawTarget)])
parseRawTargetDirs root locals ri =
  case parseRawTarget t of
    Just rt -> pure $ Right [(ri, rt)]
    Nothing -> do
      forgivingResolveDir root (T.unpack t) >>= rejectMissingDir >>= \case
        Nothing -> pure $ Left $
          if | T.isPrefixOf "stack-yaml=" t -> projectOptionTypo
             | T.isSuffixOf ".yaml" t -> projectYamlExtTypo
             | otherwise ->
                fillSep
                  [ flow "Directory not found:"
                  , style Dir (fromString $ T.unpack t) <> "."
                  ]
        Just dir ->
          case mapMaybe (childOf dir) $ Map.toList locals of
            [] -> pure $ Left $
              fillSep
                [ style Dir (fromString $ T.unpack t)
                , flow "is not a local directory for a package and it is not a \
                       \parent directory of any such directory."
                ]
            names -> pure $ Right $ map ((ri, ) . RTPackage) names
 where
  childOf dir (name, pp) =
    if dir == ppRoot pp || isProperPrefixOf dir (ppRoot pp)
      then Just name
      else Nothing

  RawInput t = ri

  projectOptionTypo :: StyleDoc
  projectOptionTypo = let o = "stack-yaml=" in projectTypo 2 (length o) o

  projectYamlExtTypo :: StyleDoc
  projectYamlExtTypo = let o = "stack-yaml " in projectTypo (2 + length o) 0 o

  projectTypo :: Int -> Int -> String -> StyleDoc
  projectTypo padLength dropLength option =
    vsep
      [ style Dir (fromString (replicate padLength ' ') <> fromString (T.unpack t))
        <> " is not a directory."
      , style Highlight (fromString $ "--" <> option)
        <> style Dir (fromString . drop dropLength $ T.unpack t)
        <> " might work as a project option."
      ]

-- | If this function returns @Nothing@, the input should be treated as a
-- directory.
parseRawTarget :: Text -> Maybe RawTarget
parseRawTarget t =
      (RTPackageIdentifier <$> parsePackageIdentifier s)
  <|> (RTPackage <$> parsePackageName s)
  <|> (RTComponent <$> T.stripPrefix ":" t)
  <|> parsePackageComponent
 where
  s = T.unpack t

  parsePackageComponent =
    case T.splitOn ":" t of
      [pname, "lib"]
        | Just pname' <- parsePackageName (T.unpack pname) ->
            Just $ RTPackageComponent pname' $ ResolvedComponent CLib
      [pname, cname]
        | Just pname' <- parsePackageName (T.unpack pname) ->
            Just $ RTPackageComponent pname' $ UnresolvedComponent cname
      [pname, typ, cname]
        | Just pname' <- parsePackageName (T.unpack pname)
        , Just wrapper <- parseCompType typ ->
            Just $ RTPackageComponent pname' $ ResolvedComponent $ wrapper cname
      _ -> Nothing

  parseCompType t' =
    case t' of
      "exe" -> Just (CExe . unqualCompFromText)
      "test" -> Just (CTest . unqualCompFromText)
      "bench" -> Just (CBench . unqualCompFromText)
      _ -> Nothing

--------------------------------------------------------------------------------
-- Resolve the raw targets
--------------------------------------------------------------------------------

-- | A type representing results of resolving a raw target.
data ResolveResult = ResolveResult
  { name :: !PackageName
  , rawInput :: !RawInput
  , component :: !(Maybe NamedComponent)
    -- ^ Was a concrete component specified?
  , addedDep :: !(Maybe PackageLocationImmutable)
    -- ^ Only if we're adding this as a dependency
  , packageType :: !PackageType
  }

-- | Convert a 'RawTarget' into a t'ResolveResult' (see description on the
-- module).
resolveRawTarget ::
     (HasLogFunc env, HasPantryConfig env, HasProcessContext env)
  => SMActual GlobalPackage
  -> Map PackageName PackageLocation
  -> (RawInput, RawTarget)
  -> RIO env (Either StyleDoc ResolveResult)
resolveRawTarget sma allLocs (rawInput, rt) =
  go rt
 where
  locals = sma.project
  deps = sma.deps
  globals = sma.globals
  -- Helper function: check if a 'NamedComponent' matches the given
  -- 'ComponentName'
  isCompNamed :: ComponentName -> NamedComponent -> Bool
  isCompNamed _ CLib = False
  isCompNamed t1 t2 = case t2 of
    (CSubLib t2') -> t1' == t2'
    (CExe t2') -> t1' == t2'
    (CFlib t2') -> t1' == t2'
    (CTest t2') -> t1' == t2'
    (CBench t2') -> t1' == t2'
   where
    t1' = unqualCompFromText t1

  go (RTComponent cname) = do
    -- Associated list from component name to package that defines it. We use an
    -- assoc list and not a Map so we can detect duplicates.
    allPairs <- fmap concat $ flip Map.traverseWithKey locals
      $ \name pp -> do
          comps <- ppComponents pp
          pure $ map (name, ) $ Set.toList comps
    pure $ case filter (isCompNamed cname . snd) allPairs of
      [] -> Left $
        fillSep
          [ style Target . fromString . T.unpack $ cname
          , flow "doesn't seem to be a local target. Run"
          , style Shell $ flow "stack ide targets"
          , flow "for a list of available targets."
          ]
      [(name, component)] -> Right ResolveResult
        { name
        , rawInput
        , component = Just component
        , addedDep = Nothing
        , packageType = PTProject
        }
      matches -> Left $
           fillSep
             [ flow "Ambiguous component name"
             , style Target (fromString $ T.unpack cname) <> ","
             , "matches:"
             ]
        <> line
        <> bulletedList
             ( map
                 ( \(pn, nc) -> fillSep
                     [ "component"
                     , style
                         PkgComponent
                         (fromString $ T.unpack $ renderComponent nc)
                     , flow "of package"
                     , style PkgComponent (fromPackageName pn)
                     ]
                 )
                 matches
             )

  go (RTPackageComponent name ucomp) =
    case Map.lookup name locals of
      Nothing -> pure $ Left $
        fillSep
          [ flow "Unknown project package:"
          , style Target (fromPackageName name) <> "."
          ]
      Just pp -> do
        comps <- ppComponents pp
        pure $ case ucomp of
          ResolvedComponent component
            | component `Set.member` comps -> Right ResolveResult
                { name
                , rawInput
                , component = Just component
                , addedDep = Nothing
                , packageType = PTProject
                }
            | otherwise -> Left $
                fillSep
                  [ "Component"
                  , style
                      Target
                      (fromString $ T.unpack $ renderComponent component)
                  , flow "does not exist in package"
                  , style Target (fromPackageName name) <> "."
                  ]
          UnresolvedComponent comp' ->
            case filter (isCompNamed comp') $ Set.toList comps of
              [] -> Left $
                fillSep
                  [ "Component"
                  , style Target (fromString $ T.unpack comp')
                  , flow "does not exist in package"
                  , style Target (fromPackageName name) <> "."
                  ]
              [component] -> Right ResolveResult
                { name
                , rawInput
                , component = Just component
                , addedDep = Nothing
                , packageType = PTProject
                }
              matches -> Left $
                fillSep
                  [ flow "Ambiguous component name"
                  , style Target (fromString $ T.unpack comp')
                  , flow "for package"
                  , style Target (fromPackageName name)
                  , flow "matches components:"
                  , fillSep $
                      mkNarrativeList (Just PkgComponent) False
                        (map ncToStyleDoc matches)
                  ]
   where
    ncToStyleDoc :: NamedComponent -> StyleDoc
    ncToStyleDoc = fromString . T.unpack . renderComponent

  go (RTPackage name)
    | Map.member name locals = pure $ Right ResolveResult
        { name
        , rawInput
        , component = Nothing
        , addedDep = Nothing
        , packageType = PTProject
        }
    | Map.member name deps =
        pure $ deferToConstructPlan name
    | Just gp <- Map.lookup name globals =
        case gp of
          GlobalPackage _ -> pure $ deferToConstructPlan name
          ReplacedGlobalPackage _ -> hackageLatest name
    | otherwise = hackageLatest name

  -- Note that we use getLatestHackageRevision below, even though it's
  -- non-reproducible, to avoid user confusion. In any event, reproducible
  -- builds should be done by updating your config files!

  go (RTPackageIdentifier ident@(PackageIdentifier name version))
    | Map.member name locals = pure $ Left $
        fillSep
          [ style Target (fromPackageId ident)
          , flow "is a specific package version, but"
          , style Target (fromPackageName name)
          , flow "is the name of a project package. To avoid confusion, Stack \
                 \will not try to build the specified version or the project \
                 \package. To build the project package, specify only"
          , style Current (fromPackageName name) <> "."
          ]
    | otherwise =
        case Map.lookup name allLocs of
          -- Installing it from the package index, so we're cool with overriding
          -- it if necessary
          Just
            ( PLImmutable
                ( PLIHackage
                    (PackageIdentifier _name versionLoc) _cfKey _treeKey
                )
            ) ->
              if version == versionLoc
                then pure $ deferToConstructPlan name
                else hackageLatestRevision name version versionLoc
          -- The package was coming from something besides the index, so refuse
          -- to do the override
          Just loc' -> pure $ Left $
            fillSep
              [ style Target (fromPackageId ident)
              , flow "was specified from a non-index location, namely:"
              , flow $ T.unpack $ textDisplay loc' <> "."
              , flow "Recommendation: add the correctly desired version to \
                     \extra-deps."
              ]
          -- Not present at all, add it from Hackage
          Nothing ->
            getLatestHackageRevision YesRequireHackageIndex name version <&> \case
              Nothing -> Left $
                fillSep
                  [ flow "Stack did not know the location of a package named"
                  , style Target (fromPackageName name)
                  , "and could not find"
                  , style Target (fromPackageId ident)
                  , flow "in the package index."
                  ]
              Just (_rev, cfKey, treeKey) -> Right ResolveResult
                { name
                , rawInput
                , component = Nothing
                , addedDep = Just $
                    PLIHackage (PackageIdentifier name version) cfKey treeKey
                , packageType = PTDependency
                }

  hackageLatest name =
    getLatestHackageLocation YesRequireHackageIndex name UsePreferredVersions <&> \case
      Nothing -> deferToConstructPlan name
      Just loc ->
        Right ResolveResult
          { name
          , rawInput
          , component = Nothing
          , addedDep = Just loc
          , packageType = PTDependency
          }

  hackageLatestRevision name version versionLoc =
    getLatestHackageRevision YesRequireHackageIndex name version <&> \case
      Nothing -> Left $
        fillSep
          [ flow "Stack knows the location of"
          , style Current (fromPackageId pkgId')
          , flow "but did not know the location of"
          , style Target (fromPackageId pkgId) <>","
          , flow "and did not find it in the package index."
          ]
       where
        pkgId = PackageIdentifier name version
        pkgId' = PackageIdentifier name versionLoc
      Just (_rev, cfKey, treeKey) -> Right ResolveResult
        { name
        , rawInput
        , component = Nothing
        , addedDep =
            Just $ PLIHackage (PackageIdentifier name version) cfKey treeKey
        , packageType = PTDependency
        }

  -- This is actually an error case. We _could_ pure a Left value here, but it
  -- turns out to be better to defer this until the ConstructPlan phase, and let
  -- it complain about the missing package so that we get more errors together,
  -- plus the fancy colored output from that module.
  deferToConstructPlan name = Right ResolveResult
    { name
    , rawInput
    , component = Nothing
    , addedDep = Nothing
    , packageType = PTDependency
    }
--------------------------------------------------------------------------------
-- Combine the ResolveResults
--------------------------------------------------------------------------------

combineResolveResults ::
     forall env. HasLogFunc env
  => [ResolveResult]
  -> RIO
       env
       ( [StyleDoc]
       , Map PackageName Target
       , Map PackageName PackageLocationImmutable
       )
combineResolveResults results = do
  addedDeps <- fmap Map.unions $ forM results $ \result ->
    case result.addedDep of
      Nothing -> pure Map.empty
      Just pl -> pure $ Map.singleton result.name pl

  let m0 = Map.unionsWith (++) $
        map (\rr -> Map.singleton rr.name [rr]) results
      (errs, ms) = partitionEithers $ flip map (Map.toList m0) $
        \(name, rrs) ->
          let mcomps = map (.component) rrs in
          -- Confirm that there is either exactly 1 with no component, or that
          -- all rrs are components
          case rrs of
            [] -> assert False $
              Left $
                flow "Somehow got no rrComponent values, that can't happen."
            [rr] | isNothing rr.component ->
              Right $ Map.singleton name $ TargetAll rr.packageType
            _
              | all isJust mcomps ->
                  Right $ Map.singleton name $ TargetComps $ Set.fromList $
                    catMaybes mcomps
              | otherwise -> Left $ fillSep
                  [ flow "The package"
                  , style Target $ fromPackageName name
                  , flow "was specified in multiple, incompatible ways:"
                  , fillSep $
                      mkNarrativeList (Just Target) False
                        (map rrToStyleDoc rrs)
                  ]
  pure (errs, Map.unions ms, addedDeps)
 where
  rrToStyleDoc :: ResolveResult -> StyleDoc
  rrToStyleDoc = fromString . T.unpack . (.rawInput.rawInput)

--------------------------------------------------------------------------------
-- OK, let's do it!
--------------------------------------------------------------------------------

-- | Parse targets and dependencies from the given command line arguments and
-- source map.
parseTargets ::
     HasBuildConfig env
  => NeedTargets
  -> Bool
     -- ^ Should Haddock documentation be built for the package?
  -> BuildOptsCLI
  -> SMActual GlobalPackage
  -> RIO env SMTargets
parseTargets needTargets haddockDeps boptscli smActual = do
  logDebug "Parsing the targets"
  bconfig <- view buildConfigL
  workingDir <- getCurrentDir
  locals <- view $ buildConfigL . to (.smWanted.project)
  let (textTargets', rawInput) = getRawInput boptscli locals

  (errs1, concat -> rawTargets) <- fmap partitionEithers $ forM rawInput $
    parseRawTargetDirs workingDir locals

  let depLocs = Map.map (.location) smActual.deps

  (errs2, resolveResults) <- fmap partitionEithers $ forM rawTargets $
    resolveRawTarget smActual depLocs

  (errs3, targets, addedDeps) <- combineResolveResults resolveResults

  case concat [errs1, errs2, errs3] of
    [] -> pure ()
    errs -> prettyThrowIO $ TargetParseException errs

  case (Map.null targets, needTargets) of
    (False, _) -> pure ()
    (True, AllowNoTargets) -> pure ()
    (True, NeedTargets)
      | null textTargets' && bcImplicitGlobal bconfig ->
          prettyThrowIO $ TargetParseException
            [ fillSep
                [ flow "The specified targets matched no packages. Perhaps you \
                       \need to run"
                , style Shell (flow "stack init") <> "?"
                ]
            ]
      | null textTargets' && Map.null locals ->
          prettyThrowIO $ TargetParseException
            [ flow "The project contains no project packages (packages other \
                   \than extra-deps)."
            ]
      | otherwise -> prettyThrowIO $ TargetParseException
          [ flow "The specified targets matched no packages." ]

  addedDeps' <- mapM (additionalDepPackage haddockDeps . PLImmutable) addedDeps

  pure SMTargets
    { targets = targets
    , deps = addedDeps'
    }
 where
  bcImplicitGlobal bconfig =
    case bconfig.config.project of
      PCProject _ -> False
      PCGlobalProject -> True
      PCNoProject _ -> False