Completion.hs

{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings   #-}

{-|
Module      : Stack.Options.Completion
Description : Completers for command line arguments.
License     : BSD-3-Clause

Completers for command line arguments or arguments of command line options.
-}

module Stack.Options.Completion
  ( ghcOptsCompleter
  , targetCompleter
  , flagCompleter
  , projectExeCompleter
  ) where

import           Data.Char ( isSpace )
import           Data.List ( isPrefixOf )
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Distribution.PackageDescription as C
import           Options.Applicative ( Completer, mkCompleter )
import           Options.Applicative.Builder.Extra ( unescapeBashArg )
import           Stack.Constants ( ghcShowOptionsOutput )
import           Stack.Options.GlobalParser ( globalOptsFromMonoid )
import           Stack.Runners
                   ( ShouldReexec (..), withConfig, withDefaultEnvConfig
                   , withRunnerGlobal
                   )
import           Stack.Prelude
import           Stack.Types.BuildConfig ( BuildConfig (..), HasBuildConfig (..) )
import           Stack.Types.Config ( Config (..) )
import           Stack.Types.EnvConfig ( EnvConfig )
import           Stack.Types.GlobalOpts ( GlobalOpts (..) )
import           Stack.Types.Project ( Project (..) )
import           Stack.Types.ProjectConfig ( ProjectConfig (..) )
import           Stack.Types.NamedComponent ( renderPkgComponent )
import           Stack.Types.SourceMap ( SMWanted (..), ppComponents, ppGPD )

-- | A completer for @--ghc-options@ or @--ghci-options@.
ghcOptsCompleter :: Completer
ghcOptsCompleter = mkCompleter $ \inputRaw -> pure $
  let input = unescapeBashArg inputRaw
      (curArgReversed, otherArgsReversed) = break isSpace (reverse input)
      curArg = reverse curArgReversed
      otherArgs = reverse otherArgsReversed
  in  if null curArg
        then []
        else
          map (otherArgs ++) $
          filter (curArg `isPrefixOf`) ghcShowOptionsOutput

-- TODO: Ideally this would pay attention to --stack-yaml, may require
-- changes to optparse-applicative.

buildConfigCompleter :: (String -> RIO EnvConfig [String]) -> Completer
buildConfigCompleter inner = mkCompleter $ \inputRaw -> do
  let input = unescapeBashArg inputRaw
  case input of
    -- If it looks like a flag, skip this more costly completion.
    ('-': _) -> pure []
    _ -> do
      -- We do not need to specify the name of the current Stack executable, as
      -- it was invoked, or the path to the current Stack executable, as
      -- withDefaultEnvConfig does not need either.
      go' <- globalOptsFromMonoid "" Nothing False mempty
      let go = go' { logLevel = LevelOther "silent" }
      withRunnerGlobal go $ withConfig NoReexec $ withDefaultEnvConfig $ inner input

-- | A completer for components of project packages.
targetCompleter :: Completer
targetCompleter = buildConfigCompleter $ \input -> do
  packages <- view $ buildConfigL . to (.smWanted.project)
  comps <- for packages ppComponents
  pure $
    concatMap
      (filter (input `isPrefixOf`) . allComponentNames)
      (Map.toList comps)
 where
  allComponentNames (name, comps) =
    map (T.unpack . renderPkgComponent . (name,)) (Set.toList comps)

-- | A completer for Cabal flags of project packages.
flagCompleter :: Completer
flagCompleter = buildConfigCompleter $ \input -> do
  bconfig <- view buildConfigL
  gpds <- for bconfig.smWanted.project ppGPD
  let wildcardFlags
        = nubOrd
        $ concatMap (\(name, gpd) ->
            map (\fl -> "*:" ++ flagString name fl) (C.genPackageFlags gpd))
        $ Map.toList gpds
      normalFlags
        = concatMap (\(name, gpd) ->
            map (\fl -> packageNameString name ++ ":" ++ flagString name fl)
                (C.genPackageFlags gpd))
        $ Map.toList gpds
      flagString name fl =
        let flname = C.unFlagName $ C.flagName fl
        in  (if flagEnabled name fl then "-" else "") ++ flname
      prjFlags =
        case bconfig.config.project of
          PCProject (p, _) -> p.flagsByPkg
          PCGlobalProject -> mempty
          PCNoProject _ -> mempty
      flagEnabled name fl =
        fromMaybe (C.flagDefault fl) $
        Map.lookup (C.flagName fl) $
        Map.findWithDefault Map.empty name prjFlags
  pure $ filter (input `isPrefixOf`) $
    case input of
      ('*' : ':' : _) -> wildcardFlags
      ('*' : _) -> wildcardFlags
      _ -> normalFlags

-- | A completer for executable components of project packages.
projectExeCompleter :: Completer
projectExeCompleter = buildConfigCompleter $ \input -> do
  packages <- view $ buildConfigL . to (.smWanted.project)
  gpds <- Map.traverseWithKey (const ppGPD) packages
  pure
    $ filter (input `isPrefixOf`)
    $ nubOrd
    $ concatMap
        (map (C.unUnqualComponentName . fst) . C.condExecutables)
        gpds