1{-# LANGUAGE CPP #-}
2{-# LANGUAGE NoImplicitPrelude #-}
3{-# LANGUAGE RecordWildCards #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5
6-- | Extra functions for optparse-applicative.
7
8module Options.Applicative.Builder.Extra
9  (boolFlags
10  ,boolFlagsNoDefault
11  ,firstBoolFlagsNoDefault
12  ,firstBoolFlagsTrue
13  ,firstBoolFlagsFalse
14  ,enableDisableFlags
15  ,enableDisableFlagsNoDefault
16  ,extraHelpOption
17  ,execExtraHelp
18  ,textOption
19  ,textArgument
20  ,optionalFirst
21  ,optionalFirstTrue
22  ,optionalFirstFalse
23  ,absFileOption
24  ,relFileOption
25  ,absDirOption
26  ,relDirOption
27  ,eitherReader'
28  ,fileCompleter
29  ,fileExtCompleter
30  ,dirCompleter
31  ,PathCompleterOpts(..)
32  ,defaultPathCompleterOpts
33  ,pathCompleterWith
34  ,unescapeBashArg
35  ,showHelpText
36  ) where
37
38import Data.List (isPrefixOf)
39import Data.Maybe
40import Data.Monoid hiding ((<>))
41import qualified Data.Text as T
42import Options.Applicative
43import Options.Applicative.Types (readerAsk)
44import Path hiding ((</>))
45import Stack.Prelude
46import System.Directory (getCurrentDirectory, getDirectoryContents, doesDirectoryExist)
47import System.Environment (withArgs)
48import System.FilePath (takeBaseName, (</>), splitFileName, isRelative, takeExtension)
49
50-- | Enable/disable flags for a 'Bool'.
51boolFlags :: Bool                 -- ^ Default value
52          -> String               -- ^ Flag name
53          -> String               -- ^ Help suffix
54          -> Mod FlagFields Bool
55          -> Parser Bool
56boolFlags defaultValue name helpSuffix =
57  enableDisableFlags defaultValue True False name $ concat
58    [ helpSuffix
59    , " (default: "
60    , if defaultValue then "enabled" else "disabled"
61    , ")"
62    ]
63
64-- | Enable/disable flags for a 'Bool', without a default case (to allow chaining with '<|>').
65boolFlagsNoDefault :: String               -- ^ Flag name
66                   -> String               -- ^ Help suffix
67                   -> Mod FlagFields Bool
68                   -> Parser Bool
69boolFlagsNoDefault = enableDisableFlagsNoDefault True False
70
71-- | Flag with no default of True or False
72firstBoolFlagsNoDefault :: String -> String -> Mod FlagFields (Maybe Bool) -> Parser (First Bool)
73firstBoolFlagsNoDefault name helpSuffix mod' =
74  First <$>
75  enableDisableFlags Nothing (Just True) (Just False)
76  name helpSuffix mod'
77
78-- | Flag with a Semigroup instance and a default of True
79firstBoolFlagsTrue :: String -> String -> Mod FlagFields FirstTrue -> Parser FirstTrue
80firstBoolFlagsTrue name helpSuffix =
81  enableDisableFlags mempty (FirstTrue (Just True)) (FirstTrue (Just False))
82  name $ helpSuffix ++ " (default: enabled)"
83
84-- | Flag with a Semigroup instance and a default of False
85firstBoolFlagsFalse :: String -> String -> Mod FlagFields FirstFalse -> Parser FirstFalse
86firstBoolFlagsFalse name helpSuffix =
87  enableDisableFlags mempty (FirstFalse (Just True)) (FirstFalse (Just False))
88  name $ helpSuffix ++ " (default: disabled)"
89
90-- | Enable/disable flags for any type.
91enableDisableFlags :: a                 -- ^ Default value
92                   -> a                 -- ^ Enabled value
93                   -> a                 -- ^ Disabled value
94                   -> String            -- ^ Name
95                   -> String            -- ^ Help suffix
96                   -> Mod FlagFields a
97                   -> Parser a
98enableDisableFlags defaultValue enabledValue disabledValue name helpSuffix mods =
99  enableDisableFlagsNoDefault enabledValue disabledValue name helpSuffix mods <|>
100  pure defaultValue
101
102-- | Enable/disable flags for any type, without a default (to allow chaining with '<|>')
103enableDisableFlagsNoDefault :: a                 -- ^ Enabled value
104                            -> a                 -- ^ Disabled value
105                            -> String            -- ^ Name
106                            -> String            -- ^ Help suffix
107                            -> Mod FlagFields a
108                            -> Parser a
109enableDisableFlagsNoDefault enabledValue disabledValue name helpSuffix mods =
110  last <$> some
111      ((flag'
112           enabledValue
113           (hidden <>
114            internal <>
115            long name <>
116            help helpSuffix <>
117            mods) <|>
118       flag'
119           disabledValue
120           (hidden <>
121            internal <>
122            long ("no-" ++ name) <>
123            help helpSuffix <>
124            mods)) <|>
125       flag'
126           disabledValue
127           (long ("[no-]" ++ name) <>
128            help ("Enable/disable " ++ helpSuffix) <>
129            mods))
130  where
131    last xs =
132      case reverse xs of
133        [] -> impureThrow $ stringException "enableDisableFlagsNoDefault.last"
134        x:_ -> x
135
136-- | Show an extra help option (e.g. @--docker-help@ shows help for all @--docker*@ args).
137--
138-- To actually have that help appear, use 'execExtraHelp' before executing the main parser.
139extraHelpOption :: Bool             -- ^ Hide from the brief description?
140                -> String           -- ^ Program name, e.g. @"stack"@
141                -> String           -- ^ Option glob expression, e.g. @"docker*"@
142                -> String           -- ^ Help option name, e.g. @"docker-help"@
143                -> Parser (a -> a)
144extraHelpOption hide progName fakeName helpName =
145    infoOption (optDesc' ++ ".") (long helpName <> hidden <> internal) <*>
146    infoOption (optDesc' ++ ".") (long fakeName <>
147                                  help optDesc' <>
148                                  (if hide then hidden <> internal else idm))
149  where optDesc' = concat ["Run '", takeBaseName progName, " --", helpName, "' for details"]
150
151-- | Display extra help if extra help option passed in arguments.
152--
153-- Since optparse-applicative doesn't allow an arbitrary IO action for an 'abortOption', this
154-- was the best way I found that doesn't require manually formatting the help.
155execExtraHelp :: [String]  -- ^ Command line arguments
156              -> String    -- ^ Extra help option name, e.g. @"docker-help"@
157              -> Parser a  -- ^ Option parser for the relevant command
158              -> String    -- ^ Option description
159              -> IO ()
160execExtraHelp args helpOpt parser pd =
161    when (args == ["--" ++ helpOpt]) $
162      withArgs ["--help"] $ do
163        _ <- execParser (info (hiddenHelper <*>
164                               ((,) <$>
165                                parser <*>
166                                some (strArgument (metavar "OTHER ARGUMENTS") :: Parser String)))
167                        (fullDesc <> progDesc pd))
168        return ()
169  where hiddenHelper = abortOption showHelpText (long "help" <> hidden <> internal)
170
171-- | 'option', specialized to 'Text'.
172textOption :: Mod OptionFields Text -> Parser Text
173textOption = option (T.pack <$> readerAsk)
174
175-- | 'argument', specialized to 'Text'.
176textArgument :: Mod ArgumentFields Text -> Parser Text
177textArgument = argument (T.pack <$> readerAsk)
178
179-- | Like 'optional', but returning a 'First'.
180optionalFirst :: Alternative f => f a -> f (First a)
181optionalFirst = fmap First . optional
182
183-- | Like 'optional', but returning a 'FirstTrue'.
184optionalFirstTrue :: Alternative f => f Bool -> f FirstTrue
185optionalFirstTrue = fmap FirstTrue . optional
186
187-- | Like 'optional', but returning a 'FirstFalse'.
188optionalFirstFalse :: Alternative f => f Bool -> f FirstFalse
189optionalFirstFalse = fmap FirstFalse . optional
190
191absFileOption :: Mod OptionFields (Path Abs File) -> Parser (Path Abs File)
192absFileOption mods = option (eitherReader' parseAbsFile) $
193  completer (pathCompleterWith defaultPathCompleterOpts { pcoRelative = False }) <> mods
194
195relFileOption :: Mod OptionFields (Path Rel File) -> Parser (Path Rel File)
196relFileOption mods = option (eitherReader' parseRelFile) $
197  completer (pathCompleterWith defaultPathCompleterOpts { pcoAbsolute = False }) <> mods
198
199absDirOption :: Mod OptionFields (Path Abs Dir) -> Parser (Path Abs Dir)
200absDirOption mods = option (eitherReader' parseAbsDir) $
201  completer (pathCompleterWith defaultPathCompleterOpts { pcoRelative = False, pcoFileFilter = const False }) <> mods
202
203relDirOption :: Mod OptionFields (Path Rel Dir) -> Parser (Path Rel Dir)
204relDirOption mods = option (eitherReader' parseRelDir) $
205  completer (pathCompleterWith defaultPathCompleterOpts { pcoAbsolute = False, pcoFileFilter = const False }) <> mods
206
207-- | Like 'eitherReader', but accepting any @'Show' e@ on the 'Left'.
208eitherReader' :: Show e => (String -> Either e a) -> ReadM a
209eitherReader' f = eitherReader (mapLeft show . f)
210
211data PathCompleterOpts = PathCompleterOpts
212    { pcoAbsolute :: Bool
213    , pcoRelative :: Bool
214    , pcoRootDir :: Maybe FilePath
215    , pcoFileFilter :: FilePath -> Bool
216    , pcoDirFilter :: FilePath -> Bool
217    }
218
219defaultPathCompleterOpts :: PathCompleterOpts
220defaultPathCompleterOpts = PathCompleterOpts
221    { pcoAbsolute = True
222    , pcoRelative = True
223    , pcoRootDir = Nothing
224    , pcoFileFilter = const True
225    , pcoDirFilter = const True
226    }
227
228fileCompleter :: Completer
229fileCompleter = pathCompleterWith defaultPathCompleterOpts
230
231fileExtCompleter :: [String] -> Completer
232fileExtCompleter exts = pathCompleterWith defaultPathCompleterOpts { pcoFileFilter = (`elem` exts) . takeExtension }
233
234dirCompleter :: Completer
235dirCompleter = pathCompleterWith defaultPathCompleterOpts { pcoFileFilter = const False }
236
237pathCompleterWith :: PathCompleterOpts -> Completer
238pathCompleterWith PathCompleterOpts {..} = mkCompleter $ \inputRaw -> do
239    -- Unescape input, to handle single and double quotes. Note that the
240    -- results do not need to be re-escaped, due to some fiddly bash
241    -- magic.
242    let input = unescapeBashArg inputRaw
243    let (inputSearchDir0, searchPrefix) = splitFileName input
244        inputSearchDir = if inputSearchDir0 == "./" then "" else inputSearchDir0
245    msearchDir <-
246        case (isRelative inputSearchDir, pcoAbsolute, pcoRelative) of
247            (True, _, True) -> do
248                rootDir <- maybe getCurrentDirectory return pcoRootDir
249                return $ Just (rootDir </> inputSearchDir)
250            (False, True, _) -> return $ Just inputSearchDir
251            _ -> return Nothing
252    case msearchDir of
253        Nothing
254            | input == "" && pcoAbsolute -> return ["/"]
255            | otherwise -> return []
256        Just searchDir -> do
257            entries <- getDirectoryContents searchDir `catch` \(_ :: IOException) -> return []
258            fmap catMaybes $ forM entries $ \entry ->
259                -- Skip . and .. unless user is typing . or ..
260                if entry `elem` ["..", "."] && searchPrefix `notElem` ["..", "."] then return Nothing else
261                    if searchPrefix `isPrefixOf` entry
262                        then do
263                            let path = searchDir </> entry
264                            case (pcoFileFilter path, pcoDirFilter path) of
265                                (True, True) -> return $ Just (inputSearchDir </> entry)
266                                (fileAllowed, dirAllowed) -> do
267                                    isDir <- doesDirectoryExist path
268                                    if (if isDir then dirAllowed else fileAllowed)
269                                        then return $ Just (inputSearchDir </> entry)
270                                        else return Nothing
271                        else return Nothing
272
273unescapeBashArg :: String -> String
274unescapeBashArg ('\'' : rest) = rest
275unescapeBashArg ('\"' : rest) = go rest
276  where
277    pattern = "$`\"\\\n" :: String
278    go [] = []
279    go ('\\' : x : xs)
280        | x `elem` pattern = x : xs
281        | otherwise = '\\' : x : go xs
282    go (x : xs) = x : go xs
283unescapeBashArg input = go input
284  where
285    go [] = []
286    go ('\\' : x : xs) = x : go xs
287    go (x : xs) = x : go xs
288
289showHelpText :: ParseError
290#if MIN_VERSION_optparse_applicative(0,16,0)
291showHelpText = ShowHelpText Nothing
292#else
293showHelpText = ShowHelpText
294#endif
295