{-# 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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return ([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 (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
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
         (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
curArg String -> String -> Bool
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 ((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 (m :: * -> *) a. Monad m => a -> m a
return []
        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
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 (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 String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)
    ([String] -> [String]) -> [String] -> [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 (PackageName, Set NamedComponent) -> [String]
allComponentNames
    ([(PackageName, Set NamedComponent)] -> [String])
-> [(PackageName, Set NamedComponent)] -> [String]
forall a b. (a -> b) -> a -> b
$ 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
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) ->
                (Flag -> String) -> [Flag] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\Flag
fl -> String
"*:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageName -> Flag -> String
flagString PackageName
name Flag
fl) (GenericPackageDescription -> [Flag]
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) ->
                (Flag -> String) -> [Flag] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\Flag
fl -> PackageName -> String
packageNameString PackageName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageName -> Flag -> String
flagString PackageName
name Flag
fl)
                    (GenericPackageDescription -> [Flag]
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 -> Flag -> String
flagString PackageName
name Flag
fl =
            let flname :: String
flname = FlagName -> String
C.unFlagName (FlagName -> String) -> FlagName -> String
forall a b. (a -> b) -> a -> b
$ Flag -> FlagName
C.flagName Flag
fl
             in (if PackageName -> Flag -> Bool
flagEnabled PackageName
name Flag
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 -> Flag -> Bool
flagEnabled PackageName
name Flag
fl =
            Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe (Flag -> Bool
C.flagDefault Flag
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 (Flag -> FlagName
C.flagName Flag
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 (m :: * -> *) a. Monad m => a -> m a
return ([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 String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`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
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 (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 String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`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
        (\GenericPackageDescription
gpd -> ((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)
          (GenericPackageDescription
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] Executable)]
C.condExecutables GenericPackageDescription
gpd)
        )
        Map PackageName GenericPackageDescription
gpds