git.iko.soy/elk
on 2edbe13 help sign in
elk/terminal/impl/Terminal/Error.hs
457 lines 12 kB history raw
1{-# LANGUAGE GADTs, OverloadedStrings #-}
2module Terminal.Error
3 ( Error(..)
4 , ArgError(..)
5 , FlagError(..)
6 , Expectation(..)
7 , exitWithHelp
8 , exitWithError
9 , exitWithUnknown
10 , exitWithOverview
11 )
12 where
15import Data.Monoid ((<>))
16import qualified Data.List as List
17import qualified Data.Maybe as Maybe
18import GHC.IO.Handle (hIsTerminalDevice)
19import qualified System.Environment as Env
20import qualified System.Exit as Exit
21import qualified System.FilePath as FP
22import System.IO (hPutStrLn, stderr)
23import qualified Text.PrettyPrint.ANSI.Leijen as P
25import Reporting.Suggest as Suggest
26import Terminal.Internal
30-- ERROR
33data Error where
34 BadArgs :: [(CompleteArgs a, ArgError)] -> Error
35 BadFlag :: FlagError -> Error
38data ArgError
39 = ArgMissing Expectation
40 | ArgBad String Expectation
41 | ArgExtras [String]
44data FlagError where
45 FlagWithValue :: String -> String -> FlagError
46 FlagWithBadValue :: String -> String -> Expectation -> FlagError
47 FlagWithNoValue :: String -> Expectation -> FlagError
48 FlagUnknown :: String -> Flags a -> FlagError
51data Expectation =
52 Expectation
53 { _type :: String
54 , _examples :: IO [String]
55 }
59-- EXIT
62exitSuccess :: [P.Doc] -> IO a
63exitSuccess =
64 exitWith Exit.ExitSuccess
67exitFailure :: [P.Doc] -> IO a
68exitFailure =
69 exitWith (Exit.ExitFailure 1)
72exitWith :: Exit.ExitCode -> [P.Doc] -> IO a
73exitWith code docs =
74 do isTerminal <- hIsTerminalDevice stderr
75 let adjust = if isTerminal then id else P.plain
76 P.displayIO stderr $ P.renderPretty 1 80 $
77 adjust $ P.vcat $ concatMap (\d -> [d,""]) docs
78 hPutStrLn stderr ""
79 Exit.exitWith code
82getExeName :: IO String
83getExeName =
84 FP.takeFileName <$> Env.getProgName
87stack :: [P.Doc] -> P.Doc
88stack docs =
89 P.vcat $ List.intersperse "" docs
92reflow :: String -> P.Doc
93reflow string =
94 P.fillSep $ map P.text $ words string
98-- HELP
101exitWithHelp :: Maybe String -> String -> P.Doc -> Args args -> Flags flags -> IO a
102exitWithHelp maybeCommand details example (Args args) flags =
103 do command <- toCommand maybeCommand
104 exitSuccess $
105 [ reflow details
106 , P.indent 4 $ P.cyan $ P.vcat $ map (argsToDoc command) args
107 , example
108 ]
109 ++
110 case flagsToDocs flags [] of
111 [] ->
112 []
114 docs@(_:_) ->
115 [ "You can customize this command with the following flags:"
116 , P.indent 4 $ stack docs
117 ]
120toCommand :: Maybe String -> IO String
121toCommand maybeCommand =
122 do exeName <- getExeName
123 return $
124 case maybeCommand of
125 Nothing ->
126 exeName
128 Just command ->
129 exeName ++ " " ++ command
132argsToDoc :: String -> CompleteArgs a -> P.Doc
133argsToDoc command args =
134 case args of
135 Exactly required ->
136 argsToDocHelp command required []
138 Multiple required (Parser _ plural _ _ _) ->
139 argsToDocHelp command required ["zero or more " ++ plural]
141 Optional required (Parser singular _ _ _ _) ->
142 argsToDocHelp command required ["optional " ++ singular]
145argsToDocHelp :: String -> RequiredArgs a -> [String] -> P.Doc
146argsToDocHelp command args names =
147 case args of
148 Done _ ->
149 P.hang 4 $ P.hsep $ map P.text $
150 command : map toToken names
152 Required others (Parser singular _ _ _ _) ->
153 argsToDocHelp command others (singular : names)
156toToken :: String -> String
157toToken string =
158 "<" ++ map (\c -> if c == ' ' then '-' else c) string ++ ">"
161flagsToDocs :: Flags flags -> [P.Doc] -> [P.Doc]
162flagsToDocs flags docs =
163 case flags of
164 FDone _ ->
165 docs
167 FMore more flag ->
168 let
169 flagDoc =
170 P.vcat $
171 case flag of
172 Flag name (Parser singular _ _ _ _) description ->
173 [ P.dullcyan $ P.text $ "--" ++ name ++ "=" ++ toToken singular
174 , P.indent 4 $ reflow description
175 ]
177 OnOff name description ->
178 [ P.dullcyan $ P.text $ "--" ++ name
179 , P.indent 4 $ reflow description
180 ]
181 in
182 flagsToDocs more (flagDoc:docs)
186-- OVERVIEW
189exitWithOverview :: P.Doc -> P.Doc -> [Command] -> IO a
190exitWithOverview intro outro commands =
191 do exeName <- getExeName
192 exitSuccess
193 [ intro
194 , "The most common commands are:"
195 , P.indent 4 $ stack $ Maybe.mapMaybe (toSummary exeName) commands
196 , "There are a bunch of other commands as well though. Here is a full list:"
197 , P.indent 4 $ P.dullcyan $ toCommandList exeName commands
198 , "Adding the --help flag gives a bunch of additional details about each one."
199 , outro
200 ]
203toSummary :: String -> Command -> Maybe P.Doc
204toSummary exeName (Command name summary _ _ (Args args) _ _) =
205 case summary of
206 Uncommon ->
207 Nothing
209 Common summaryString ->
210 Just $
211 P.vcat
212 [ P.cyan $ argsToDoc (exeName ++ " " ++ name) (head args)
213 , P.indent 4 $ reflow summaryString
214 ]
217toCommandList :: String -> [Command] -> P.Doc
218toCommandList exeName commands =
219 let
220 names = map toName commands
221 width = maximum (map length names)
223 toExample name =
224 P.text $ exeName ++ " " ++ name ++ replicate (width - length name) ' ' ++ " --help"
225 in
226 P.vcat (map toExample names)
230-- UNKNOWN
233exitWithUnknown :: String -> [String] -> IO a
234exitWithUnknown unknown knowns =
235 let
236 nearbyKnowns =
237 takeWhile (\(r,_) -> r <= 3) (Suggest.rank unknown id knowns)
239 suggestions =
240 case map toGreen (map snd nearbyKnowns) of
241 [] ->
242 []
244 [nearby] ->
245 ["Try",nearby,"instead?"]
247 [a,b] ->
248 ["Try",a,"or",b,"instead?"]
250 abcs@(_:_:_:_) ->
251 ["Try"] ++ map (<> ",") (init abcs) ++ ["or",last abcs,"instead?"]
252 in
253 do exeName <- getExeName
254 exitFailure
255 [ P.fillSep $ ["There","is","no",toRed unknown,"command."] ++ suggestions
256 , reflow $ "Run `" ++ exeName ++ "` with no arguments to get more hints."
257 ]
261-- ERROR TO DOC
264exitWithError :: Error -> IO a
265exitWithError err =
266 exitFailure =<<
267 case err of
268 BadFlag flagError ->
269 flagErrorToDocs flagError
271 BadArgs argErrors ->
272 case argErrors of
273 [] ->
274 return
275 [ reflow $ "I was not expecting any arguments for this command."
276 , reflow $ "Try removing them?"
277 ]
279 [(_args, argError)] ->
280 argErrorToDocs argError
282 _:_:_ ->
283 argErrorToDocs $ head $ List.sortOn toArgErrorRank (map snd argErrors)
286toArgErrorRank :: ArgError -> Int -- lower is better
287toArgErrorRank err =
288 case err of
289 ArgBad _ _ -> 0
290 ArgMissing _ -> 1
291 ArgExtras _ -> 2
294toGreen :: String -> P.Doc
295toGreen str =
296 P.green (P.text str)
299toYellow :: String -> P.Doc
300toYellow str =
301 P.yellow (P.text str)
304toRed :: String -> P.Doc
305toRed str =
306 P.red (P.text str)
310-- ARG ERROR TO DOC
313argErrorToDocs :: ArgError -> IO [P.Doc]
314argErrorToDocs argError =
315 case argError of
316 ArgMissing (Expectation tipe makeExamples) ->
317 do examples <- makeExamples
318 return
319 [ P.fillSep
320 ["The","arguments","you","have","are","fine,","but","in","addition,","I","was"
321 ,"expecting","a",toYellow (toToken tipe),"value.","For","example:"
322 ]
323 , P.indent 4 $ P.green $ P.vcat $ map P.text examples
324 ]
326 ArgBad string (Expectation tipe makeExamples) ->
327 do examples <- makeExamples
328 return
329 [ "I am having trouble with this argument:"
330 , P.indent 4 $ toRed string
331 , P.fillSep $
332 ["It","is","supposed","to","be","a"
333 ,toYellow (toToken tipe),"value,","like"
334 ] ++ if length examples == 1 then ["this:"] else ["one","of","these:"]
335 , P.indent 4 $ P.green $ P.vcat $ map P.text examples
336 ]
338 ArgExtras extras ->
339 let
340 (these, them) =
341 case extras of
342 [_] -> ("this argument", "it")
343 _ -> ("these arguments", "them")
344 in
345 return
346 [ reflow $ "I was not expecting " ++ these ++ ":"
347 , P.indent 4 $ P.red $ P.vcat $ map P.text extras
348 , reflow $ "Try removing " ++ them ++ "?"
349 ]
353-- FLAG ERROR TO DOC
356flagErrorHelp :: String -> String -> [P.Doc] -> IO [P.Doc]
357flagErrorHelp summary original explanation =
358 return $
359 [ reflow summary
360 , P.indent 4 (toRed original)
361 ]
362 ++ explanation
365flagErrorToDocs :: FlagError -> IO [P.Doc]
366flagErrorToDocs flagError =
367 case flagError of
368 FlagWithValue flagName value ->
369 flagErrorHelp
370 "This on/off flag was given a value:"
371 ("--" ++ flagName ++ "=" ++ value)
372 [ "An on/off flag either exists or not. It cannot have an equals sign and value.\n\
373 \Maybe you want this instead?"
374 , P.indent 4 $ toGreen $ "--" ++ flagName
375 ]
377 FlagWithNoValue flagName (Expectation tipe makeExamples) ->
378 do examples <- makeExamples
379 flagErrorHelp
380 "This flag needs more information:"
381 ("--" ++ flagName)
382 [ P.fillSep ["It","needs","a",toYellow (toToken tipe),"like","this:"]
383 , P.indent 4 $ P.vcat $ map toGreen $
384 case take 4 examples of
385 [] ->
386 ["--" ++ flagName ++ "=" ++ toToken tipe]
388 _:_ ->
389 map (\example -> "--" ++ flagName ++ "=" ++ example) examples
390 ]
392 FlagWithBadValue flagName badValue (Expectation tipe makeExamples) ->
393 do examples <- makeExamples
394 flagErrorHelp
395 "This flag was given a bad value:"
396 ("--" ++ flagName ++ "=" ++ badValue)
397 [ P.fillSep $
398 ["I","need","a","valid",toYellow (toToken tipe),"value.","For","example:"
399 ]
400 , P.indent 4 $ P.vcat $ map toGreen $
401 case take 4 examples of
402 [] ->
403 ["--" ++ flagName ++ "=" ++ toToken tipe]
405 _:_ ->
406 map (\example -> "--" ++ flagName ++ "=" ++ example) examples
407 ]
409 FlagUnknown unknown flags ->
410 flagErrorHelp
411 "I do not recognize this flag:"
412 unknown
413 (
414 let unknownName = takeWhile ('=' /=) (dropWhile ('-' ==) unknown) in
415 case getNearbyFlags unknownName flags [] of
416 [] ->
417 []
419 [thisOne] ->
420 [ P.fillSep ["Maybe","you","want",P.green thisOne,"instead?"]
421 ]
423 suggestions ->
424 [ P.fillSep ["Maybe","you","want","one","of","these","instead?"]
425 , P.indent 4 $ P.green $ P.vcat suggestions
426 ]
427 )
430getNearbyFlags :: String -> Flags a -> [(Int, String)] -> [P.Doc]
431getNearbyFlags unknown flags unsortedFlags =
432 case flags of
433 FMore more flag ->
434 getNearbyFlags unknown more (getNearbyFlagsHelp unknown flag : unsortedFlags)
436 FDone _ ->
437 map P.text $ map snd $ List.sortOn fst $
438 case filter (\(d,_) -> d < 3) unsortedFlags of
439 [] ->
440 unsortedFlags
442 nearbyUnsortedFlags ->
443 nearbyUnsortedFlags
446getNearbyFlagsHelp :: String -> Flag a -> (Int, String)
447getNearbyFlagsHelp unknown flag =
448 case flag of
449 OnOff flagName _ ->
450 ( Suggest.distance unknown flagName
451 , "--" ++ flagName
452 )
454 Flag flagName (Parser singular _ _ _ _) _ ->
455 ( Suggest.distance unknown flagName
456 , "--" ++ flagName ++ "=" ++ toToken singular
457 )