{-# LANGUAGE CPP #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Extra functions for optparse-applicative.

module Options.Applicative.Builder.Extra
  (boolFlags
  ,boolFlagsNoDefault
  ,firstBoolFlagsNoDefault
  ,firstBoolFlagsTrue
  ,firstBoolFlagsFalse
  ,enableDisableFlags
  ,enableDisableFlagsNoDefault
  ,extraHelpOption
  ,execExtraHelp
  ,textOption
  ,textArgument
  ,optionalFirst
  ,optionalFirstTrue
  ,optionalFirstFalse
  ,absFileOption
  ,relFileOption
  ,absDirOption
  ,relDirOption
  ,eitherReader'
  ,fileCompleter
  ,fileExtCompleter
  ,dirCompleter
  ,PathCompleterOpts(..)
  ,defaultPathCompleterOpts
  ,pathCompleterWith
  ,unescapeBashArg
  ,showHelpText
  ) where

import Data.List (isPrefixOf)
import Data.Maybe
import Data.Monoid hiding ((<>))
import qualified Data.Text as T
import Options.Applicative
import Options.Applicative.Types (readerAsk)
import Path hiding ((</>))
import Stack.Prelude
import System.Directory (getCurrentDirectory, getDirectoryContents, doesDirectoryExist)
import System.Environment (withArgs)
import System.FilePath (takeBaseName, (</>), splitFileName, isRelative, takeExtension)

-- | Enable/disable flags for a 'Bool'.
boolFlags :: Bool                 -- ^ Default value
          -> String               -- ^ Flag name
          -> String               -- ^ Help suffix
          -> Mod FlagFields Bool
          -> Parser Bool
boolFlags :: Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool
boolFlags Bool
defaultValue String
name String
helpSuffix =
  Bool
-> Bool
-> Bool
-> String
-> String
-> Mod FlagFields Bool
-> Parser Bool
forall a.
a -> a -> a -> String -> String -> Mod FlagFields a -> Parser a
enableDisableFlags Bool
defaultValue Bool
True Bool
False String
name (String -> Mod FlagFields Bool -> Parser Bool)
-> String -> Mod FlagFields Bool -> Parser Bool
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
helpSuffix
    , String
" (default: "
    , if Bool
defaultValue then String
"enabled" else String
"disabled"
    , String
")"
    ]

-- | Enable/disable flags for a 'Bool', without a default case (to allow chaining with '<|>').
boolFlagsNoDefault :: String               -- ^ Flag name
                   -> String               -- ^ Help suffix
                   -> Mod FlagFields Bool
                   -> Parser Bool
boolFlagsNoDefault :: String -> String -> Mod FlagFields Bool -> Parser Bool
boolFlagsNoDefault = Bool
-> Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool
forall a.
a -> a -> String -> String -> Mod FlagFields a -> Parser a
enableDisableFlagsNoDefault Bool
True Bool
False

-- | Flag with no default of True or False
firstBoolFlagsNoDefault :: String -> String -> Mod FlagFields (Maybe Bool) -> Parser (First Bool)
firstBoolFlagsNoDefault :: String
-> String -> Mod FlagFields (Maybe Bool) -> Parser (First Bool)
firstBoolFlagsNoDefault String
name String
helpSuffix Mod FlagFields (Maybe Bool)
mod' =
  Maybe Bool -> First Bool
forall a. Maybe a -> First a
First (Maybe Bool -> First Bool)
-> Parser (Maybe Bool) -> Parser (First Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> String
-> String
-> Mod FlagFields (Maybe Bool)
-> Parser (Maybe Bool)
forall a.
a -> a -> a -> String -> String -> Mod FlagFields a -> Parser a
enableDisableFlags Maybe Bool
forall a. Maybe a
Nothing (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False)
  String
name String
helpSuffix Mod FlagFields (Maybe Bool)
mod'

-- | Flag with a Semigroup instance and a default of True
firstBoolFlagsTrue :: String -> String -> Mod FlagFields FirstTrue -> Parser FirstTrue
firstBoolFlagsTrue :: String -> String -> Mod FlagFields FirstTrue -> Parser FirstTrue
firstBoolFlagsTrue String
name String
helpSuffix =
  FirstTrue
-> FirstTrue
-> FirstTrue
-> String
-> String
-> Mod FlagFields FirstTrue
-> Parser FirstTrue
forall a.
a -> a -> a -> String -> String -> Mod FlagFields a -> Parser a
enableDisableFlags FirstTrue
forall a. Monoid a => a
mempty (Maybe Bool -> FirstTrue
FirstTrue (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)) (Maybe Bool -> FirstTrue
FirstTrue (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False))
  String
name (String -> Mod FlagFields FirstTrue -> Parser FirstTrue)
-> String -> Mod FlagFields FirstTrue -> Parser FirstTrue
forall a b. (a -> b) -> a -> b
$ String
helpSuffix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (default: enabled)"

-- | Flag with a Semigroup instance and a default of False
firstBoolFlagsFalse :: String -> String -> Mod FlagFields FirstFalse -> Parser FirstFalse
firstBoolFlagsFalse :: String -> String -> Mod FlagFields FirstFalse -> Parser FirstFalse
firstBoolFlagsFalse String
name String
helpSuffix =
  FirstFalse
-> FirstFalse
-> FirstFalse
-> String
-> String
-> Mod FlagFields FirstFalse
-> Parser FirstFalse
forall a.
a -> a -> a -> String -> String -> Mod FlagFields a -> Parser a
enableDisableFlags FirstFalse
forall a. Monoid a => a
mempty (Maybe Bool -> FirstFalse
FirstFalse (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)) (Maybe Bool -> FirstFalse
FirstFalse (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False))
  String
name (String -> Mod FlagFields FirstFalse -> Parser FirstFalse)
-> String -> Mod FlagFields FirstFalse -> Parser FirstFalse
forall a b. (a -> b) -> a -> b
$ String
helpSuffix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (default: disabled)"

-- | Enable/disable flags for any type.
enableDisableFlags :: a                 -- ^ Default value
                   -> a                 -- ^ Enabled value
                   -> a                 -- ^ Disabled value
                   -> String            -- ^ Name
                   -> String            -- ^ Help suffix
                   -> Mod FlagFields a
                   -> Parser a
enableDisableFlags :: a -> a -> a -> String -> String -> Mod FlagFields a -> Parser a
enableDisableFlags a
defaultValue a
enabledValue a
disabledValue String
name String
helpSuffix Mod FlagFields a
mods =
  a -> a -> String -> String -> Mod FlagFields a -> Parser a
forall a.
a -> a -> String -> String -> Mod FlagFields a -> Parser a
enableDisableFlagsNoDefault a
enabledValue a
disabledValue String
name String
helpSuffix Mod FlagFields a
mods Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
defaultValue

-- | Enable/disable flags for any type, without a default (to allow chaining with '<|>')
enableDisableFlagsNoDefault :: a                 -- ^ Enabled value
                            -> a                 -- ^ Disabled value
                            -> String            -- ^ Name
                            -> String            -- ^ Help suffix
                            -> Mod FlagFields a
                            -> Parser a
enableDisableFlagsNoDefault :: a -> a -> String -> String -> Mod FlagFields a -> Parser a
enableDisableFlagsNoDefault a
enabledValue a
disabledValue String
name String
helpSuffix Mod FlagFields a
mods =
  [a] -> a
forall p. [p] -> p
last ([a] -> a) -> Parser [a] -> Parser a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some
      ((a -> Mod FlagFields a -> Parser a
forall a. a -> Mod FlagFields a -> Parser a
flag'
           a
enabledValue
           (Mod FlagFields a
forall (f :: * -> *) a. Mod f a
hidden Mod FlagFields a -> Mod FlagFields a -> Mod FlagFields a
forall a. Semigroup a => a -> a -> a
<>
            Mod FlagFields a
forall (f :: * -> *) a. Mod f a
internal Mod FlagFields a -> Mod FlagFields a -> Mod FlagFields a
forall a. Semigroup a => a -> a -> a
<>
            String -> Mod FlagFields a
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
name Mod FlagFields a -> Mod FlagFields a -> Mod FlagFields a
forall a. Semigroup a => a -> a -> a
<>
            String -> Mod FlagFields a
forall (f :: * -> *) a. String -> Mod f a
help String
helpSuffix Mod FlagFields a -> Mod FlagFields a -> Mod FlagFields a
forall a. Semigroup a => a -> a -> a
<>
            Mod FlagFields a
mods) Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
       a -> Mod FlagFields a -> Parser a
forall a. a -> Mod FlagFields a -> Parser a
flag'
           a
disabledValue
           (Mod FlagFields a
forall (f :: * -> *) a. Mod f a
hidden Mod FlagFields a -> Mod FlagFields a -> Mod FlagFields a
forall a. Semigroup a => a -> a -> a
<>
            Mod FlagFields a
forall (f :: * -> *) a. Mod f a
internal Mod FlagFields a -> Mod FlagFields a -> Mod FlagFields a
forall a. Semigroup a => a -> a -> a
<>
            String -> Mod FlagFields a
forall (f :: * -> *) a. HasName f => String -> Mod f a
long (String
"no-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name) Mod FlagFields a -> Mod FlagFields a -> Mod FlagFields a
forall a. Semigroup a => a -> a -> a
<>
            String -> Mod FlagFields a
forall (f :: * -> *) a. String -> Mod f a
help String
helpSuffix Mod FlagFields a -> Mod FlagFields a -> Mod FlagFields a
forall a. Semigroup a => a -> a -> a
<>
            Mod FlagFields a
mods)) Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
       a -> Mod FlagFields a -> Parser a
forall a. a -> Mod FlagFields a -> Parser a
flag'
           a
disabledValue
           (String -> Mod FlagFields a
forall (f :: * -> *) a. HasName f => String -> Mod f a
long (String
"[no-]" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name) Mod FlagFields a -> Mod FlagFields a -> Mod FlagFields a
forall a. Semigroup a => a -> a -> a
<>
            String -> Mod FlagFields a
forall (f :: * -> *) a. String -> Mod f a
help (String
"Enable/disable " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
helpSuffix) Mod FlagFields a -> Mod FlagFields a -> Mod FlagFields a
forall a. Semigroup a => a -> a -> a
<>
            Mod FlagFields a
mods))
  where
    last :: [p] -> p
last [p]
xs =
      case [p] -> [p]
forall a. [a] -> [a]
reverse [p]
xs of
        [] -> StringException -> p
forall e a. Exception e => e -> a
impureThrow (StringException -> p) -> StringException -> p
forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> StringException
String -> StringException
stringException String
"enableDisableFlagsNoDefault.last"
        p
x:[p]
_ -> p
x

-- | Show an extra help option (e.g. @--docker-help@ shows help for all @--docker*@ args).
--
-- To actually have that help appear, use 'execExtraHelp' before executing the main parser.
extraHelpOption :: Bool             -- ^ Hide from the brief description?
                -> String           -- ^ Program name, e.g. @"stack"@
                -> String           -- ^ Option glob expression, e.g. @"docker*"@
                -> String           -- ^ Help option name, e.g. @"docker-help"@
                -> Parser (a -> a)
extraHelpOption :: Bool -> String -> String -> String -> Parser (a -> a)
extraHelpOption Bool
hide String
progName String
fakeName String
helpName =
    String
-> Mod OptionFields ((a -> a) -> a -> a)
-> Parser ((a -> a) -> a -> a)
forall a. String -> Mod OptionFields (a -> a) -> Parser (a -> a)
infoOption (String
optDesc' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".") (String -> Mod OptionFields ((a -> a) -> a -> a)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
helpName Mod OptionFields ((a -> a) -> a -> a)
-> Mod OptionFields ((a -> a) -> a -> a)
-> Mod OptionFields ((a -> a) -> a -> a)
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields ((a -> a) -> a -> a)
forall (f :: * -> *) a. Mod f a
hidden Mod OptionFields ((a -> a) -> a -> a)
-> Mod OptionFields ((a -> a) -> a -> a)
-> Mod OptionFields ((a -> a) -> a -> a)
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields ((a -> a) -> a -> a)
forall (f :: * -> *) a. Mod f a
internal) Parser ((a -> a) -> a -> a) -> Parser (a -> a) -> Parser (a -> a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    String -> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a. String -> Mod OptionFields (a -> a) -> Parser (a -> a)
infoOption (String
optDesc' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".") (String -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
fakeName Mod OptionFields (a -> a)
-> Mod OptionFields (a -> a) -> Mod OptionFields (a -> a)
forall a. Semigroup a => a -> a -> a
<>
                                  String -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. String -> Mod f a
help String
optDesc' Mod OptionFields (a -> a)
-> Mod OptionFields (a -> a) -> Mod OptionFields (a -> a)
forall a. Semigroup a => a -> a -> a
<>
                                  (if Bool
hide then Mod OptionFields (a -> a)
forall (f :: * -> *) a. Mod f a
hidden Mod OptionFields (a -> a)
-> Mod OptionFields (a -> a) -> Mod OptionFields (a -> a)
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields (a -> a)
forall (f :: * -> *) a. Mod f a
internal else Mod OptionFields (a -> a)
forall a. Monoid a => a
idm))
  where optDesc' :: String
optDesc' = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"Run '", String -> String
takeBaseName String
progName, String
" --", String
helpName, String
"' for details"]

-- | Display extra help if extra help option passed in arguments.
--
-- Since optparse-applicative doesn't allow an arbitrary IO action for an 'abortOption', this
-- was the best way I found that doesn't require manually formatting the help.
execExtraHelp :: [String]  -- ^ Command line arguments
              -> String    -- ^ Extra help option name, e.g. @"docker-help"@
              -> Parser a  -- ^ Option parser for the relevant command
              -> String    -- ^ Option description
              -> IO ()
execExtraHelp :: [String] -> String -> Parser a -> String -> IO ()
execExtraHelp [String]
args String
helpOpt Parser a
parser String
pd =
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([String]
args [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
== [String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
helpOpt]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      [String] -> IO () -> IO ()
forall a. [String] -> IO a -> IO a
withArgs [String
"--help"] (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        (a, [String])
_ <- ParserInfo (a, [String]) -> IO (a, [String])
forall a. ParserInfo a -> IO a
execParser (Parser (a, [String])
-> InfoMod (a, [String]) -> ParserInfo (a, [String])
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser ((a, [String]) -> (a, [String]))
forall a. Parser (a -> a)
hiddenHelper Parser ((a, [String]) -> (a, [String]))
-> Parser (a, [String]) -> Parser (a, [String])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
                               ((,) (a -> [String] -> (a, [String]))
-> Parser a -> Parser ([String] -> (a, [String]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                Parser a
parser Parser ([String] -> (a, [String]))
-> Parser [String] -> Parser (a, [String])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
                                Parser String -> Parser [String]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (Mod ArgumentFields String -> Parser String
forall s. IsString s => Mod ArgumentFields s -> Parser s
strArgument (String -> Mod ArgumentFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"OTHER ARGUMENTS") :: Parser String)))
                        (InfoMod (a, [String])
forall a. InfoMod a
fullDesc InfoMod (a, [String])
-> InfoMod (a, [String]) -> InfoMod (a, [String])
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod (a, [String])
forall a. String -> InfoMod a
progDesc String
pd))
        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where hiddenHelper :: Parser (a -> a)
hiddenHelper = ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a.
ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a)
abortOption ParseError
showHelpText (String -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"help" Mod OptionFields (a -> a)
-> Mod OptionFields (a -> a) -> Mod OptionFields (a -> a)
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields (a -> a)
forall (f :: * -> *) a. Mod f a
hidden Mod OptionFields (a -> a)
-> Mod OptionFields (a -> a) -> Mod OptionFields (a -> a)
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields (a -> a)
forall (f :: * -> *) a. Mod f a
internal)

-- | 'option', specialized to 'Text'.
textOption :: Mod OptionFields Text -> Parser Text
textOption :: Mod OptionFields Text -> Parser Text
textOption = ReadM Text -> Mod OptionFields Text -> Parser Text
forall a. ReadM a -> Mod OptionFields a -> Parser a
option (String -> Text
T.pack (String -> Text) -> ReadM String -> ReadM Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM String
readerAsk)

-- | 'argument', specialized to 'Text'.
textArgument :: Mod ArgumentFields Text -> Parser Text
textArgument :: Mod ArgumentFields Text -> Parser Text
textArgument = ReadM Text -> Mod ArgumentFields Text -> Parser Text
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument (String -> Text
T.pack (String -> Text) -> ReadM String -> ReadM Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM String
readerAsk)

-- | Like 'optional', but returning a 'First'.
optionalFirst :: Alternative f => f a -> f (First a)
optionalFirst :: f a -> f (First a)
optionalFirst = (Maybe a -> First a) -> f (Maybe a) -> f (First a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe a -> First a
forall a. Maybe a -> First a
First (f (Maybe a) -> f (First a))
-> (f a -> f (Maybe a)) -> f a -> f (First a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> f (Maybe a)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional

-- | Like 'optional', but returning a 'FirstTrue'.
optionalFirstTrue :: Alternative f => f Bool -> f FirstTrue
optionalFirstTrue :: f Bool -> f FirstTrue
optionalFirstTrue = (Maybe Bool -> FirstTrue) -> f (Maybe Bool) -> f FirstTrue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe Bool -> FirstTrue
FirstTrue (f (Maybe Bool) -> f FirstTrue)
-> (f Bool -> f (Maybe Bool)) -> f Bool -> f FirstTrue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f Bool -> f (Maybe Bool)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional

-- | Like 'optional', but returning a 'FirstFalse'.
optionalFirstFalse :: Alternative f => f Bool -> f FirstFalse
optionalFirstFalse :: f Bool -> f FirstFalse
optionalFirstFalse = (Maybe Bool -> FirstFalse) -> f (Maybe Bool) -> f FirstFalse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe Bool -> FirstFalse
FirstFalse (f (Maybe Bool) -> f FirstFalse)
-> (f Bool -> f (Maybe Bool)) -> f Bool -> f FirstFalse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f Bool -> f (Maybe Bool)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional

absFileOption :: Mod OptionFields (Path Abs File) -> Parser (Path Abs File)
absFileOption :: Mod OptionFields (Path Abs File) -> Parser (Path Abs File)
absFileOption Mod OptionFields (Path Abs File)
mods = ReadM (Path Abs File)
-> Mod OptionFields (Path Abs File) -> Parser (Path Abs File)
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ((String -> Either SomeException (Path Abs File))
-> ReadM (Path Abs File)
forall e a. Show e => (String -> Either e a) -> ReadM a
eitherReader' String -> Either SomeException (Path Abs File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile) (Mod OptionFields (Path Abs File) -> Parser (Path Abs File))
-> Mod OptionFields (Path Abs File) -> Parser (Path Abs File)
forall a b. (a -> b) -> a -> b
$
  Completer -> Mod OptionFields (Path Abs File)
forall (f :: * -> *) a. HasCompleter f => Completer -> Mod f a
completer (PathCompleterOpts -> Completer
pathCompleterWith PathCompleterOpts
defaultPathCompleterOpts { pcoRelative :: Bool
pcoRelative = Bool
False }) Mod OptionFields (Path Abs File)
-> Mod OptionFields (Path Abs File)
-> Mod OptionFields (Path Abs File)
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields (Path Abs File)
mods

relFileOption :: Mod OptionFields (Path Rel File) -> Parser (Path Rel File)
relFileOption :: Mod OptionFields (Path Rel File) -> Parser (Path Rel File)
relFileOption Mod OptionFields (Path Rel File)
mods = ReadM (Path Rel File)
-> Mod OptionFields (Path Rel File) -> Parser (Path Rel File)
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ((String -> Either SomeException (Path Rel File))
-> ReadM (Path Rel File)
forall e a. Show e => (String -> Either e a) -> ReadM a
eitherReader' String -> Either SomeException (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile) (Mod OptionFields (Path Rel File) -> Parser (Path Rel File))
-> Mod OptionFields (Path Rel File) -> Parser (Path Rel File)
forall a b. (a -> b) -> a -> b
$
  Completer -> Mod OptionFields (Path Rel File)
forall (f :: * -> *) a. HasCompleter f => Completer -> Mod f a
completer (PathCompleterOpts -> Completer
pathCompleterWith PathCompleterOpts
defaultPathCompleterOpts { pcoAbsolute :: Bool
pcoAbsolute = Bool
False }) Mod OptionFields (Path Rel File)
-> Mod OptionFields (Path Rel File)
-> Mod OptionFields (Path Rel File)
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields (Path Rel File)
mods

absDirOption :: Mod OptionFields (Path Abs Dir) -> Parser (Path Abs Dir)
absDirOption :: Mod OptionFields (Path Abs Dir) -> Parser (Path Abs Dir)
absDirOption Mod OptionFields (Path Abs Dir)
mods = ReadM (Path Abs Dir)
-> Mod OptionFields (Path Abs Dir) -> Parser (Path Abs Dir)
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ((String -> Either SomeException (Path Abs Dir))
-> ReadM (Path Abs Dir)
forall e a. Show e => (String -> Either e a) -> ReadM a
eitherReader' String -> Either SomeException (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir) (Mod OptionFields (Path Abs Dir) -> Parser (Path Abs Dir))
-> Mod OptionFields (Path Abs Dir) -> Parser (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$
  Completer -> Mod OptionFields (Path Abs Dir)
forall (f :: * -> *) a. HasCompleter f => Completer -> Mod f a
completer (PathCompleterOpts -> Completer
pathCompleterWith PathCompleterOpts
defaultPathCompleterOpts { pcoRelative :: Bool
pcoRelative = Bool
False, pcoFileFilter :: String -> Bool
pcoFileFilter = Bool -> String -> Bool
forall a b. a -> b -> a
const Bool
False }) Mod OptionFields (Path Abs Dir)
-> Mod OptionFields (Path Abs Dir)
-> Mod OptionFields (Path Abs Dir)
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields (Path Abs Dir)
mods

relDirOption :: Mod OptionFields (Path Rel Dir) -> Parser (Path Rel Dir)
relDirOption :: Mod OptionFields (Path Rel Dir) -> Parser (Path Rel Dir)
relDirOption Mod OptionFields (Path Rel Dir)
mods = ReadM (Path Rel Dir)
-> Mod OptionFields (Path Rel Dir) -> Parser (Path Rel Dir)
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ((String -> Either SomeException (Path Rel Dir))
-> ReadM (Path Rel Dir)
forall e a. Show e => (String -> Either e a) -> ReadM a
eitherReader' String -> Either SomeException (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir) (Mod OptionFields (Path Rel Dir) -> Parser (Path Rel Dir))
-> Mod OptionFields (Path Rel Dir) -> Parser (Path Rel Dir)
forall a b. (a -> b) -> a -> b
$
  Completer -> Mod OptionFields (Path Rel Dir)
forall (f :: * -> *) a. HasCompleter f => Completer -> Mod f a
completer (PathCompleterOpts -> Completer
pathCompleterWith PathCompleterOpts
defaultPathCompleterOpts { pcoAbsolute :: Bool
pcoAbsolute = Bool
False, pcoFileFilter :: String -> Bool
pcoFileFilter = Bool -> String -> Bool
forall a b. a -> b -> a
const Bool
False }) Mod OptionFields (Path Rel Dir)
-> Mod OptionFields (Path Rel Dir)
-> Mod OptionFields (Path Rel Dir)
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields (Path Rel Dir)
mods

-- | Like 'eitherReader', but accepting any @'Show' e@ on the 'Left'.
eitherReader' :: Show e => (String -> Either e a) -> ReadM a
eitherReader' :: (String -> Either e a) -> ReadM a
eitherReader' String -> Either e a
f = (String -> Either String a) -> ReadM a
forall a. (String -> Either String a) -> ReadM a
eitherReader ((e -> String) -> Either e a -> Either String a
forall a1 a2 b. (a1 -> a2) -> Either a1 b -> Either a2 b
mapLeft e -> String
forall a. Show a => a -> String
show (Either e a -> Either String a)
-> (String -> Either e a) -> String -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either e a
f)

data PathCompleterOpts = PathCompleterOpts
    { PathCompleterOpts -> Bool
pcoAbsolute :: Bool
    , PathCompleterOpts -> Bool
pcoRelative :: Bool
    , PathCompleterOpts -> Maybe String
pcoRootDir :: Maybe FilePath
    , PathCompleterOpts -> String -> Bool
pcoFileFilter :: FilePath -> Bool
    , PathCompleterOpts -> String -> Bool
pcoDirFilter :: FilePath -> Bool
    }

defaultPathCompleterOpts :: PathCompleterOpts
defaultPathCompleterOpts :: PathCompleterOpts
defaultPathCompleterOpts = PathCompleterOpts :: Bool
-> Bool
-> Maybe String
-> (String -> Bool)
-> (String -> Bool)
-> PathCompleterOpts
PathCompleterOpts
    { pcoAbsolute :: Bool
pcoAbsolute = Bool
True
    , pcoRelative :: Bool
pcoRelative = Bool
True
    , pcoRootDir :: Maybe String
pcoRootDir = Maybe String
forall a. Maybe a
Nothing
    , pcoFileFilter :: String -> Bool
pcoFileFilter = Bool -> String -> Bool
forall a b. a -> b -> a
const Bool
True
    , pcoDirFilter :: String -> Bool
pcoDirFilter = Bool -> String -> Bool
forall a b. a -> b -> a
const Bool
True
    }

fileCompleter :: Completer
fileCompleter :: Completer
fileCompleter = PathCompleterOpts -> Completer
pathCompleterWith PathCompleterOpts
defaultPathCompleterOpts

fileExtCompleter :: [String] -> Completer
fileExtCompleter :: [String] -> Completer
fileExtCompleter [String]
exts = PathCompleterOpts -> Completer
pathCompleterWith PathCompleterOpts
defaultPathCompleterOpts { pcoFileFilter :: String -> Bool
pcoFileFilter = (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
exts) (String -> Bool) -> (String -> String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeExtension }

dirCompleter :: Completer
dirCompleter :: Completer
dirCompleter = PathCompleterOpts -> Completer
pathCompleterWith PathCompleterOpts
defaultPathCompleterOpts { pcoFileFilter :: String -> Bool
pcoFileFilter = Bool -> String -> Bool
forall a b. a -> b -> a
const Bool
False }

pathCompleterWith :: PathCompleterOpts -> Completer
pathCompleterWith :: PathCompleterOpts -> Completer
pathCompleterWith PathCompleterOpts {Bool
Maybe String
String -> Bool
pcoDirFilter :: String -> Bool
pcoFileFilter :: String -> Bool
pcoRootDir :: Maybe String
pcoRelative :: Bool
pcoAbsolute :: Bool
pcoDirFilter :: PathCompleterOpts -> String -> Bool
pcoRootDir :: PathCompleterOpts -> Maybe String
pcoFileFilter :: PathCompleterOpts -> String -> Bool
pcoAbsolute :: PathCompleterOpts -> Bool
pcoRelative :: PathCompleterOpts -> Bool
..} = (String -> IO [String]) -> Completer
mkCompleter ((String -> IO [String]) -> Completer)
-> (String -> IO [String]) -> Completer
forall a b. (a -> b) -> a -> b
$ \String
inputRaw -> do
    -- Unescape input, to handle single and double quotes. Note that the
    -- results do not need to be re-escaped, due to some fiddly bash
    -- magic.
    let input :: String
input = String -> String
unescapeBashArg String
inputRaw
    let (String
inputSearchDir0, String
searchPrefix) = String -> (String, String)
splitFileName String
input
        inputSearchDir :: String
inputSearchDir = if String
inputSearchDir0 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"./" then String
"" else String
inputSearchDir0
    Maybe String
msearchDir <-
        case (String -> Bool
isRelative String
inputSearchDir, Bool
pcoAbsolute, Bool
pcoRelative) of
            (Bool
True, Bool
_, Bool
True) -> do
                String
rootDir <- IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
getCurrentDirectory String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
pcoRootDir
                Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just (String
rootDir String -> String -> String
</> String
inputSearchDir)
            (Bool
False, Bool
True, Bool
_) -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
inputSearchDir
            (Bool, Bool, Bool)
_ -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
    case Maybe String
msearchDir of
        Maybe String
Nothing
            | String
input String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" Bool -> Bool -> Bool
&& Bool
pcoAbsolute -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
"/"]
            | Bool
otherwise -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
        Just String
searchDir -> do
            [String]
entries <- String -> IO [String]
getDirectoryContents String
searchDir IO [String] -> (IOException -> IO [String]) -> IO [String]
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(IOException
_ :: IOException) -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
            ([Maybe String] -> [String]) -> IO [Maybe String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes (IO [Maybe String] -> IO [String])
-> IO [Maybe String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ [String] -> (String -> IO (Maybe String)) -> IO [Maybe String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
entries ((String -> IO (Maybe String)) -> IO [Maybe String])
-> (String -> IO (Maybe String)) -> IO [Maybe String]
forall a b. (a -> b) -> a -> b
$ \String
entry ->
                -- Skip . and .. unless user is typing . or ..
                if String
entry String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"..", String
"."] Bool -> Bool -> Bool
&& String
searchPrefix String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String
"..", String
"."] then Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing else
                    if String
searchPrefix String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
entry
                        then do
                            let path :: String
path = String
searchDir String -> String -> String
</> String
entry
                            case (String -> Bool
pcoFileFilter String
path, String -> Bool
pcoDirFilter String
path) of
                                (Bool
True, Bool
True) -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just (String
inputSearchDir String -> String -> String
</> String
entry)
                                (Bool
fileAllowed, Bool
dirAllowed) -> do
                                    Bool
isDir <- String -> IO Bool
doesDirectoryExist String
path
                                    if (if Bool
isDir then Bool
dirAllowed else Bool
fileAllowed)
                                        then Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just (String
inputSearchDir String -> String -> String
</> String
entry)
                                        else Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
                        else Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing

unescapeBashArg :: String -> String
unescapeBashArg :: String -> String
unescapeBashArg (Char
'\'' : String
rest) = String
rest
unescapeBashArg (Char
'\"' : String
rest) = String -> String
go String
rest
  where
    pattern :: String
pattern = String
"$`\"\\\n" :: String
    go :: String -> String
go [] = []
    go (Char
'\\' : Char
x : String
xs)
        | Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
pattern = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs
        | Bool
otherwise = Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
xs
    go (Char
x : String
xs) = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
xs
unescapeBashArg String
input = String -> String
go String
input
  where
    go :: String -> String
go [] = []
    go (Char
'\\' : Char
x : String
xs) = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
xs
    go (Char
x : String
xs) = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
xs

showHelpText :: ParseError
#if MIN_VERSION_optparse_applicative(0,16,0)
showHelpText :: ParseError
showHelpText = Maybe String -> ParseError
ShowHelpText Maybe String
forall a. Maybe a
Nothing
#else
showHelpText = ShowHelpText
#endif