{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} module OptEnvConf.Completion ( generateBashCompletionScript, bashCompletionScript, generateZshCompletionScript, zshCompletionScript, generateFishCompletionScript, fishCompletionScript, runCompletionQuery, pureCompletionQuery, Completion (..), ) where import Control.Monad.State import Data.List import qualified Data.List.NonEmpty as NE import Data.Maybe import OptEnvConf.Args as Args import OptEnvConf.Casing import OptEnvConf.Parser import OptEnvConf.Setting import Path generateBashCompletionScript :: Path Abs File -> String -> IO () generateBashCompletionScript progPath progname = putStrLn $ bashCompletionScript progPath progname -- | Generated bash shell completion script bashCompletionScript :: Path Abs File -> String -> String bashCompletionScript progPath progname = let functionName = progNameToFunctionName progname in unlines [ functionName ++ "()", "{", " local CMDLINE", " local IFS=$'\\n'", " CMDLINE=(--query-opt-env-conf-completion)", " CMDLINE+=(--completion-index $COMP_CWORD)", "", " for arg in ${COMP_WORDS[@]}; do", " CMDLINE=(${CMDLINE[@]} --completion-word $arg)", " done", "", " COMPREPLY=( $(" ++ fromAbsFile progPath ++ " \"${CMDLINE[@]}\") )", " echo \"${COMPREPLY[@]}\" > hm.log", "}", "", "complete -o filenames -F " ++ functionName ++ " " ++ progname ] generateZshCompletionScript :: Path Abs File -> String -> IO () generateZshCompletionScript progPath progname = putStrLn $ zshCompletionScript progPath progname -- | Generated zsh shell completion script zshCompletionScript :: Path Abs File -> String -> String zshCompletionScript progPath progname = unlines [ "#compdef " ++ progname, "", "local request", "local completions", "local word", "local index=$((CURRENT - 1))", "", "request=(--query-opt-env-conf-completion --completion-enriched --completion-index $index)", "for arg in ${words[@]}; do", " request=(${request[@]} --completion-word $arg)", "done", "", "IFS=$'\\n' completions=($( " ++ fromAbsFile progPath ++ " \"${request[@]}\" ))", "", "for word in $completions; do", " local -a parts", "", " # Split the line at a tab if there is one.", " IFS=$'\\t' parts=($( echo $word ))", "", " if [[ -n $parts[2] ]]; then", " if [[ $word[1] == \"-\" ]]; then", " local desc=(\"$parts[1] ($parts[2])\")", " compadd -d desc -- $parts[1]", " else", " local desc=($(print -f \"%-019s -- %s\" $parts[1] $parts[2]))", " compadd -l -d desc -- $parts[1]", " fi", " else", " compadd -f -- $word", " fi", "done" ] generateFishCompletionScript :: Path Abs File -> String -> IO () generateFishCompletionScript progPath progname = putStrLn $ fishCompletionScript progPath progname -- | Generated fish shell completion script fishCompletionScript :: Path Abs File -> String -> String fishCompletionScript progPath progname = let functionName = progNameToFunctionName progname in unlines [ " function " ++ functionName, " set -l cl (commandline --tokenize --current-process)", " # Hack around fish issue #3934", " set -l cn (commandline --tokenize --cut-at-cursor --current-process)", " set -l cn (count $cn)", " set -l tmpline --query-opt-env-conf-completion --completion-enriched --completion-index $cn", " for arg in $cl", " set tmpline $tmpline --completion-word $arg", " end", " for opt in (" ++ fromAbsFile progPath ++ " $tmpline)", " if test -d $opt", " echo -E \"$opt/\"", " else", " echo -E \"$opt\"", " end", " end", "end", "", "complete --no-files --command " ++ fromAbsFile progPath ++ " --arguments '(" ++ functionName ++ ")'" ] -- This should be a name that a normal user would never want to define themselves. progNameToFunctionName :: String -> String progNameToFunctionName progname = "_opt_env_conf_completion_" ++ toShellFunctionCase progname runCompletionQuery :: Parser a -> -- | Enriched Bool -> -- Where completion is invoked (inbetween arguments) Int -> -- Provider arguments [String] -> IO () runCompletionQuery parser enriched index ws = do let completions = pureCompletionQuery parser index ws if enriched then putStr $ unlines $ map ( \Completion {..} -> case completionDescription of Nothing -> completionSuggestion Just d -> completionSuggestion <> "\t" <> d ) completions else putStr $ unlines $ map completionSuggestion completions pure () selectArgs :: Int -> [String] -> (Args, Maybe String) selectArgs _ix args = let selectedArgs = args -- take ix args in (parseArgs selectedArgs, NE.last <$> NE.nonEmpty selectedArgs) data Completion = Completion { -- | Completion completionSuggestion :: String, -- | Description completionDescription :: !(Maybe String) } deriving (Show, Eq) pureCompletionQuery :: Parser a -> Int -> [String] -> [Completion] pureCompletionQuery parser ix args = -- TODO use the index properly (?) fromMaybe [] $ evalState (go parser) selectedArgs where (selectedArgs, mCursorArg) = selectArgs ix args goCommand :: Command a -> State Args (Maybe [Completion]) goCommand = go . commandParser -- TODO complete with the command -- Nothing means "this branch was not valid" -- Just means "no completions" go :: Parser a -> State Args (Maybe [Completion]) go = \case ParserPure _ -> pure $ Just [] ParserAp p1 p2 -> do c1 <- go p1 case c1 of Just [] -> go p2 Just ss -> pure $ Just ss Nothing -> pure $ Just [] ParserAlt p1 p2 -> do s1s <- go p1 s2s <- go p2 pure $ (++) <$> s1s <*> s2s ParserSelect p1 p2 -> do c1 <- go p1 case c1 of Just [] -> go p2 Just ss -> pure $ Just ss Nothing -> pure $ Just [] ParserEmpty _ -> pure Nothing ParserMany p -> do mR <- go p case mR of Nothing -> pure Nothing Just os -> fmap (os ++) <$> go p ParserAllOrNothing _ p -> go p ParserCheck _ _ _ p -> go p ParserCommands _ cs -> do -- Don't re-use the state accross commands Just . concat . catMaybes <$> mapM goCommand cs ParserWithConfig _ p -> go p ParserSetting _ Setting {..} -> if settingHidden then pure $ Just [] else do case mCursorArg of Nothing -> pure $ Just [] Just arg -> do let suggestions = filter (arg `isPrefixOf`) (map Args.renderDashed settingDasheds) let completions = map ( \completionSuggestion -> let completionDescription = settingHelp in Completion {..} ) suggestions pure $ Just completions -- ParserAp p1 p2 -> do -- s1s <- go p1 |> go p2