{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Stack.Options.Completion
( ghcOptsCompleter
, targetCompleter
, flagCompleter
, projectExeCompleter
) where
import Data.Char (isSpace)
import Data.List (isPrefixOf)
import qualified Data.Map as Map
import Data.Maybe
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Distribution.PackageDescription as C
import qualified Distribution.Types.UnqualComponentName as C
import Options.Applicative
import Options.Applicative.Builder.Extra
import Stack.Constants (ghcShowOptionsOutput)
import Stack.Options.GlobalParser (globalOptsFromMonoid)
import Stack.Runners
import Stack.Prelude
import Stack.Types.Config
import Stack.Types.NamedComponent
import Stack.Types.SourceMap
ghcOptsCompleter :: Completer
ghcOptsCompleter = mkCompleter $ \inputRaw -> return $
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
buildConfigCompleter
:: (String -> RIO EnvConfig [String])
-> Completer
buildConfigCompleter inner = mkCompleter $ \inputRaw -> do
let input = unescapeBashArg inputRaw
case input of
('-': _) -> return []
_ -> do
go' <- globalOptsFromMonoid False mempty
let go = go' { globalLogLevel = LevelOther "silent" }
withRunnerGlobal go $ withConfig NoReexec $ withDefaultEnvConfig $ inner input
targetCompleter :: Completer
targetCompleter = buildConfigCompleter $ \input -> do
packages <- view $ buildConfigL.to (smwProject . bcSMWanted)
comps <- for packages ppComponents
pure
$ filter (input `isPrefixOf`)
$ concatMap allComponentNames
$ Map.toList comps
where
allComponentNames (name, comps) =
map (T.unpack . renderPkgComponent . (name,)) (Set.toList comps)
flagCompleter :: Completer
flagCompleter = buildConfigCompleter $ \input -> do
bconfig <- view buildConfigL
gpds <- for (smwProject $ bcSMWanted bconfig) 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 configProject (bcConfig bconfig) of
PCProject (p, _) -> projectFlags p
PCGlobalProject -> mempty
PCNoProject _ -> mempty
flagEnabled name fl =
fromMaybe (C.flagDefault fl) $
Map.lookup (C.flagName fl) $
Map.findWithDefault Map.empty name prjFlags
return $ filter (input `isPrefixOf`) $
case input of
('*' : ':' : _) -> wildcardFlags
('*' : _) -> wildcardFlags
_ -> normalFlags
projectExeCompleter :: Completer
projectExeCompleter = buildConfigCompleter $ \input -> do
packages <- view $ buildConfigL.to (smwProject . bcSMWanted)
gpds <- Map.traverseWithKey (const ppGPD) packages
pure
$ filter (input `isPrefixOf`)
$ nubOrd
$ concatMap
(\gpd -> map
(C.unUnqualComponentName . fst)
(C.condExecutables gpd)
)
gpds