{-# 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           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 :: Completer
ghcOptsCompleter = (String -> IO [String]) -> Completer
mkCompleter forall a b. (a -> b) -> a -> b
$ \String
inputRaw -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    let input :: String
input = String -> String
unescapeBashArg String
inputRaw
        (String
curArgReversed, String
otherArgsReversed) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace (forall a. [a] -> [a]
reverse String
input)
        curArg :: String
curArg = forall a. [a] -> [a]
reverse String
curArgReversed
        otherArgs :: String
otherArgs = forall a. [a] -> [a]
reverse String
otherArgsReversed
     in if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
curArg then [] else
         forall a b. (a -> b) -> [a] -> [b]
map (String
otherArgs forall a. [a] -> [a] -> [a]
++) forall a b. (a -> b) -> a -> b
$
         forall a. (a -> Bool) -> [a] -> [a]
filter (String
curArg forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
ghcShowOptionsOutput

-- TODO: Ideally this would pay attention to --stack-yaml, may require

-- changes to optparse-applicative.


buildConfigCompleter
    :: (String -> RIO EnvConfig [String])
    -> Completer
buildConfigCompleter :: (String -> RIO EnvConfig [String]) -> Completer
buildConfigCompleter String -> RIO EnvConfig [String]
inner = (String -> IO [String]) -> Completer
mkCompleter forall a b. (a -> b) -> a -> b
$ \String
inputRaw -> do
    let input :: String
input = String -> String
unescapeBashArg String
inputRaw
    case String
input of
        -- If it looks like a flag, skip this more costly completion.

        (Char
'-': String
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        String
_ -> do
            GlobalOpts
go' <- forall (m :: * -> *).
MonadIO m =>
Bool -> GlobalOptsMonoid -> m GlobalOpts
globalOptsFromMonoid Bool
False forall a. Monoid a => a
mempty
            let go :: GlobalOpts
go = GlobalOpts
go' { globalLogLevel :: LogLevel
globalLogLevel = Text -> LogLevel
LevelOther Text
"silent" }
            forall a. GlobalOpts -> RIO Runner a -> IO a
withRunnerGlobal GlobalOpts
go forall a b. (a -> b) -> a -> b
$ forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
NoReexec forall a b. (a -> b) -> a -> b
$ forall a. RIO EnvConfig a -> RIO Config a
withDefaultEnvConfig forall a b. (a -> b) -> a -> b
$ String -> RIO EnvConfig [String]
inner String
input

targetCompleter :: Completer
targetCompleter :: Completer
targetCompleter = (String -> RIO EnvConfig [String]) -> Completer
buildConfigCompleter forall a b. (a -> b) -> a -> b
$ \String
input -> do
  Map PackageName ProjectPackage
packages <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to (SMWanted -> Map PackageName ProjectPackage
smwProject forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildConfig -> SMWanted
bcSMWanted)
  Map PackageName (Set NamedComponent)
comps <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Map PackageName ProjectPackage
packages forall (m :: * -> *).
MonadIO m =>
ProjectPackage -> m (Set NamedComponent)
ppComponents
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (String
input forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)
    forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (PackageName, Set NamedComponent) -> [String]
allComponentNames
    forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName (Set NamedComponent)
comps
  where
    allComponentNames :: (PackageName, Set NamedComponent) -> [String]
allComponentNames (PackageName
name, Set NamedComponent
comps) =
        forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, NamedComponent) -> Text
renderPkgComponent forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName
name,)) (forall a. Set a -> [a]
Set.toList Set NamedComponent
comps)

flagCompleter :: Completer
flagCompleter :: Completer
flagCompleter = (String -> RIO EnvConfig [String]) -> Completer
buildConfigCompleter forall a b. (a -> b) -> a -> b
$ \String
input -> do
    BuildConfig
bconfig <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigL
    Map PackageName GenericPackageDescription
gpds <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (SMWanted -> Map PackageName ProjectPackage
smwProject forall a b. (a -> b) -> a -> b
$ BuildConfig -> SMWanted
bcSMWanted BuildConfig
bconfig) forall (m :: * -> *).
MonadIO m =>
ProjectPackage -> m GenericPackageDescription
ppGPD
    let wildcardFlags :: [String]
wildcardFlags
            = forall a. Ord a => [a] -> [a]
nubOrd
            forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(PackageName
name, GenericPackageDescription
gpd) ->
                forall a b. (a -> b) -> [a] -> [b]
map (\PackageFlag
fl -> String
"*:" forall a. [a] -> [a] -> [a]
++ PackageName -> PackageFlag -> String
flagString PackageName
name PackageFlag
fl) (GenericPackageDescription -> [PackageFlag]
C.genPackageFlags GenericPackageDescription
gpd))
            forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName GenericPackageDescription
gpds
        normalFlags :: [String]
normalFlags
            = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(PackageName
name, GenericPackageDescription
gpd) ->
                forall a b. (a -> b) -> [a] -> [b]
map (\PackageFlag
fl -> PackageName -> String
packageNameString PackageName
name forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ PackageName -> PackageFlag -> String
flagString PackageName
name PackageFlag
fl)
                    (GenericPackageDescription -> [PackageFlag]
C.genPackageFlags GenericPackageDescription
gpd))
            forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName GenericPackageDescription
gpds
        flagString :: PackageName -> PackageFlag -> String
flagString PackageName
name PackageFlag
fl =
            let flname :: String
flname = FlagName -> String
C.unFlagName forall a b. (a -> b) -> a -> b
$ PackageFlag -> FlagName
C.flagName PackageFlag
fl
             in (if PackageName -> PackageFlag -> Bool
flagEnabled PackageName
name PackageFlag
fl then String
"-" else String
"") forall a. [a] -> [a] -> [a]
++ String
flname
        prjFlags :: Map PackageName (Map FlagName Bool)
prjFlags =
          case Config -> ProjectConfig (Project, Path Abs File)
configProject (BuildConfig -> Config
bcConfig BuildConfig
bconfig) of
            PCProject (Project
p, Path Abs File
_) -> Project -> Map PackageName (Map FlagName Bool)
projectFlags Project
p
            ProjectConfig (Project, Path Abs File)
PCGlobalProject -> forall a. Monoid a => a
mempty
            PCNoProject [PackageIdentifierRevision]
_ -> forall a. Monoid a => a
mempty
        flagEnabled :: PackageName -> PackageFlag -> Bool
flagEnabled PackageName
name PackageFlag
fl =
            forall a. a -> Maybe a -> a
fromMaybe (PackageFlag -> Bool
C.flagDefault PackageFlag
fl) forall a b. (a -> b) -> a -> b
$
            forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (PackageFlag -> FlagName
C.flagName PackageFlag
fl) forall a b. (a -> b) -> a -> b
$
            forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault forall k a. Map k a
Map.empty PackageName
name Map PackageName (Map FlagName Bool)
prjFlags
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (String
input forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) forall a b. (a -> b) -> a -> b
$
        case String
input of
            (Char
'*' : Char
':' : String
_) -> [String]
wildcardFlags
            (Char
'*' : String
_) -> [String]
wildcardFlags
            String
_ -> [String]
normalFlags

projectExeCompleter :: Completer
projectExeCompleter :: Completer
projectExeCompleter = (String -> RIO EnvConfig [String]) -> Completer
buildConfigCompleter forall a b. (a -> b) -> a -> b
$ \String
input -> do
  Map PackageName ProjectPackage
packages <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to (SMWanted -> Map PackageName ProjectPackage
smwProject forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildConfig -> SMWanted
bcSMWanted)
  Map PackageName GenericPackageDescription
gpds <- forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey (forall a b. a -> b -> a
const forall (m :: * -> *).
MonadIO m =>
ProjectPackage -> m GenericPackageDescription
ppGPD) Map PackageName ProjectPackage
packages
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (String
input forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)
    forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
nubOrd
    forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
        (\GenericPackageDescription
gpd -> forall a b. (a -> b) -> [a] -> [b]
map
          (UnqualComponentName -> String
C.unUnqualComponentName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
          (GenericPackageDescription
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] Executable)]
C.condExecutables GenericPackageDescription
gpd)
        )
        Map PackageName GenericPackageDescription
gpds