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

-- 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.

('-': _) -> 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