{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}

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 )

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 b. (a -> b) -> a -> b
$
          forall a. (a -> Bool) -> [a] -> [a]
filter (String
curArg `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 `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 `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 `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
        (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) forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] Executable)]
C.condExecutables)
        Map PackageName GenericPackageDescription
gpds