git.iko.soy/elk
on 8f7c3cd help sign in
elk/cli/src/CommandLine/Args/Internal.hs
851 lines 18 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE GADTs #-}
3module CommandLine.Args.Internal
4 ( get
5 , Flags, noFlags, flags, (|--)
6 , Flag, flag, onOff
7 , Parser, int, file, anything, custom
8 , Args, noArgs, required, optional, zeroOrMore, oneOrMore, oneOf
9 , require0, require1, require2, require3, require4, require5
10 , RequiredArgs, args, exactly, (!), (?), (...)
11 , Route(..)
12 )
13 where
15import qualified Data.Char as Char
16import qualified Data.List as List
17import GHC.IO.Handle (hIsTerminalDevice)
18import System.Environment (getArgs)
19import System.Exit (exitFailure)
20import System.IO (hPutStrLn, stderr)
21import Text.PrettyPrint.ANSI.Leijen
22 ( Doc, (<>), comma, displayIO, fillSep, green
23 , plain, red, renderPretty, text, vcat
24 )
26import Elm.Utils (nearbyNames)
30-- ROUTE
33data Route a where
34 Route :: (args -> flags -> a) -> Args args -> Flags flags -> Route a
38-- FLAGS
41data Flags a where
42 FDone :: a -> Flags a
43 FMore :: Flags (a -> b) -> Flag a -> Flags b
46noFlags :: Flags ()
47noFlags =
48 FDone ()
51flags :: a -> Flags a
52flags =
53 FDone
56(|--) :: Flags (a -> b) -> Flag a -> Flags b
57(|--) =
58 FMore
62-- FLAG
65data Flag a where
66 Flag :: String -> Parser a -> String -> Flag (Maybe a)
67 OnOff :: String -> String -> Flag Bool
70flag :: String -> Parser a -> String -> Flag (Maybe a)
71flag =
72 Flag
75onOff :: String -> String -> Flag Bool
76onOff =
77 OnOff
81-- PARSERS
84data Parser a where
85 Anything :: String -> Parser String
86 File :: Parser FilePath
87 Int :: String -> Parser Int
88 Custom :: String -> (String -> Maybe a) -> Parser a
91file :: Parser FilePath
92file =
93 File
96int :: String -> Parser Int
97int =
98 Int
101anything :: String -> Parser String
102anything =
103 Anything
106custom :: String -> (String -> Maybe a) -> Parser a
107custom =
108 Custom
111data ParserInfo =
112 ParserInfo
113 { _type :: String
114 }
117getParserInfo :: Parser a -> ParserInfo
118getParserInfo parser =
119 case parser of
120 Anything tipe ->
121 ParserInfo tipe
123 File ->
124 ParserInfo "FILE"
126 Int tipe ->
127 ParserInfo tipe
129 Custom tipe _ ->
130 ParserInfo tipe
133runParser :: Parser a -> String -> Either ParserError a
134runParser parser str =
135 case parser of
136 Anything _ ->
137 Right str
139 File ->
140 Right str
142 Int tipe ->
143 if all Char.isDigit str then
144 Right (read str :: Int)
145 else
146 Left (Expecting tipe)
148 Custom tipe toMaybe ->
149 case toMaybe str of
150 Nothing ->
151 Left (Expecting tipe)
153 Just a ->
154 Right a
157data ParserError = Expecting String
161-- ARGS
164noArgs :: Args ()
165noArgs =
166 exactly (args ())
169required :: Parser a -> Args a
170required parser =
171 require1 id parser
174optional :: Parser a -> Args (Maybe a)
175optional parser =
176 args id
177 ? parser
180zeroOrMore :: Parser a -> Args [a]
181zeroOrMore parser =
182 args id
183 ... parser
186oneOrMore :: Parser a -> Args (a, [a])
187oneOrMore parser =
188 args (,)
189 ! parser
190 ... parser
193require0 :: args -> Args args
194require0 value =
195 exactly (args value)
198require1 :: (a -> args) -> Parser a -> Args args
199require1 func a =
200 exactly (
201 args func
202 ! a
203 )
206require2 :: (a -> b -> args) -> Parser a -> Parser b -> Args args
207require2 func a b =
208 exactly (
209 args func
210 ! a
211 ! b
212 )
215require3 :: (a -> b -> c -> args) -> Parser a -> Parser b -> Parser c -> Args args
216require3 func a b c =
217 exactly (
218 args func
219 ! a
220 ! b
221 ! c
222 )
225require4 :: (a -> b -> c -> d -> args) -> Parser a -> Parser b -> Parser c -> Parser d -> Args args
226require4 func a b c d =
227 exactly (
228 args func
229 ! a
230 ! b
231 ! c
232 ! d
233 )
236require5 :: (a -> b -> c -> d -> e -> args) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e -> Args args
237require5 func a b c d e =
238 exactly (
239 args func
240 ! a
241 ! b
242 ! c
243 ! d
244 ! e
245 )
248oneOf :: [Args a] -> Args a
249oneOf =
250 OneOf
254-- FANCE ARGS
257data RequiredArgs a where
258 Done :: a -> RequiredArgs a
259 Required :: RequiredArgs (a -> b) -> Parser a -> RequiredArgs b
262data Args a where
263 Exactly :: RequiredArgs a -> Args a
264 Optional :: RequiredArgs (Maybe a -> b) -> Parser a -> Args b
265 Multiple :: RequiredArgs ([a] -> b) -> Parser a -> Args b
266 OneOf :: [Args a] -> Args a
269args :: a -> RequiredArgs a
270args =
271 Done
274exactly :: RequiredArgs a -> Args a
275exactly =
276 Exactly
279(!) :: RequiredArgs (a -> b) -> Parser a -> RequiredArgs b
280(!) =
281 Required
284(?) :: RequiredArgs (Maybe a -> b) -> Parser a -> Args b
285(?) =
286 Optional
289(...) :: RequiredArgs ([a] -> b) -> Parser a -> Args b
290(...) =
291 Multiple
295-- GET
298get :: Route a -> [(String, Route a)] -> IO a
299get route namedRoutes =
300 do chunks <- getArgs
301 case parse route namedRoutes chunks of
302 Right flagsAndArgs ->
303 return flagsAndArgs
305 Left err ->
306 failure err
310-- PARSE
313data Error
314 = AfterCommand String RouteError
315 | BadCommand String [String] String
316 | NoCommand RouteError
319parse :: Route a -> [(String, Route a)] -> [String] -> Either Error a
320parse route namedRoutes chunks =
321 case parseHelp namedRoutes chunks [] of
322 Right answer ->
323 Right answer
325 Left errors ->
326 case parseRoute route chunks of
327 Right answer ->
328 Right answer
330 Left routeError ->
331 case errors of
332 (name, specificRouteError) : _ ->
333 Left (AfterCommand name specificRouteError)
335 [] ->
336 case chunks of
337 first : _ | not (List.isPrefixOf "-" first) ->
338 case nearbyNames id first (map fst namedRoutes) of
339 [] ->
340 Left (NoCommand routeError)
342 suggestions ->
343 Left (BadCommand first (init suggestions) (last suggestions))
345 _ ->
346 Left (NoCommand routeError)
349parseHelp :: [(String, Route a)] -> [String] -> RouteErrors -> Either RouteErrors a
350parseHelp namedRoutes chunks errors =
351 case namedRoutes of
352 [] ->
353 Left errors
355 (name, route) : rest ->
356 case parseNamedRoute name route chunks of
357 Left errs ->
358 parseHelp rest chunks (errs ++ errors)
360 Right answer ->
361 Right answer
365-- PARSE NAMED ROUTE
368type RouteErrors = [(String, RouteError)]
371parseNamedRoute :: String -> Route a -> [String] -> Either RouteErrors a
372parseNamedRoute name route rawChunks =
373 case rawChunks of
374 first : chunks | name == first ->
375 case parseRoute route chunks of
376 Right answer ->
377 Right answer
379 Left err ->
380 Left [(name, err)]
382 _ ->
383 Left []
387-- PARSE ROUTE
390data RouteError = BadFlags FlagError | BadArgs ArgError
393parseRoute :: Route a -> [String] -> Either RouteError a
394parseRoute (Route func args_ flags_) chunks =
395 case parseFlags flags_ chunks of
396 Left flagError ->
397 Left (BadFlags flagError)
399 Right (flagData, remainingChunks) ->
400 case parseArgs args_ remainingChunks of
401 Left argError ->
402 Left (BadArgs argError)
404 Right argData ->
405 Right (func argData flagData)
409-- PARSE ARGS
412data ArgError
413 = NoneOf [ArgError]
414 | MissingArg ParserInfo
415 | BadArg String ParserError
416 | ExtraArgs [String]
419parseArgs :: Args a -> [String] -> Either ArgError a
420parseArgs args_ chunks =
421 case args_ of
422 OneOf argsList ->
423 parseOneOf argsList chunks []
425 Exactly requiredArgs ->
426 do (value, extras) <- parseRequiredArgs requiredArgs chunks
427 case extras of
428 [] ->
429 Right value
431 _ : _ ->
432 Left (ExtraArgs extras)
434 Optional requiredArgs optionalParser ->
435 do (func, subChunks) <- parseRequiredArgs requiredArgs chunks
436 case subChunks of
437 [] ->
438 Right (func Nothing)
440 [chunk] ->
441 do value <- runArgParser optionalParser chunk
442 Right (func (Just value))
444 _ : extras ->
445 Left (ExtraArgs extras)
447 Multiple requiredArgs multiParser ->
448 do (func, extras) <- parseRequiredArgs requiredArgs chunks
449 values <- traverse (runArgParser multiParser) extras
450 Right (func values)
453parseOneOf :: [Args a] -> [String] -> [ArgError] -> Either ArgError a
454parseOneOf argsList chunks errors =
455 case argsList of
456 [] ->
457 Left (NoneOf (reverse errors))
459 args_ : rest ->
460 case parseArgs args_ chunks of
461 Left err ->
462 parseOneOf rest chunks (err:errors)
464 Right answer ->
465 Right answer
468parseRequiredArgs :: RequiredArgs a -> [String] -> Either ArgError (a, [String])
469parseRequiredArgs args_ chunks =
470 case args_ of
471 Done value ->
472 Right (value, chunks)
474 Required funcArgs parser ->
475 do (func, subChunks) <- parseRequiredArgs funcArgs chunks
476 case subChunks of
477 [] ->
478 Left (MissingArg (getParserInfo parser))
480 chunk : rest ->
481 do value <- runArgParser parser chunk
482 Right ( func value, rest )
485runArgParser :: Parser a -> String -> Either ArgError a
486runArgParser parser chunk =
487 case runParser parser chunk of
488 Left parserError ->
489 Left (BadArg chunk parserError)
491 Right value ->
492 Right value
496-- PARSE FLAGS
499type Result a =
500 Either FlagError (a, [String])
503data FlagError
504 = BadOnOff String String
505 | BadFlag String ParserInfo (Maybe (String, ParserError))
506 | Unrecognized String [(String, String)]
509parseFlags :: Flags a -> [String] -> Result a
510parseFlags flags_ chunks =
511 do (a, leftoverChunks) <- parseFlagsHelp flags_ chunks
512 case List.find (List.isPrefixOf "-") leftoverChunks of
513 Nothing ->
514 Right (a, leftoverChunks)
516 Just badArg ->
517 Left (Unrecognized badArg (collectFlagInfo flags_))
520parseFlagsHelp :: Flags a -> [String] -> Result a
521parseFlagsHelp flags_ chunks =
522 case flags_ of
523 FDone value ->
524 Right (value, chunks)
526 FMore makeFunc flag_ ->
527 do (func, remainingChunks) <- parseFlagsHelp makeFunc chunks
528 (arg, leftoverChunks) <- parseFlag flag_ remainingChunks
529 Right (func arg, leftoverChunks)
532parseFlag :: Flag a -> [String] -> Result a
533parseFlag flag_ chunks =
534 case flag_ of
535 Flag name parser _summary ->
536 parseFlagFlag name parser chunks
538 OnOff name _summary ->
539 parseFlagOnOff name chunks
542parseFlagFlag :: String -> Parser a -> [String] -> Result (Maybe a)
543parseFlagFlag name parser chunks =
544 case findDoubleDash [] ("--" ++ name) chunks of
545 Nothing ->
546 Right (Nothing, chunks)
548 Just (ChunkZipper before value after) ->
549 case value of
550 Definitely str ->
551 parseFlagFlagHelp name parser before str after
553 Possibly str ->
554 parseFlagFlagHelp name parser before str after
556 DefNope ->
557 Left (BadFlag name (getParserInfo parser) Nothing)
560parseFlagFlagHelp :: String -> Parser a -> [String] -> String -> [String] -> Result (Maybe a)
561parseFlagFlagHelp name parser before str after =
562 case runParser parser str of
563 Right value ->
564 Right (Just value, before ++ after)
566 Left parserError ->
567 Left $ BadFlag name (getParserInfo parser) $
568 Just (str, parserError)
571parseFlagOnOff :: String -> [String] -> Result Bool
572parseFlagOnOff name chunks =
573 case findDoubleDash [] ("--" ++ name) chunks of
574 Nothing ->
575 Right (False, chunks)
577 Just (ChunkZipper before value after) ->
578 case value of
579 DefNope ->
580 Right (True, before ++ after)
582 Possibly str ->
583 Right (True, before ++ str : after)
585 Definitely str ->
586 Left (BadOnOff name str)
590-- DOUBLE DASH
593data ChunkZipper =
594 ChunkZipper
595 { _before :: [String]
596 , _value :: Value
597 , _after :: [String]
598 }
601data Value
602 = Definitely String
603 | Possibly String
604 | DefNope
607findDoubleDash :: [String] -> String -> [String] -> Maybe ChunkZipper
608findDoubleDash revPrev prefix chunks =
609 case chunks of
610 flag_ : val : rest | flag_ == prefix ->
611 if List.isPrefixOf "-" val then
612 Just $ ChunkZipper (reverse revPrev) DefNope (val : rest)
613 else
614 Just $ ChunkZipper (reverse revPrev) (Possibly val) rest
616 [flag_] | flag_ == prefix ->
617 Just $ ChunkZipper (reverse revPrev) DefNope []
619 flag_ : rest | List.isPrefixOf (prefix ++ "=") flag_ ->
620 let
621 value =
622 drop (length prefix + 1) flag_
623 in
624 Just $ ChunkZipper (reverse revPrev) (Definitely value) rest
626 chunk : rest ->
627 findDoubleDash (chunk : revPrev) prefix rest
629 [] ->
630 Nothing
634-- COLLECT FLAG NAMES
637collectFlagInfo :: Flags a -> [(String, String)]
638collectFlagInfo flags_ =
639 collectFlagInfoHelp flags_ []
642collectFlagInfoHelp :: Flags a -> [(String, String)] -> [(String, String)]
643collectFlagInfoHelp flags_ info =
644 case flags_ of
645 FDone _ ->
646 reverse info
648 FMore otherFlags flag_ ->
649 collectFlagInfoHelp otherFlags (getFlagInfo flag_ : info)
652getFlagInfo :: Flag a -> (String, String)
653getFlagInfo flag_ =
654 case flag_ of
655 OnOff name summary ->
656 (name, summary)
658 Flag name _ summary ->
659 (name, summary)
663-- FAILURE
666failure :: Error -> IO a
667failure err =
668 do let doc = toDoc err
669 isTerminal <- hIsTerminalDevice stderr
670 displayIO stderr $ renderPretty 1 80 $
671 if isTerminal then doc else plain doc
672 hPutStrLn stderr ""
673 exitFailure
676toDoc :: Error -> Doc
677toDoc err =
678 case err of
679 BadCommand badName suggestions lastSuggestion ->
680 fillSep $
681 [ text "There is no"
682 , code badName
683 , text "command."
684 , text "Did you mean"
685 ]
686 ++ oxfordify (map code suggestions) "or" (code lastSuggestion <> text "?")
688 NoCommand (BadArgs argError) ->
689 argErrorToDoc Nothing argError
691 NoCommand (BadFlags flagError) ->
692 flagErrorToDoc Nothing flagError
694 AfterCommand name (BadArgs argError) ->
695 argErrorToDoc (Just name) argError
697 AfterCommand name (BadFlags flagError) ->
698 flagErrorToDoc (Just name) flagError
702-- ARG FAILURE
705argErrorToDoc :: Maybe String -> ArgError -> Doc
706argErrorToDoc maybeCommand argError =
707 case argError of
708 NoneOf argErrors ->
709 text $ "TODO - " ++ show (map (argErrorToDoc maybeCommand) argErrors)
711 MissingArg (ParserInfo tipe) ->
712 text $ "TODO - " ++ tipe
714 BadArg chunk _parserError ->
715 text $ "TODO - " ++ chunk
717 ExtraArgs extraChunks ->
718 text $ "TODO - " ++ show extraChunks
722-- FLAG FAILURE
725flagErrorToDoc :: Maybe String -> FlagError -> Doc
726flagErrorToDoc maybeCommand flagError =
727 case flagError of
728 BadOnOff name value ->
729 let
730 chunk =
731 "--" ++ name ++ "=" ++ value
732 in
733 if null value then
734 flagErrorToDocHelp "This on/off flag has a trailing equals sign:" chunk
735 [ fillSep
736 [ text "Just get rid of the equals sign, like this:"
737 , green (text ("--" ++ name))
738 ]
739 ]
741 else
742 flagErrorToDocHelp "This on/off flag was given a value:" chunk
743 [ text "An on/off flag either exists or not, no need for an equals sign and value."
744 , text "Maybe you want this instead?"
745 , text ""
746 , text " " <> green (text ("--" ++ name))
747 , text ""
748 ]
750 BadFlag name (ParserInfo tipe) Nothing ->
751 flagErrorToDocHelp
752 "This flag cannot appear without a value:"
753 ("--" ++ name)
754 [ text $ "It needs a " ++ tipe ++ " value."
755 ]
757 BadFlag name (ParserInfo tipe) (Just (value, parserError)) ->
758 flagErrorToDocHelp
759 "This flag was given a bad value:"
760 ("--" ++ name ++ "=" ++ value)
761 [ fillSep $ map text $ words $
762 "I need a " ++ tipe ++ " value, but "
763 ++
764 case parserError of
765 Expecting expectedType ->
766 value ++ " is not a valid " ++ expectedType ++ "."
767 ]
769 Unrecognized chunk [] ->
770 let
771 explanation =
772 case maybeCommand of
773 Nothing ->
774 "I am not expecting any flags."
776 Just command ->
777 "The `" ++ command ++ "` command does not expect any flags."
778 in
779 flagErrorToDocHelp "Get rid of this flag:" chunk $
780 [ fillSep (map text (words explanation))
781 ]
783 Unrecognized chunk info ->
784 case takeWhile ('=' /=) (dropWhile ('-' ==) chunk) of
785 "" ->
786 flagErrorToDocHelp "This is not a valid flag:" chunk
787 [ text "Valid flags look like --output=FILE"
788 ]
790 name ->
791 let
792 suggestions =
793 nearbyNames id name (map fst info)
794 in
795 flagErrorToDocHelp "I do not recognize this flag:" chunk $
796 unrecognizedExplanation $
797 if null suggestions then map fst info else suggestions
800flagErrorToDocHelp :: String -> String -> [Doc] -> Doc
801flagErrorToDocHelp summary original explanation =
802 vcat $
803 [ text summary
804 , text ""
805 , text " " <> red (text original)
806 , text ""
807 ]
808 ++ explanation
811unrecognizedExplanation :: [String] -> [Doc]
812unrecognizedExplanation suggestions =
813 let
814 toBullet name =
815 text " " <> green (text ("--" ++ name))
816 in
817 case suggestions of
818 [] ->
819 []
821 [suggestion] ->
822 [ text "Looks like a typo. Maybe you want:"
823 , text ""
824 , toBullet suggestion
825 , text ""
826 ]
828 _ ->
829 [ text "Maybe you want one of these?"
830 , text ""
831 ]
832 ++ map toBullet suggestions
833 ++ [ text "" ]
836code :: String -> Doc
837code str =
838 red (text str)
841oxfordify :: [Doc] -> String -> Doc -> [Doc]
842oxfordify chunks conjuction lastChunk =
843 case chunks of
844 [] ->
845 [ lastChunk ]
847 [chunk] ->
848 [ chunk, text conjuction, lastChunk ]
850 _ ->
851 map (<> comma) chunks ++ [ text conjuction, lastChunk ]