@@ -1,846 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE GADTs #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−module CommandLine.Args.Internal
5− ( get
6− , Flags, noFlags, flags, (|--)
7− , Flag, flag, onOff
8− , Parser, int, file, anything, custom
9− , Args, noArgs, required, optional, zeroOrMore, oneOrMore, oneOf
10− , require0, require1, require2, require3, require4, require5
11− , RequiredArgs, args, exactly, (!), (?), (...)
12− , Route(..)
13− )
14− where
15−
16−
17−import Data.Monoid ((<>))
18−import qualified Data.Char as Char
19−import qualified Data.List as List
20−import GHC.IO.Handle (hIsTerminalDevice)
21−import System.Environment (getArgs)
22−import System.Exit (exitFailure)
23−import System.IO (hPutStrLn, stderr)
24−import qualified Text.PrettyPrint.ANSI.Leijen as P
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− P.displayIO stderr $ P.renderPretty 1 80 $
671− if isTerminal then doc else P.plain doc
672− hPutStrLn stderr ""
673− exitFailure
674−
675−
676−toDoc :: Error -> P.Doc
677−toDoc err =
678− case err of
679− BadCommand badName suggestions lastSuggestion ->
680− P.fillSep $
681− ["There","is","no",toRed badName,"command.","Try"
682− ]
683− ++ oxfordify (map toGreen suggestions) "or" (toGreen lastSuggestion)
684− ++ ["instead?"]
685−
686− NoCommand (BadArgs argError) ->
687− argErrorToDoc Nothing argError
688−
689− NoCommand (BadFlags flagError) ->
690− flagErrorToDoc Nothing flagError
691−
692− AfterCommand name (BadArgs argError) ->
693− argErrorToDoc (Just name) argError
694−
695− AfterCommand name (BadFlags flagError) ->
696− flagErrorToDoc (Just name) flagError
697−
698−
699−toRed :: String -> P.Doc
700−toRed str =
701− P.red (P.text str)
702−
703−
704−toGreen :: String -> P.Doc
705−toGreen str =
706− P.green (P.text str)
707−
708−
709−
710−-- ARG FAILURE
711−
712−
713−argErrorToDoc :: Maybe String -> ArgError -> P.Doc
714−argErrorToDoc maybeCommand argError =
715− case argError of
716− NoneOf argErrors ->
717− P.text $ "TODO - " ++ show (map (argErrorToDoc maybeCommand) argErrors)
718−
719− MissingArg (ParserInfo tipe) ->
720− P.text $ "TODO - " ++ tipe
721−
722− BadArg chunk _parserError ->
723− P.text $ "TODO - " ++ chunk
724−
725− ExtraArgs extraChunks ->
726− P.text $ "TODO - " ++ show extraChunks
727−
728−
729−
730−-- FLAG FAILURE
731−
732−
733−flagErrorToDoc :: Maybe String -> FlagError -> P.Doc
734−flagErrorToDoc maybeCommand flagError =
735− case flagError of
736− BadOnOff name value ->
737− let
738− chunk =
739− "--" ++ name ++ "=" ++ value
740− in
741− if null value then
742− flagErrorToDocHelp
743− "This on/off flag has a trailing equals sign:"
744− chunk
745− [ P.fillSep
746− ["Just","get","rid","of","the","equals","sign,","like","this:"
747− , toGreen ("--" ++ name)
748− ]
749− ]
750−
751− else
752− flagErrorToDocHelp
753− "This on/off flag was given a value:"
754− chunk
755− [ "An on/off flag either exists or not, no need for an equals sign and value.\n\
756− \Maybe you want this instead?"
757− , P.indent 4 (toGreen ("--" ++ name))
758− ]
759−
760− BadFlag name (ParserInfo tipe) Nothing ->
761− flagErrorToDocHelp
762− "This flag cannot appear without a value:"
763− ("--" ++ name)
764− [ P.fillSep ["It","needs","a",toGreen tipe,"value."]
765− ]
766−
767− BadFlag name (ParserInfo tipe) (Just (value, parserError)) ->
768− flagErrorToDocHelp
769− "This flag was given a bad value:"
770− ("--" ++ name ++ "=" ++ value)
771− [ P.fillSep $
772− ["I","need","a",toGreen tipe,"value,","but"
773− ]
774− ++
775− case parserError of
776− Expecting expectedType ->
777− [P.text value,"is","not","a","valid",P.text expectedType <> "."]
778− ]
779−
780− Unrecognized chunk [] ->
781− flagErrorToDocHelp
782− "Get rid of this flag:"
783− chunk
784− [ P.fillSep $ map P.text $ words $
785− case maybeCommand of
786− Nothing ->
787− "I am not expecting any flags."
788−
789− Just command ->
790− "The `" ++ command ++ "` command does not expect any flags."
791− ]
792−
793− Unrecognized chunk info ->
794− case takeWhile ('=' /=) (dropWhile ('-' ==) chunk) of
795− "" ->
796− flagErrorToDocHelp
797− "This is not a valid flag:"
798− chunk
799− [ P.fillSep ["Valid","flags","look","like",P.green "--output=FILE"]
800− ]
801−
802− name ->
803− let
804− closeNames = nearbyNames id name (map fst info)
805− suggestions = if null closeNames then map fst info else closeNames
806− toFlag str = toGreen ("--" ++ str)
807− in
808− flagErrorToDocHelp
809− "I do not recognize this flag:"
810− chunk
811− (
812− case suggestions of
813− [] ->
814− []
815−
816− [suggestion] ->
817− [ P.fillSep ["Looks","like","a","typo.","Maybe","you","want",toFlag suggestion,"instead?"]
818− ]
819−
820− _ ->
821− [ P.fillSep ["Maybe","you","want","one","of","these","instead?"]
822− , P.indent 4 (P.vcat (map toFlag suggestions))
823− ]
824− )
825−
826−
827−flagErrorToDocHelp :: String -> String -> [P.Doc] -> P.Doc
828−flagErrorToDocHelp summary original explanation =
829− P.vcat $ concatMap (\d -> [d,""]) $
830− [ P.fillSep (map P.text (words summary))
831− , P.indent 4 (toRed original)
832− ]
833− ++ explanation
834−
835−
836−oxfordify :: [P.Doc] -> String -> P.Doc -> [P.Doc]
837−oxfordify chunks conjuction lastChunk =
838− case chunks of
839− [] ->
840− [ lastChunk ]
841−
842− [chunk] ->
843− [ chunk, P.text conjuction, lastChunk ]
844−
845− _ ->
846− map (<> P.comma) chunks ++ [ P.text conjuction, lastChunk ]