module Stack.Options.Completion
( ghcOptsCompleter
, targetCompleter
, flagCompleter
, projectExeCompleter
) where
import Control.Monad.Logger (LogLevel (LevelOther))
import Data.Char (isSpace)
import Data.List (isPrefixOf)
import Data.List.Extra (nubOrd)
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 Options.Applicative
import Options.Applicative.Builder.Extra
import Stack.Build.Target (LocalPackageView(..))
import Stack.Build.Source (getLocalPackageViews)
import Stack.Options.GlobalParser (globalOptsFromMonoid)
import Stack.Runners (loadConfigWithOpts)
import Stack.Setup
import Stack.Types.Config
import Stack.Types.FlagName
import Stack.Types.Package
import Stack.Types.PackageName
import Stack.Types.StackT
import System.Process (readProcess)
import Language.Haskell.TH.Syntax (runIO, lift)
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`)
$(runIO (readProcess "ghc" ["--show-options"] "") >>= lift . lines)
buildConfigCompleter
:: (String -> StackT EnvConfig IO [String])
-> Completer
buildConfigCompleter inner = mkCompleter $ \inputRaw -> do
let input = unescapeBashArg inputRaw
case input of
('-': _) -> return []
_ -> do
let go = (globalOptsFromMonoid False mempty)
{ globalLogLevel = LevelOther "silent" }
lc <- loadConfigWithOpts go
bconfig <- runStackTGlobal () go $
lcLoadBuildConfig lc (globalCompiler go)
envConfig <-
runStackTGlobal bconfig go (setupEnv Nothing)
runStackTGlobal envConfig go (inner input)
targetCompleter :: Completer
targetCompleter = buildConfigCompleter $ \input -> do
lpvs <- getLocalPackageViews
return $
filter (input `isPrefixOf`) $
concatMap allComponentNames (Map.toList lpvs)
where
allComponentNames (name, (lpv, _)) =
map (T.unpack . renderPkgComponent . (name,)) (Set.toList (lpvComponents lpv))
flagCompleter :: Completer
flagCompleter = buildConfigCompleter $ \input -> do
lpvs <- getLocalPackageViews
bconfig <- view buildConfigL
let wildcardFlags
= nubOrd
$ concatMap (\(name, (_, gpd)) ->
map (\fl -> "*:" ++ flagString name fl) (C.genPackageFlags gpd))
$ Map.toList lpvs
normalFlags
= concatMap (\(name, (_, gpd)) ->
map (\fl -> packageNameString name ++ ":" ++ flagString name fl)
(C.genPackageFlags gpd))
$ Map.toList lpvs
flagString name fl =
case C.flagName fl of
C.FlagName flname -> (if flagEnabled name fl then "-" else "") ++ flname
flagEnabled name fl =
fromMaybe (C.flagDefault fl) $
Map.lookup (fromCabalFlagName (C.flagName fl)) $
Map.findWithDefault Map.empty name (unPackageFlags (bcFlags bconfig))
return $ filter (input `isPrefixOf`) $
case input of
('*' : ':' : _) -> wildcardFlags
('*' : _) -> wildcardFlags
_ -> normalFlags
projectExeCompleter :: Completer
projectExeCompleter = buildConfigCompleter $ \input -> do
lpvs <- getLocalPackageViews
return $
filter (input `isPrefixOf`) $
nubOrd $
concatMap (\(_, (_, gpd)) -> map fst (C.condExecutables gpd)) $
Map.toList lpvs