content: {-# 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
  