{-# 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 ((String -> IO [String]) -> Completer)
-> (String -> IO [String]) -> Completer
forall a b. (a -> b) -> a -> b
$ \String
inputRaw -> [String] -> IO [String]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$
  let input :: String
input = String -> String
unescapeBashArg String
inputRaw
      (String
curArgReversed, String
otherArgsReversed) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace (String -> String
forall a. [a] -> [a]
reverse String
input)
      curArg :: String
curArg = String -> String
forall a. [a] -> [a]
reverse String
curArgReversed
      otherArgs :: String
otherArgs = String -> String
forall a. [a] -> [a]
reverse String
otherArgsReversed
  in  if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
curArg
        then []
        else
          (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
otherArgs ++) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
          (String -> Bool) -> [String] -> [String]
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 ((String -> IO [String]) -> Completer)
-> (String -> IO [String]) -> Completer
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
_) -> [String] -> IO [String]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    String
_ -> do
      GlobalOpts
go' <- Bool -> GlobalOptsMonoid -> IO GlobalOpts
forall (m :: * -> *).
MonadIO m =>
Bool -> GlobalOptsMonoid -> m GlobalOpts
globalOptsFromMonoid Bool
False GlobalOptsMonoid
forall a. Monoid a => a
mempty
      let go :: GlobalOpts
go = GlobalOpts
go' { globalLogLevel :: LogLevel
globalLogLevel = Text -> LogLevel
LevelOther Text
"silent" }
      GlobalOpts -> RIO Runner [String] -> IO [String]
forall a. GlobalOpts -> RIO Runner a -> IO a
withRunnerGlobal GlobalOpts
go (RIO Runner [String] -> IO [String])
-> RIO Runner [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ ShouldReexec -> RIO Config [String] -> RIO Runner [String]
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
NoReexec (RIO Config [String] -> RIO Runner [String])
-> RIO Config [String] -> RIO Runner [String]
forall a b. (a -> b) -> a -> b
$ RIO EnvConfig [String] -> RIO Config [String]
forall a. RIO EnvConfig a -> RIO Config a
withDefaultEnvConfig (RIO EnvConfig [String] -> RIO Config [String])
-> RIO EnvConfig [String] -> RIO Config [String]
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 ((String -> RIO EnvConfig [String]) -> Completer)
-> (String -> RIO EnvConfig [String]) -> Completer
forall a b. (a -> b) -> a -> b
$ \String
input -> do
  Map PackageName ProjectPackage
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 -> Map PackageName ProjectPackage
smwProject (SMWanted -> Map PackageName ProjectPackage)
-> (BuildConfig -> SMWanted)
-> BuildConfig
-> Map PackageName ProjectPackage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildConfig -> SMWanted
bcSMWanted)
  Map PackageName (Set NamedComponent)
comps <- Map PackageName ProjectPackage
-> (ProjectPackage -> RIO EnvConfig (Set NamedComponent))
-> RIO EnvConfig (Map PackageName (Set NamedComponent))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Map PackageName ProjectPackage
packages ProjectPackage -> RIO EnvConfig (Set NamedComponent)
forall (m :: * -> *).
MonadIO m =>
ProjectPackage -> m (Set NamedComponent)
ppComponents
  [String] -> RIO EnvConfig [String]
forall a. a -> RIO EnvConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> RIO EnvConfig [String])
-> [String] -> RIO EnvConfig [String]
forall a b. (a -> b) -> a -> b
$
    ((PackageName, Set NamedComponent) -> [String])
-> [(PackageName, Set NamedComponent)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
      ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
input `isPrefixOf`) ([String] -> [String])
-> ((PackageName, Set NamedComponent) -> [String])
-> (PackageName, Set NamedComponent)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, Set NamedComponent) -> [String]
allComponentNames)
      (Map PackageName (Set NamedComponent)
-> [(PackageName, Set NamedComponent)]
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) =
    (NamedComponent -> String) -> [NamedComponent] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack (Text -> String)
-> (NamedComponent -> Text) -> NamedComponent -> String
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)

flagCompleter :: Completer
flagCompleter :: Completer
flagCompleter = (String -> RIO EnvConfig [String]) -> Completer
buildConfigCompleter ((String -> RIO EnvConfig [String]) -> Completer)
-> (String -> RIO EnvConfig [String]) -> Completer
forall a b. (a -> b) -> a -> b
$ \String
input -> do
  BuildConfig
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
  Map PackageName GenericPackageDescription
gpds <- Map PackageName ProjectPackage
-> (ProjectPackage -> RIO EnvConfig GenericPackageDescription)
-> RIO EnvConfig (Map PackageName GenericPackageDescription)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (SMWanted -> Map PackageName ProjectPackage
smwProject (SMWanted -> Map PackageName ProjectPackage)
-> SMWanted -> Map PackageName ProjectPackage
forall a b. (a -> b) -> a -> b
$ BuildConfig -> SMWanted
bcSMWanted BuildConfig
bconfig) ProjectPackage -> RIO EnvConfig GenericPackageDescription
forall (m :: * -> *).
MonadIO m =>
ProjectPackage -> m GenericPackageDescription
ppGPD
  let wildcardFlags :: [String]
wildcardFlags
        = [String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd
        ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ((PackageName, GenericPackageDescription) -> [String])
-> [(PackageName, GenericPackageDescription)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(PackageName
name, GenericPackageDescription
gpd) ->
            (PackageFlag -> String) -> [PackageFlag] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\PackageFlag
fl -> String
"*:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageName -> PackageFlag -> String
flagString PackageName
name PackageFlag
fl) (GenericPackageDescription -> [PackageFlag]
C.genPackageFlags GenericPackageDescription
gpd))
        ([(PackageName, GenericPackageDescription)] -> [String])
-> [(PackageName, GenericPackageDescription)] -> [String]
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 :: [String]
normalFlags
        = ((PackageName, GenericPackageDescription) -> [String])
-> [(PackageName, GenericPackageDescription)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(PackageName
name, GenericPackageDescription
gpd) ->
            (PackageFlag -> String) -> [PackageFlag] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\PackageFlag
fl -> PackageName -> String
packageNameString PackageName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageName -> PackageFlag -> String
flagString PackageName
name PackageFlag
fl)
                (GenericPackageDescription -> [PackageFlag]
C.genPackageFlags GenericPackageDescription
gpd))
        ([(PackageName, GenericPackageDescription)] -> [String])
-> [(PackageName, GenericPackageDescription)] -> [String]
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 -> PackageFlag -> String
flagString PackageName
name PackageFlag
fl =
        let flname :: String
flname = FlagName -> String
C.unFlagName (FlagName -> String) -> FlagName -> String
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
"") String -> String -> 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 -> Map PackageName (Map FlagName Bool)
forall a. Monoid a => a
mempty
          PCNoProject [PackageIdentifierRevision]
_ -> Map PackageName (Map FlagName Bool)
forall a. Monoid a => a
mempty
      flagEnabled :: PackageName -> PackageFlag -> Bool
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
  [String] -> RIO EnvConfig [String]
forall a. a -> RIO EnvConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> RIO EnvConfig [String])
-> [String] -> RIO EnvConfig [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
input `isPrefixOf`) ([String] -> [String]) -> [String] -> [String]
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 ((String -> RIO EnvConfig [String]) -> Completer)
-> (String -> RIO EnvConfig [String]) -> Completer
forall a b. (a -> b) -> a -> b
$ \String
input -> do
  Map PackageName ProjectPackage
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 -> Map PackageName ProjectPackage
smwProject (SMWanted -> Map PackageName ProjectPackage)
-> (BuildConfig -> SMWanted)
-> BuildConfig
-> Map PackageName ProjectPackage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildConfig -> SMWanted
bcSMWanted)
  Map PackageName GenericPackageDescription
gpds <- (PackageName
 -> ProjectPackage -> RIO EnvConfig GenericPackageDescription)
-> Map PackageName ProjectPackage
-> RIO EnvConfig (Map PackageName GenericPackageDescription)
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey ((ProjectPackage -> RIO EnvConfig GenericPackageDescription)
-> PackageName
-> ProjectPackage
-> RIO EnvConfig GenericPackageDescription
forall a b. a -> b -> a
const ProjectPackage -> RIO EnvConfig GenericPackageDescription
forall (m :: * -> *).
MonadIO m =>
ProjectPackage -> m GenericPackageDescription
ppGPD) Map PackageName ProjectPackage
packages
  [String] -> RIO EnvConfig [String]
forall a. a -> RIO EnvConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ([String] -> RIO EnvConfig [String])
-> [String] -> RIO EnvConfig [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
input `isPrefixOf`)
    ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd
    ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (GenericPackageDescription -> [String])
-> Map PackageName GenericPackageDescription -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
        (((UnqualComponentName, CondTree ConfVar [Dependency] Executable)
 -> String)
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] Executable)]
-> [String]
forall a b. (a -> b) -> [a] -> [b]
map (UnqualComponentName -> String
C.unUnqualComponentName (UnqualComponentName -> String)
-> ((UnqualComponentName, CondTree ConfVar [Dependency] Executable)
    -> UnqualComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Executable)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnqualComponentName, CondTree ConfVar [Dependency] Executable)
-> UnqualComponentName
forall a b. (a, b) -> a
fst) ([(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
 -> [String])
-> (GenericPackageDescription
    -> [(UnqualComponentName,
         CondTree ConfVar [Dependency] Executable)])
-> GenericPackageDescription
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] Executable)]
C.condExecutables)
        Map PackageName GenericPackageDescription
gpds