module Options.Applicative.Builder.Extra
(boolFlags
,boolFlagsNoDefault
,maybeBoolFlags
,firstBoolFlags
,enableDisableFlags
,enableDisableFlagsNoDefault
,extraHelpOption
,execExtraHelp
,textOption
,textArgument
,optionalFirst
,absFileOption
,relFileOption
,absDirOption
,relDirOption
,eitherReader'
,fileCompleter
,fileExtCompleter
,dirCompleter
,PathCompleterOpts(..)
,defaultPathCompleterOpts
,pathCompleterWith
,unescapeBashArg
) where
import Data.List (isPrefixOf)
import Data.Maybe
import Data.Monoid
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)
boolFlags :: Bool
-> String
-> String
-> Mod FlagFields Bool
-> Parser Bool
boolFlags defaultValue = enableDisableFlags defaultValue True False
boolFlagsNoDefault :: String
-> String
-> Mod FlagFields Bool
-> Parser Bool
boolFlagsNoDefault = enableDisableFlagsNoDefault True False
maybeBoolFlags :: String
-> String
-> Mod FlagFields (Maybe Bool)
-> Parser (Maybe Bool)
maybeBoolFlags = enableDisableFlags Nothing (Just True) (Just False)
firstBoolFlags :: String -> String -> Mod FlagFields (Maybe Bool) -> Parser (First Bool)
firstBoolFlags long0 help0 mod0 = First <$> maybeBoolFlags long0 help0 mod0
enableDisableFlags :: a
-> a
-> a
-> String
-> String
-> Mod FlagFields a
-> Parser a
enableDisableFlags defaultValue enabledValue disabledValue name helpSuffix mods =
enableDisableFlagsNoDefault enabledValue disabledValue name helpSuffix mods <|>
pure defaultValue
enableDisableFlagsNoDefault :: a
-> a
-> String
-> String
-> Mod FlagFields a
-> Parser a
enableDisableFlagsNoDefault enabledValue disabledValue name helpSuffix mods =
last <$> some
((flag'
enabledValue
(hidden <>
internal <>
long name <>
help helpSuffix <>
mods) <|>
flag'
disabledValue
(hidden <>
internal <>
long ("no-" ++ name) <>
help helpSuffix <>
mods)) <|>
flag'
disabledValue
(long ("[no-]" ++ name) <>
help ("Enable/disable " ++ helpSuffix) <>
mods))
where
last xs =
case reverse xs of
[] -> impureThrow $ stringException "enableDisableFlagsNoDefault.last"
x:_ -> x
extraHelpOption :: Bool
-> String
-> String
-> String
-> Parser (a -> a)
extraHelpOption hide progName fakeName helpName =
infoOption (optDesc' ++ ".") (long helpName <> hidden <> internal) <*>
infoOption (optDesc' ++ ".") (long fakeName <>
help optDesc' <>
(if hide then hidden <> internal else idm))
where optDesc' = concat ["Run '", takeBaseName progName, " --", helpName, "' for details"]
execExtraHelp :: [String]
-> String
-> Parser a
-> String
-> IO ()
execExtraHelp args helpOpt parser pd =
when (args == ["--" ++ helpOpt]) $
withArgs ["--help"] $ do
_ <- execParser (info (hiddenHelper <*>
((,) <$>
parser <*>
some (strArgument (metavar "OTHER ARGUMENTS") :: Parser String)))
(fullDesc <> progDesc pd))
return ()
where hiddenHelper = abortOption ShowHelpText (long "help" <> hidden <> internal)
textOption :: Mod OptionFields Text -> Parser Text
textOption = option (T.pack <$> readerAsk)
textArgument :: Mod ArgumentFields Text -> Parser Text
textArgument = argument (T.pack <$> readerAsk)
optionalFirst :: Alternative f => f a -> f (First a)
optionalFirst = fmap First . optional
absFileOption :: Mod OptionFields (Path Abs File) -> Parser (Path Abs File)
absFileOption mods = option (eitherReader' parseAbsFile) $
completer (pathCompleterWith defaultPathCompleterOpts { pcoRelative = False }) <> mods
relFileOption :: Mod OptionFields (Path Rel File) -> Parser (Path Rel File)
relFileOption mods = option (eitherReader' parseRelFile) $
completer (pathCompleterWith defaultPathCompleterOpts { pcoAbsolute = False }) <> mods
absDirOption :: Mod OptionFields (Path Abs Dir) -> Parser (Path Abs Dir)
absDirOption mods = option (eitherReader' parseAbsDir) $
completer (pathCompleterWith defaultPathCompleterOpts { pcoRelative = False, pcoFileFilter = const False }) <> mods
relDirOption :: Mod OptionFields (Path Rel Dir) -> Parser (Path Rel Dir)
relDirOption mods = option (eitherReader' parseRelDir) $
completer (pathCompleterWith defaultPathCompleterOpts { pcoAbsolute = False, pcoFileFilter = const False }) <> mods
eitherReader' :: Show e => (String -> Either e a) -> ReadM a
eitherReader' f = eitherReader (mapLeft show . f)
data PathCompleterOpts = PathCompleterOpts
{ pcoAbsolute :: Bool
, pcoRelative :: Bool
, pcoRootDir :: Maybe FilePath
, pcoFileFilter :: FilePath -> Bool
, pcoDirFilter :: FilePath -> Bool
}
defaultPathCompleterOpts :: PathCompleterOpts
defaultPathCompleterOpts = PathCompleterOpts
{ pcoAbsolute = True
, pcoRelative = True
, pcoRootDir = Nothing
, pcoFileFilter = const True
, pcoDirFilter = const True
}
fileCompleter :: Completer
fileCompleter = pathCompleterWith defaultPathCompleterOpts
fileExtCompleter :: [String] -> Completer
fileExtCompleter exts = pathCompleterWith defaultPathCompleterOpts { pcoFileFilter = (`elem` exts) . takeExtension }
dirCompleter :: Completer
dirCompleter = pathCompleterWith defaultPathCompleterOpts { pcoFileFilter = const False }
pathCompleterWith :: PathCompleterOpts -> Completer
pathCompleterWith PathCompleterOpts {..} = mkCompleter $ \inputRaw -> do
let input = unescapeBashArg inputRaw
let (inputSearchDir0, searchPrefix) = splitFileName input
inputSearchDir = if inputSearchDir0 == "./" then "" else inputSearchDir0
msearchDir <-
case (isRelative inputSearchDir, pcoAbsolute, pcoRelative) of
(True, _, True) -> do
rootDir <- maybe getCurrentDirectory return pcoRootDir
return $ Just (rootDir </> inputSearchDir)
(False, True, _) -> return $ Just inputSearchDir
_ -> return Nothing
case msearchDir of
Nothing
| input == "" && pcoAbsolute -> return ["/"]
| otherwise -> return []
Just searchDir -> do
entries <- getDirectoryContents searchDir `catch` \(_ :: IOException) -> return []
fmap catMaybes $ forM entries $ \entry ->
if entry `elem` ["..", "."] && searchPrefix `notElem` ["..", "."] then return Nothing else
if searchPrefix `isPrefixOf` entry
then do
let path = searchDir </> entry
case (pcoFileFilter path, pcoDirFilter path) of
(True, True) -> return $ Just (inputSearchDir </> entry)
(fileAllowed, dirAllowed) -> do
isDir <- doesDirectoryExist path
if (if isDir then dirAllowed else fileAllowed)
then return $ Just (inputSearchDir </> entry)
else return Nothing
else return Nothing
unescapeBashArg :: String -> String
unescapeBashArg ('\'' : rest) = rest
unescapeBashArg ('\"' : rest) = go rest
where
pattern = "$`\"\\\n" :: String
go [] = []
go ('\\' : x : xs)
| x `elem` pattern = x : xs
| otherwise = '\\' : x : go xs
go (x : xs) = x : go xs
unescapeBashArg input = go input
where
go [] = []
go ('\\' : x : xs) = x : go xs
go (x : xs) = x : go xs