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

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

-- changes to optparse-applicative.


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

    (Char
'-': [Char]
_) -> [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    [Char]
_ -> 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' <- [Char]
-> Maybe (Path Abs File)
-> Bool
-> GlobalOptsMonoid
-> IO GlobalOpts
forall (m :: * -> *).
MonadIO m =>
[Char]
-> Maybe (Path Abs File)
-> Bool
-> GlobalOptsMonoid
-> m GlobalOpts
globalOptsFromMonoid [Char]
"" Maybe (Path Abs File)
forall a. Maybe a
Nothing Bool
False GlobalOptsMonoid
forall a. Monoid a => a
mempty
      let go = GlobalOpts
go' { logLevel = LevelOther "silent" }
      withRunnerGlobal go $ withConfig NoReexec $ withDefaultEnvConfig $ inner input

-- | A completer for components of project packages.

targetCompleter :: Completer
targetCompleter :: Completer
targetCompleter = ([Char] -> RIO EnvConfig [[Char]]) -> Completer
buildConfigCompleter (([Char] -> RIO EnvConfig [[Char]]) -> Completer)
-> ([Char] -> RIO EnvConfig [[Char]]) -> Completer
forall a b. (a -> b) -> a -> b
$ \[Char]
input -> do
  packages <- Getting
  (Map PackageName ProjectPackage)
  EnvConfig
  (Map PackageName ProjectPackage)
-> RIO EnvConfig (Map PackageName ProjectPackage)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
   (Map PackageName ProjectPackage)
   EnvConfig
   (Map PackageName ProjectPackage)
 -> RIO EnvConfig (Map PackageName ProjectPackage))
-> Getting
     (Map PackageName ProjectPackage)
     EnvConfig
     (Map PackageName ProjectPackage)
-> RIO EnvConfig (Map PackageName ProjectPackage)
forall a b. (a -> b) -> a -> b
$ (BuildConfig -> Const (Map PackageName ProjectPackage) BuildConfig)
-> EnvConfig -> Const (Map PackageName ProjectPackage) EnvConfig
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' EnvConfig BuildConfig
buildConfigL ((BuildConfig
  -> Const (Map PackageName ProjectPackage) BuildConfig)
 -> EnvConfig -> Const (Map PackageName ProjectPackage) EnvConfig)
-> ((Map PackageName ProjectPackage
     -> Const
          (Map PackageName ProjectPackage) (Map PackageName ProjectPackage))
    -> BuildConfig
    -> Const (Map PackageName ProjectPackage) BuildConfig)
-> Getting
     (Map PackageName ProjectPackage)
     EnvConfig
     (Map PackageName ProjectPackage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BuildConfig -> Map PackageName ProjectPackage)
-> SimpleGetter BuildConfig (Map PackageName ProjectPackage)
forall s a. (s -> a) -> SimpleGetter s a
to (.smWanted.project)
  comps <- for packages ppComponents
  pure $
    concatMap
      (filter (input `isPrefixOf`) . allComponentNames)
      (Map.toList comps)
 where
  allComponentNames :: (PackageName, Set NamedComponent) -> [[Char]]
allComponentNames (PackageName
name, Set NamedComponent
comps) =
    (NamedComponent -> [Char]) -> [NamedComponent] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> [Char]
T.unpack (Text -> [Char])
-> (NamedComponent -> Text) -> NamedComponent -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, NamedComponent) -> Text
renderPkgComponent ((PackageName, NamedComponent) -> Text)
-> (NamedComponent -> (PackageName, NamedComponent))
-> NamedComponent
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName
name,)) (Set NamedComponent -> [NamedComponent]
forall a. Set a -> [a]
Set.toList Set NamedComponent
comps)

-- | A completer for Cabal flags of project packages.

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

-- | A completer for executable components of project packages.

projectExeCompleter :: Completer
projectExeCompleter :: Completer
projectExeCompleter = ([Char] -> RIO EnvConfig [[Char]]) -> Completer
buildConfigCompleter (([Char] -> RIO EnvConfig [[Char]]) -> Completer)
-> ([Char] -> RIO EnvConfig [[Char]]) -> Completer
forall a b. (a -> b) -> a -> b
$ \[Char]
input -> do
  packages <- Getting
  (Map PackageName ProjectPackage)
  EnvConfig
  (Map PackageName ProjectPackage)
-> RIO EnvConfig (Map PackageName ProjectPackage)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
   (Map PackageName ProjectPackage)
   EnvConfig
   (Map PackageName ProjectPackage)
 -> RIO EnvConfig (Map PackageName ProjectPackage))
-> Getting
     (Map PackageName ProjectPackage)
     EnvConfig
     (Map PackageName ProjectPackage)
-> RIO EnvConfig (Map PackageName ProjectPackage)
forall a b. (a -> b) -> a -> b
$ (BuildConfig -> Const (Map PackageName ProjectPackage) BuildConfig)
-> EnvConfig -> Const (Map PackageName ProjectPackage) EnvConfig
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' EnvConfig BuildConfig
buildConfigL ((BuildConfig
  -> Const (Map PackageName ProjectPackage) BuildConfig)
 -> EnvConfig -> Const (Map PackageName ProjectPackage) EnvConfig)
-> ((Map PackageName ProjectPackage
     -> Const
          (Map PackageName ProjectPackage) (Map PackageName ProjectPackage))
    -> BuildConfig
    -> Const (Map PackageName ProjectPackage) BuildConfig)
-> Getting
     (Map PackageName ProjectPackage)
     EnvConfig
     (Map PackageName ProjectPackage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BuildConfig -> Map PackageName ProjectPackage)
-> SimpleGetter BuildConfig (Map PackageName ProjectPackage)
forall s a. (s -> a) -> SimpleGetter s a
to (.smWanted.project)
  gpds <- Map.traverseWithKey (const ppGPD) packages
  pure
    $ filter (input `isPrefixOf`)
    $ nubOrd
    $ concatMap
        (map (C.unUnqualComponentName . fst) . C.condExecutables)
        gpds