@@ -0,0 +1,851 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE GADTs #-}
3+module 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
14+
15+import qualified Data.Char as Char
16+import qualified Data.List as List
17+import GHC.IO.Handle (hIsTerminalDevice)
18+import System.Environment (getArgs)
19+import System.Exit (exitFailure)
20+import System.IO (hPutStrLn, stderr)
21+import Text.PrettyPrint.ANSI.Leijen
22+ ( Doc, (<>), comma, displayIO, fillSep, green
23+ , plain, red, renderPretty, text, vcat
24+ )
25+
26+import Elm.Utils (nearbyNames)
27+
28+
29+
30+-- ROUTE
31+
32+
33+data Route a where
34+ Route :: (args -> flags -> a) -> Args args -> Flags flags -> Route a
35+
36+
37+
38+-- FLAGS
39+
40+
41+data Flags a where
42+ FDone :: a -> Flags a
43+ FMore :: Flags (a -> b) -> Flag a -> Flags b
44+
45+
46+noFlags :: Flags ()
47+noFlags =
48+ FDone ()
49+
50+
51+flags :: a -> Flags a
52+flags =
53+ FDone
54+
55+
56+(|--) :: Flags (a -> b) -> Flag a -> Flags b
57+(|--) =
58+ FMore
59+
60+
61+
62+-- FLAG
63+
64+
65+data Flag a where
66+ Flag :: String -> Parser a -> String -> Flag (Maybe a)
67+ OnOff :: String -> String -> Flag Bool
68+
69+
70+flag :: String -> Parser a -> String -> Flag (Maybe a)
71+flag =
72+ Flag
73+
74+
75+onOff :: String -> String -> Flag Bool
76+onOff =
77+ OnOff
78+
79+
80+
81+-- PARSERS
82+
83+
84+data 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
89+
90+
91+file :: Parser FilePath
92+file =
93+ File
94+
95+
96+int :: String -> Parser Int
97+int =
98+ Int
99+
100+
101+anything :: String -> Parser String
102+anything =
103+ Anything
104+
105+
106+custom :: String -> (String -> Maybe a) -> Parser a
107+custom =
108+ Custom
109+
110+
111+data ParserInfo =
112+ ParserInfo
113+ { _type :: String
114+ }
115+
116+
117+getParserInfo :: Parser a -> ParserInfo
118+getParserInfo parser =
119+ case parser of
120+ Anything tipe ->
121+ ParserInfo tipe
122+
123+ File ->
124+ ParserInfo "FILE"
125+
126+ Int tipe ->
127+ ParserInfo tipe
128+
129+ Custom tipe _ ->
130+ ParserInfo tipe
131+
132+
133+runParser :: Parser a -> String -> Either ParserError a
134+runParser parser str =
135+ case parser of
136+ Anything _ ->
137+ Right str
138+
139+ File ->
140+ Right str
141+
142+ Int tipe ->
143+ if all Char.isDigit str then
144+ Right (read str :: Int)
145+ else
146+ Left (Expecting tipe)
147+
148+ Custom tipe toMaybe ->
149+ case toMaybe str of
150+ Nothing ->
151+ Left (Expecting tipe)
152+
153+ Just a ->
154+ Right a
155+
156+
157+data ParserError = Expecting String
158+
159+
160+
161+-- ARGS
162+
163+
164+noArgs :: Args ()
165+noArgs =
166+ exactly (args ())
167+
168+
169+required :: Parser a -> Args a
170+required parser =
171+ require1 id parser
172+
173+
174+optional :: Parser a -> Args (Maybe a)
175+optional parser =
176+ args id
177+ ? parser
178+
179+
180+zeroOrMore :: Parser a -> Args [a]
181+zeroOrMore parser =
182+ args id
183+ ... parser
184+
185+
186+oneOrMore :: Parser a -> Args (a, [a])
187+oneOrMore parser =
188+ args (,)
189+ ! parser
190+ ... parser
191+
192+
193+require0 :: args -> Args args
194+require0 value =
195+ exactly (args value)
196+
197+
198+require1 :: (a -> args) -> Parser a -> Args args
199+require1 func a =
200+ exactly (
201+ args func
202+ ! a
203+ )
204+
205+
206+require2 :: (a -> b -> args) -> Parser a -> Parser b -> Args args
207+require2 func a b =
208+ exactly (
209+ args func
210+ ! a
211+ ! b
212+ )
213+
214+
215+require3 :: (a -> b -> c -> args) -> Parser a -> Parser b -> Parser c -> Args args
216+require3 func a b c =
217+ exactly (
218+ args func
219+ ! a
220+ ! b
221+ ! c
222+ )
223+
224+
225+require4 :: (a -> b -> c -> d -> args) -> Parser a -> Parser b -> Parser c -> Parser d -> Args args
226+require4 func a b c d =
227+ exactly (
228+ args func
229+ ! a
230+ ! b
231+ ! c
232+ ! d
233+ )
234+
235+
236+require5 :: (a -> b -> c -> d -> e -> args) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e -> Args args
237+require5 func a b c d e =
238+ exactly (
239+ args func
240+ ! a
241+ ! b
242+ ! c
243+ ! d
244+ ! e
245+ )
246+
247+
248+oneOf :: [Args a] -> Args a
249+oneOf =
250+ OneOf
251+
252+
253+
254+-- FANCE ARGS
255+
256+
257+data RequiredArgs a where
258+ Done :: a -> RequiredArgs a
259+ Required :: RequiredArgs (a -> b) -> Parser a -> RequiredArgs b
260+
261+
262+data 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
267+
268+
269+args :: a -> RequiredArgs a
270+args =
271+ Done
272+
273+
274+exactly :: RequiredArgs a -> Args a
275+exactly =
276+ Exactly
277+
278+
279+(!) :: RequiredArgs (a -> b) -> Parser a -> RequiredArgs b
280+(!) =
281+ Required
282+
283+
284+(?) :: RequiredArgs (Maybe a -> b) -> Parser a -> Args b
285+(?) =
286+ Optional
287+
288+
289+(...) :: RequiredArgs ([a] -> b) -> Parser a -> Args b
290+(...) =
291+ Multiple
292+
293+
294+
295+-- GET
296+
297+
298+get :: Route a -> [(String, Route a)] -> IO a
299+get route namedRoutes =
300+ do chunks <- getArgs
301+ case parse route namedRoutes chunks of
302+ Right flagsAndArgs ->
303+ return flagsAndArgs
304+
305+ Left err ->
306+ failure err
307+
308+
309+
310+-- PARSE
311+
312+
313+data Error
314+ = AfterCommand String RouteError
315+ | BadCommand String [String] String
316+ | NoCommand RouteError
317+
318+
319+parse :: Route a -> [(String, Route a)] -> [String] -> Either Error a
320+parse route namedRoutes chunks =
321+ case parseHelp namedRoutes chunks [] of
322+ Right answer ->
323+ Right answer
324+
325+ Left errors ->
326+ case parseRoute route chunks of
327+ Right answer ->
328+ Right answer
329+
330+ Left routeError ->
331+ case errors of
332+ (name, specificRouteError) : _ ->
333+ Left (AfterCommand name specificRouteError)
334+
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)
341+
342+ suggestions ->
343+ Left (BadCommand first (init suggestions) (last suggestions))
344+
345+ _ ->
346+ Left (NoCommand routeError)
347+
348+
349+parseHelp :: [(String, Route a)] -> [String] -> RouteErrors -> Either RouteErrors a
350+parseHelp namedRoutes chunks errors =
351+ case namedRoutes of
352+ [] ->
353+ Left errors
354+
355+ (name, route) : rest ->
356+ case parseNamedRoute name route chunks of
357+ Left errs ->
358+ parseHelp rest chunks (errs ++ errors)
359+
360+ Right answer ->
361+ Right answer
362+
363+
364+
365+-- PARSE NAMED ROUTE
366+
367+
368+type RouteErrors = [(String, RouteError)]
369+
370+
371+parseNamedRoute :: String -> Route a -> [String] -> Either RouteErrors a
372+parseNamedRoute name route rawChunks =
373+ case rawChunks of
374+ first : chunks | name == first ->
375+ case parseRoute route chunks of
376+ Right answer ->
377+ Right answer
378+
379+ Left err ->
380+ Left [(name, err)]
381+
382+ _ ->
383+ Left []
384+
385+
386+
387+-- PARSE ROUTE
388+
389+
390+data RouteError = BadFlags FlagError | BadArgs ArgError
391+
392+
393+parseRoute :: Route a -> [String] -> Either RouteError a
394+parseRoute (Route func args_ flags_) chunks =
395+ case parseFlags flags_ chunks of
396+ Left flagError ->
397+ Left (BadFlags flagError)
398+
399+ Right (flagData, remainingChunks) ->
400+ case parseArgs args_ remainingChunks of
401+ Left argError ->
402+ Left (BadArgs argError)
403+
404+ Right argData ->
405+ Right (func argData flagData)
406+
407+
408+
409+-- PARSE ARGS
410+
411+
412+data ArgError
413+ = NoneOf [ArgError]
414+ | MissingArg ParserInfo
415+ | BadArg String ParserError
416+ | ExtraArgs [String]
417+
418+
419+parseArgs :: Args a -> [String] -> Either ArgError a
420+parseArgs args_ chunks =
421+ case args_ of
422+ OneOf argsList ->
423+ parseOneOf argsList chunks []
424+
425+ Exactly requiredArgs ->
426+ do (value, extras) <- parseRequiredArgs requiredArgs chunks
427+ case extras of
428+ [] ->
429+ Right value
430+
431+ _ : _ ->
432+ Left (ExtraArgs extras)
433+
434+ Optional requiredArgs optionalParser ->
435+ do (func, subChunks) <- parseRequiredArgs requiredArgs chunks
436+ case subChunks of
437+ [] ->
438+ Right (func Nothing)
439+
440+ [chunk] ->
441+ do value <- runArgParser optionalParser chunk
442+ Right (func (Just value))
443+
444+ _ : extras ->
445+ Left (ExtraArgs extras)
446+
447+ Multiple requiredArgs multiParser ->
448+ do (func, extras) <- parseRequiredArgs requiredArgs chunks
449+ values <- traverse (runArgParser multiParser) extras
450+ Right (func values)
451+
452+
453+parseOneOf :: [Args a] -> [String] -> [ArgError] -> Either ArgError a
454+parseOneOf argsList chunks errors =
455+ case argsList of
456+ [] ->
457+ Left (NoneOf (reverse errors))
458+
459+ args_ : rest ->
460+ case parseArgs args_ chunks of
461+ Left err ->
462+ parseOneOf rest chunks (err:errors)
463+
464+ Right answer ->
465+ Right answer
466+
467+
468+parseRequiredArgs :: RequiredArgs a -> [String] -> Either ArgError (a, [String])
469+parseRequiredArgs args_ chunks =
470+ case args_ of
471+ Done value ->
472+ Right (value, chunks)
473+
474+ Required funcArgs parser ->
475+ do (func, subChunks) <- parseRequiredArgs funcArgs chunks
476+ case subChunks of
477+ [] ->
478+ Left (MissingArg (getParserInfo parser))
479+
480+ chunk : rest ->
481+ do value <- runArgParser parser chunk
482+ Right ( func value, rest )
483+
484+
485+runArgParser :: Parser a -> String -> Either ArgError a
486+runArgParser parser chunk =
487+ case runParser parser chunk of
488+ Left parserError ->
489+ Left (BadArg chunk parserError)
490+
491+ Right value ->
492+ Right value
493+
494+
495+
496+-- PARSE FLAGS
497+
498+
499+type Result a =
500+ Either FlagError (a, [String])
501+
502+
503+data FlagError
504+ = BadOnOff String String
505+ | BadFlag String ParserInfo (Maybe (String, ParserError))
506+ | Unrecognized String [(String, String)]
507+
508+
509+parseFlags :: Flags a -> [String] -> Result a
510+parseFlags flags_ chunks =
511+ do (a, leftoverChunks) <- parseFlagsHelp flags_ chunks
512+ case List.find (List.isPrefixOf "-") leftoverChunks of
513+ Nothing ->
514+ Right (a, leftoverChunks)
515+
516+ Just badArg ->
517+ Left (Unrecognized badArg (collectFlagInfo flags_))
518+
519+
520+parseFlagsHelp :: Flags a -> [String] -> Result a
521+parseFlagsHelp flags_ chunks =
522+ case flags_ of
523+ FDone value ->
524+ Right (value, chunks)
525+
526+ FMore makeFunc flag_ ->
527+ do (func, remainingChunks) <- parseFlagsHelp makeFunc chunks
528+ (arg, leftoverChunks) <- parseFlag flag_ remainingChunks
529+ Right (func arg, leftoverChunks)
530+
531+
532+parseFlag :: Flag a -> [String] -> Result a
533+parseFlag flag_ chunks =
534+ case flag_ of
535+ Flag name parser _summary ->
536+ parseFlagFlag name parser chunks
537+
538+ OnOff name _summary ->
539+ parseFlagOnOff name chunks
540+
541+
542+parseFlagFlag :: String -> Parser a -> [String] -> Result (Maybe a)
543+parseFlagFlag name parser chunks =
544+ case findDoubleDash [] ("--" ++ name) chunks of
545+ Nothing ->
546+ Right (Nothing, chunks)
547+
548+ Just (ChunkZipper before value after) ->
549+ case value of
550+ Definitely str ->
551+ parseFlagFlagHelp name parser before str after
552+
553+ Possibly str ->
554+ parseFlagFlagHelp name parser before str after
555+
556+ DefNope ->
557+ Left (BadFlag name (getParserInfo parser) Nothing)
558+
559+
560+parseFlagFlagHelp :: String -> Parser a -> [String] -> String -> [String] -> Result (Maybe a)
561+parseFlagFlagHelp name parser before str after =
562+ case runParser parser str of
563+ Right value ->
564+ Right (Just value, before ++ after)
565+
566+ Left parserError ->
567+ Left $ BadFlag name (getParserInfo parser) $
568+ Just (str, parserError)
569+
570+
571+parseFlagOnOff :: String -> [String] -> Result Bool
572+parseFlagOnOff name chunks =
573+ case findDoubleDash [] ("--" ++ name) chunks of
574+ Nothing ->
575+ Right (False, chunks)
576+
577+ Just (ChunkZipper before value after) ->
578+ case value of
579+ DefNope ->
580+ Right (True, before ++ after)
581+
582+ Possibly str ->
583+ Right (True, before ++ str : after)
584+
585+ Definitely str ->
586+ Left (BadOnOff name str)
587+
588+
589+
590+-- DOUBLE DASH
591+
592+
593+data ChunkZipper =
594+ ChunkZipper
595+ { _before :: [String]
596+ , _value :: Value
597+ , _after :: [String]
598+ }
599+
600+
601+data Value
602+ = Definitely String
603+ | Possibly String
604+ | DefNope
605+
606+
607+findDoubleDash :: [String] -> String -> [String] -> Maybe ChunkZipper
608+findDoubleDash 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
615+
616+ [flag_] | flag_ == prefix ->
617+ Just $ ChunkZipper (reverse revPrev) DefNope []
618+
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
625+
626+ chunk : rest ->
627+ findDoubleDash (chunk : revPrev) prefix rest
628+
629+ [] ->
630+ Nothing
631+
632+
633+
634+-- COLLECT FLAG NAMES
635+
636+
637+collectFlagInfo :: Flags a -> [(String, String)]
638+collectFlagInfo flags_ =
639+ collectFlagInfoHelp flags_ []
640+
641+
642+collectFlagInfoHelp :: Flags a -> [(String, String)] -> [(String, String)]
643+collectFlagInfoHelp flags_ info =
644+ case flags_ of
645+ FDone _ ->
646+ reverse info
647+
648+ FMore otherFlags flag_ ->
649+ collectFlagInfoHelp otherFlags (getFlagInfo flag_ : info)
650+
651+
652+getFlagInfo :: Flag a -> (String, String)
653+getFlagInfo flag_ =
654+ case flag_ of
655+ OnOff name summary ->
656+ (name, summary)
657+
658+ Flag name _ summary ->
659+ (name, summary)
660+
661+
662+
663+-- FAILURE
664+
665+
666+failure :: Error -> IO a
667+failure 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
674+
675+
676+toDoc :: Error -> Doc
677+toDoc 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 "?")
687+
688+ NoCommand (BadArgs argError) ->
689+ argErrorToDoc Nothing argError
690+
691+ NoCommand (BadFlags flagError) ->
692+ flagErrorToDoc Nothing flagError
693+
694+ AfterCommand name (BadArgs argError) ->
695+ argErrorToDoc (Just name) argError
696+
697+ AfterCommand name (BadFlags flagError) ->
698+ flagErrorToDoc (Just name) flagError
699+
700+
701+
702+-- ARG FAILURE
703+
704+
705+argErrorToDoc :: Maybe String -> ArgError -> Doc
706+argErrorToDoc maybeCommand argError =
707+ case argError of
708+ NoneOf argErrors ->
709+ text $ "TODO - " ++ show (map (argErrorToDoc maybeCommand) argErrors)
710+
711+ MissingArg (ParserInfo tipe) ->
712+ text $ "TODO - " ++ tipe
713+
714+ BadArg chunk _parserError ->
715+ text $ "TODO - " ++ chunk
716+
717+ ExtraArgs extraChunks ->
718+ text $ "TODO - " ++ show extraChunks
719+
720+
721+
722+-- FLAG FAILURE
723+
724+
725+flagErrorToDoc :: Maybe String -> FlagError -> Doc
726+flagErrorToDoc 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+ ]
740+
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+ ]
749+
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+ ]
756+
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+ ]
768+
769+ Unrecognized chunk [] ->
770+ let
771+ explanation =
772+ case maybeCommand of
773+ Nothing ->
774+ "I am not expecting any flags."
775+
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+ ]
782+
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+ ]
789+
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
798+
799+
800+flagErrorToDocHelp :: String -> String -> [Doc] -> Doc
801+flagErrorToDocHelp summary original explanation =
802+ vcat $
803+ [ text summary
804+ , text ""
805+ , text " " <> red (text original)
806+ , text ""
807+ ]
808+ ++ explanation
809+
810+
811+unrecognizedExplanation :: [String] -> [Doc]
812+unrecognizedExplanation suggestions =
813+ let
814+ toBullet name =
815+ text " " <> green (text ("--" ++ name))
816+ in
817+ case suggestions of
818+ [] ->
819+ []
820+
821+ [suggestion] ->
822+ [ text "Looks like a typo. Maybe you want:"
823+ , text ""
824+ , toBullet suggestion
825+ , text ""
826+ ]
827+
828+ _ ->
829+ [ text "Maybe you want one of these?"
830+ , text ""
831+ ]
832+ ++ map toBullet suggestions
833+ ++ [ text "" ]
834+
835+
836+code :: String -> Doc
837+code str =
838+ red (text str)
839+
840+
841+oxfordify :: [Doc] -> String -> Doc -> [Doc]
842+oxfordify chunks conjuction lastChunk =
843+ case chunks of
844+ [] ->
845+ [ lastChunk ]
846+
847+ [chunk] ->
848+ [ chunk, text conjuction, lastChunk ]
849+
850+ _ ->
851+ map (<> comma) chunks ++ [ text conjuction, lastChunk ]