{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# 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.Config (getLocalPackages)
import           Stack.DefaultColorWhen (defaultColorWhen)
import           Stack.Options.GlobalParser (globalOptsFromMonoid)
import           Stack.Runners (loadConfigWithOpts)
import           Stack.Prelude hiding (lift)
import           Stack.Setup
import           Stack.Types.Config
import           Stack.Types.FlagName
import           Stack.Types.NamedComponent
import           Stack.Types.PackageName
import           System.Process (readProcess)
import           Language.Haskell.TH.Syntax (runIO, lift)

ghcOptsCompleter :: Completer
ghcOptsCompleter = mkCompleter $ \inputRaw -> return $
    let input = unescapeBashArg inputRaw
        (curArgReversed, otherArgsReversed) = break isSpace (reverse input)
        curArg = reverse curArgReversed
        otherArgs = reverse otherArgsReversed
     in if null curArg then [] else
         map (otherArgs ++) $
         filter (curArg `isPrefixOf`)
                -- Technically, we should be consulting the user's current ghc,
                -- but that would require loading up a BuildConfig.
                $(runIO (readProcess "ghc" ["--show-options"] "") >>= lift . lines)

-- TODO: Ideally this would pay attention to --stack-yaml, may require
-- changes to optparse-applicative.

buildConfigCompleter
    :: (String -> RIO EnvConfig [String])
    -> Completer
buildConfigCompleter inner = mkCompleter $ \inputRaw -> do
    let input = unescapeBashArg inputRaw
    case input of
        -- If it looks like a flag, skip this more costly completion.
        ('-': _) -> return []
        _ -> do
            defColorWhen <- liftIO defaultColorWhen
            let go = (globalOptsFromMonoid False defColorWhen mempty)
                    { globalLogLevel = LevelOther "silent" }
            loadConfigWithOpts go $ \lc -> do
              bconfig <- liftIO $ lcLoadBuildConfig lc (globalCompiler go)
              envConfig <- runRIO bconfig (setupEnv Nothing)
              runRIO envConfig (inner input)

targetCompleter :: Completer
targetCompleter = buildConfigCompleter $ \input ->
      filter (input `isPrefixOf`)
    . concatMap allComponentNames
    . Map.toList
    . lpProject
  <$> getLocalPackages
  where
    allComponentNames (name, lpv) =
        map (T.unpack . renderPkgComponent . (name,)) (Set.toList (lpvComponents lpv))

flagCompleter :: Completer
flagCompleter = buildConfigCompleter $ \input -> do
    lpvs <- fmap lpProject getLocalPackages
    bconfig <- view buildConfigL
    let wildcardFlags
            = nubOrd
            $ concatMap (\(name, lpv) ->
                map (\fl -> "*:" ++ flagString name fl) (C.genPackageFlags (lpvGPD lpv)))
            $ Map.toList lpvs
        normalFlags
            = concatMap (\(name, lpv) ->
                map (\fl -> packageNameString name ++ ":" ++ flagString name fl)
                    (C.genPackageFlags (lpvGPD lpv)))
            $ Map.toList lpvs
        flagString name fl =
            let flname = C.unFlagName $ C.flagName fl
             in (if flagEnabled name fl then "-" else "") ++ flname
        flagEnabled name fl =
            fromMaybe (C.flagDefault fl) $
            Map.lookup (fromCabalFlagName (C.flagName fl)) $
            Map.findWithDefault Map.empty name (bcFlags bconfig)
    return $ filter (input `isPrefixOf`) $
        case input of
            ('*' : ':' : _) -> wildcardFlags
            ('*' : _) -> wildcardFlags
            _ -> normalFlags

projectExeCompleter :: Completer
projectExeCompleter = buildConfigCompleter $ \input ->
      filter (input `isPrefixOf`)
    . nubOrd
    . concatMap
        (\(_, lpv) -> map
          (C.unUnqualComponentName . fst)
          (C.condExecutables (lpvGPD lpv))
        )
    . Map.toList
    . lpProject
  <$> getLocalPackages