git.iko.soy/elk
on master help sign in
Implement Terminal.Args to by nicer / have autocomplete support
2cd952bEvan Czaplicki
ui/terminal/src/CommandLine/Args.hsdeleted−163
compare with master
unifiedsplit
@@ -1,163 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module CommandLine.Args
3− ( chomp
4− , ElmRoute(..)
5− , DevFlags(..)
6− , MakeFlags(..)
7− , ReplFlags(..)
8− )
9− where
10−
11−
12−import CommandLine.Args.Internal as Args
13−import qualified Data.Text as Text
14−import qualified Elm.Diff as Diff
15−import qualified Elm.Package as Pkg
16−import qualified Elm.Project.Flags as Flags
17−import qualified System.FilePath as FP
18−
19−
20−
21−-- ROUTE
22−
23−
24−data ElmRoute
25− = Naked () ()
26− | Version () ()
27− | Install Pkg.Name ()
28− | Publish () ()
29− | Make [FilePath] MakeFlags
30− | Bump () ()
31− | Diff Diff.Args ()
32− | Repl () ReplFlags
33− | Dev () DevFlags
34−
35−
36−chomp :: IO ElmRoute
37−chomp =
38− get
39− (Route Naked noArgs noFlags)
40− [ "version" ==> Route Version noArgs noFlags
41− , "install" ==> Route Install (required package) noFlags
42− , "publish" ==> Route Publish noArgs noFlags
43− , "make" ==> Route Make (zeroOrMore file) makeFlags
44− , "bump" ==> Route Bump noArgs noFlags
45− , "diff" ==> Route Diff diffArgs noFlags
46− , "repl" ==> Route Repl noArgs replFlags
47− , "reactor" ==> Route Dev noArgs devFlags
48− ]
49−
50−
51−(==>) :: a -> b -> (a, b)
52−(==>) =
53− (,)
54−
55−
56−
57−-- MAKE
58−
59−
60−data MakeFlags =
61− MakeFlags
62− { _warn :: Bool
63− , _debug :: Bool
64− , _output :: Maybe Flags.Output
65−-- , _server :: Bool
66− }
67−
68−
69−makeFlags :: Flags MakeFlags
70−makeFlags =
71− flags MakeFlags
72− |-- onOff "warn" "Report warnings to improve code quality."
73− |-- onOff "debug" "Generate programs in debug mode."
74− |-- flag "output" output "Specify the name of the resulting JS file (use --output=/dev/null for no output)"
75−-- |-- onOff "server" "Generate JS for server-side rendering."
76−
77−
78−output :: Parser Flags.Output
79−output =
80− custom "PATH" $ \string ->
81− if string == "/dev/null" then
82− Just Flags.None
83−
84− else
85− case FP.splitPath string of
86− [] ->
87− Nothing
88−
89− [name] ->
90− outputCustom Nothing name
91−
92− segments ->
93− outputCustom (Just (FP.joinPath (init segments))) (last segments)
94−
95−
96−outputCustom :: Maybe FilePath -> FilePath -> Maybe Flags.Output
97−outputCustom maybeDir fileName =
98− if FP.takeExtension fileName == ".js" then
99− Just (Flags.Custom maybeDir fileName)
100− else
101− Nothing
102−
103−
104−
105−-- REPL
106−
107−
108−data ReplFlags =
109− ReplFlags
110− { _interpreter :: Maybe FilePath
111− }
112−
113−
114−replFlags :: Flags ReplFlags
115−replFlags =
116− flags ReplFlags
117− |-- flag "interpreter" (anything "EXE") "Path to a alternate JS interpreter, like node or nodejs."
118−
119−
120−
121−-- DEVELOP
122−
123−
124−data DevFlags =
125− DevFlags
126− { _port :: Maybe Int
127− }
128−
129−
130−devFlags :: Flags DevFlags
131−devFlags =
132− flags DevFlags
133− |-- flag "port" (int "PORT") "The port of the server (default: 8000)"
134−
135−
136−
137−-- DIFF
138−
139−
140−diffArgs :: Args Diff.Args
141−diffArgs =
142− oneOf
143− [ require0 Diff.CodeVsLatest
144− , require1 Diff.CodeVsExactly version
145− , require2 Diff.LocalInquiry version version
146− , require3 Diff.GlobalInquiry package version version
147− ]
148−
149−
150−package :: Parser Pkg.Name
151−package =
152− custom "USER/PROJECT" $ \string ->
153− case Pkg.fromText (Text.pack string) of
154− Left _ ->
155− Nothing
156−
157− Right a ->
158− Just a
159−
160−
161−version :: Parser Pkg.Version
162−version =
163− custom "VERSION" (Pkg.versionFromText . Text.pack)
ui/terminal/src/CommandLine/Args/Internal.hsdeleted−846
@@ -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 ]
ui/terminal/src/Terminal/Args.hsnew file+301
@@ -0,0 +1,301 @@
1+module Terminal.Args
2+ ( simple
3+ , Interface(..)
4+ , Summary(..)
5+ , Details(..)
6+ , complex
7+ , Flags, noFlags, flags, (|--)
8+ , Flag, flag, onOff
9+ , Parser(..), suggestFiles
10+ , Args, noArgs, required, optional, zeroOrMore, oneOrMore, oneOf
11+ , require0, require1, require2, require3, require4, require5
12+ , RequiredArgs, args, exactly, (!), (?), (...)
13+ )
14+ where
15+
16+
17+import Control.Monad (filterM)
18+import qualified Data.Char as Char
19+import qualified Data.List as List
20+import qualified System.Directory as Dir
21+import qualified System.Environment as Env
22+import qualified System.Exit as Exit
23+import qualified System.FilePath as FP
24+import System.FilePath ((</>))
25+import System.IO (hPutStrLn, stdout)
26+import qualified Text.PrettyPrint.ANSI.Leijen as P
27+
28+import Terminal.Args.Internal
29+import qualified Terminal.Args.Chomp as Chomp
30+import qualified Terminal.Args.Error as Error
31+
32+
33+
34+-- GET
35+
36+
37+simple :: String -> Args args -> Flags flags -> (args -> flags -> IO ()) -> IO ()
38+simple details args_ flags_ callback =
39+ do argStrings <- Env.getArgs
40+ case argStrings of
41+ "<autocomplete>" : number : chunks ->
42+ attemptAutoComplete number $ \index ->
43+ fst $ Chomp.chomp (Just index) chunks args_ flags_
44+
45+ chunks ->
46+ if elem "--help" chunks then
47+ Error.exitWithHelp Nothing details args_ flags_
48+
49+ else
50+ case snd $ Chomp.chomp Nothing chunks args_ flags_ of
51+ Right (argsValue, flagValue) ->
52+ callback argsValue flagValue
53+
54+ Left err ->
55+ Error.exitWithError Nothing err
56+
57+
58+complex :: P.Doc -> P.Doc -> [Interface] -> IO ()
59+complex intro outro interfaces =
60+ do argStrings <- Env.getArgs
61+ case argStrings of
62+ [] ->
63+ Error.exitWithOverview intro outro interfaces
64+
65+ "<autocomplete>" : number : chunks ->
66+ attemptAutoComplete number $ \index ->
67+ complexSuggest index chunks interfaces
68+
69+ command : chunks ->
70+ case List.find (\iface -> toName iface == command) interfaces of
71+ Nothing ->
72+ Error.exitWithUnknown command (map toName interfaces)
73+
74+ Just (Interface _ _ (Details details) args_ flags_ callback) ->
75+ if elem "--help" chunks then
76+ Error.exitWithHelp (Just command) details args_ flags_
77+
78+ else
79+ case snd $ Chomp.chomp Nothing chunks args_ flags_ of
80+ Right (argsValue, flagValue) ->
81+ callback argsValue flagValue
82+
83+ Left err ->
84+ Error.exitWithError (Just command) err
85+
86+
87+
88+-- AUTO-COMPLETE
89+
90+
91+attemptAutoComplete :: String -> (Int -> IO [String]) -> IO a
92+attemptAutoComplete number getSuggestions =
93+ if all Char.isDigit number then
94+ do suggestions <- getSuggestions (read number)
95+ hPutStrLn stdout (List.intercalate " " suggestions)
96+ Exit.exitSuccess
97+ else
98+ Exit.exitFailure
99+
100+
101+complexSuggest :: Int -> [String] -> [Interface] -> IO [String]
102+complexSuggest index strings interfaces =
103+ case strings of
104+ [] ->
105+ return (map toName interfaces)
106+
107+ command : chunks ->
108+ case List.find (\iface -> toName iface == command) interfaces of
109+ Nothing ->
110+ return (map toName interfaces)
111+
112+ Just (Interface _ _ _ args_ flags_ _) ->
113+ fst $ Chomp.chomp (Just (index-1)) chunks args_ flags_
114+
115+
116+
117+-- FLAGS
118+
119+
120+{-|-}
121+noFlags :: Flags ()
122+noFlags =
123+ FDone ()
124+
125+
126+{-|-}
127+flags :: a -> Flags a
128+flags =
129+ FDone
130+
131+
132+{-|-}
133+(|--) :: Flags (a -> b) -> Flag a -> Flags b
134+(|--) =
135+ FMore
136+
137+
138+
139+-- FLAG
140+
141+
142+{-|-}
143+flag :: String -> Parser a -> String -> Flag (Maybe a)
144+flag =
145+ Flag
146+
147+
148+{-|-}
149+onOff :: String -> String -> Flag Bool
150+onOff =
151+ OnOff
152+
153+
154+
155+-- FANCY ARGS
156+
157+
158+{-|-}
159+args :: a -> RequiredArgs a
160+args =
161+ Done
162+
163+
164+{-|-}
165+exactly :: RequiredArgs a -> Args a
166+exactly requiredArgs =
167+ Args [Exactly requiredArgs]
168+
169+
170+{-|-}
171+(!) :: RequiredArgs (a -> b) -> Parser a -> RequiredArgs b
172+(!) =
173+ Required
174+
175+
176+{-|-}
177+(?) :: RequiredArgs (Maybe a -> b) -> Parser a -> Args b
178+(?) requiredArgs optionalArg =
179+ Args [Optional requiredArgs optionalArg]
180+
181+
182+{-|-}
183+(...) :: RequiredArgs ([a] -> b) -> Parser a -> Args b
184+(...) requiredArgs repeatedArg =
185+ Args [Multiple requiredArgs repeatedArg]
186+
187+
188+{-|-}
189+oneOf :: [Args a] -> Args a
190+oneOf listOfArgs =
191+ Args (concatMap (\(Args a) -> a) listOfArgs)
192+
193+
194+
195+-- SIMPLE ARGS
196+
197+
198+{-|-}
199+noArgs :: Args ()
200+noArgs =
201+ exactly (args ())
202+
203+
204+{-|-}
205+required :: Parser a -> Args a
206+required parser =
207+ require1 id parser
208+
209+
210+{-|-}
211+optional :: Parser a -> Args (Maybe a)
212+optional parser =
213+ args id ? parser
214+
215+
216+{-|-}
217+zeroOrMore :: Parser a -> Args [a]
218+zeroOrMore parser =
219+ args id ... parser
220+
221+
222+{-|-}
223+oneOrMore :: Parser a -> Args (a, [a])
224+oneOrMore parser =
225+ args (,) ! parser ... parser
226+
227+
228+{-|-}
229+require0 :: args -> Args args
230+require0 value =
231+ exactly (args value)
232+
233+
234+{-|-}
235+require1 :: (a -> args) -> Parser a -> Args args
236+require1 func a =
237+ exactly (args func ! a)
238+
239+
240+{-|-}
241+require2 :: (a -> b -> args) -> Parser a -> Parser b -> Args args
242+require2 func a b =
243+ exactly (args func ! a ! b)
244+
245+
246+{-|-}
247+require3 :: (a -> b -> c -> args) -> Parser a -> Parser b -> Parser c -> Args args
248+require3 func a b c =
249+ exactly (args func ! a ! b ! c)
250+
251+
252+{-|-}
253+require4 :: (a -> b -> c -> d -> args) -> Parser a -> Parser b -> Parser c -> Parser d -> Args args
254+require4 func a b c d =
255+ exactly (args func ! a ! b ! c ! d)
256+
257+
258+{-|-}
259+require5 :: (a -> b -> c -> d -> e -> args) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e -> Args args
260+require5 func a b c d e =
261+ exactly (args func ! a ! b ! c ! d ! e)
262+
263+
264+
265+-- SUGGEST FILES
266+
267+
268+{-| Helper for creating custom `Parser` values. It will suggest directories and
269+file names:
270+
271+ suggestFiles [] -- suggests any file
272+ suggestFiles ["elm"] -- suggests only .elm files
273+ suggestFiles ["js","html"] -- suggests only .js and .html files
274+
275+Notice that you can limit the suggestion by the file extension! If you need
276+something more elaborate, you can implement a function like this yourself that
277+does whatever you need!
278+-}
279+suggestFiles :: [String] -> String -> IO [String]
280+suggestFiles extensions string =
281+ let
282+ (dir, start) =
283+ FP.splitFileName string
284+ in
285+ do content <- Dir.getDirectoryContents dir
286+ filterM (isPossibleSuggestion extensions start dir) content
287+
288+
289+isPossibleSuggestion :: [String] -> String -> FilePath -> FilePath -> IO Bool
290+isPossibleSuggestion extensions start dir path =
291+ if List.isPrefixOf start path then
292+ do isDir <- Dir.doesDirectoryExist (dir </> path)
293+ return (isDir || isOkayExtension path extensions)
294+ else
295+ return False
296+
297+
298+isOkayExtension :: FilePath -> [String] -> Bool
299+isOkayExtension path extensions =
300+ null extensions || elem (FP.takeExtension path) extensions
301+
ui/terminal/src/Terminal/Args/Chomp.hsnew file+515
@@ -0,0 +1,515 @@
1+{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE Rank2Types #-}
3+module Terminal.Args.Chomp
4+ ( chomp
5+ )
6+ where
7+
8+
9+import qualified Data.List as List
10+
11+import Terminal.Args.Error
12+import Terminal.Args.Internal
13+
14+
15+
16+-- CHOMP INTERFACE
17+
18+
19+chomp :: Maybe Int -> [String] -> Args args -> Flags flags -> ( IO [String], Either Error (args, flags) )
20+chomp maybeIndex strings args flags =
21+ let
22+ (Chomper flagChomper) =
23+ chompFlags flags
24+
25+ ok suggest chunks flagValue =
26+ fmap (flip (,) flagValue) <$> chompArgs suggest chunks args
27+
28+ err suggest flagError =
29+ ( addSuggest (return []) suggest, Left (BadFlag flagError) )
30+ in
31+ flagChomper (toSuggest maybeIndex) (toChunks strings) ok err
32+
33+
34+toChunks :: [String] -> [Chunk]
35+toChunks strings =
36+ zipWith Chunk [ 1 .. length strings ] strings
37+
38+
39+toSuggest :: Maybe Int -> Suggest
40+toSuggest maybeIndex =
41+ case maybeIndex of
42+ Nothing ->
43+ NoSuggestion
44+
45+ Just index ->
46+ Suggest index
47+
48+
49+
50+-- CHOMPER
51+
52+
53+newtype Chomper x a =
54+ Chomper (
55+ forall result.
56+ Suggest
57+ -> [Chunk]
58+ -> (Suggest -> [Chunk] -> a -> result)
59+ -> (Suggest -> x -> result)
60+ -> result
61+ )
62+
63+
64+data Chunk =
65+ Chunk
66+ { _index :: Int
67+ , _chunk :: String
68+ }
69+
70+
71+data Suggest
72+ = NoSuggestion
73+ | Suggest Int
74+ | Suggestions (IO [String])
75+
76+
77+makeSuggestion :: Suggest -> (Int -> Maybe (IO [String])) -> Suggest
78+makeSuggestion suggest maybeUpdate =
79+ case suggest of
80+ NoSuggestion ->
81+ suggest
82+
83+ Suggestions _ ->
84+ suggest
85+
86+ Suggest index ->
87+ maybe suggest Suggestions (maybeUpdate index)
88+
89+
90+
91+-- ARGS
92+
93+
94+chompArgs :: Suggest -> [Chunk] -> Args a -> (IO [String], Either Error a)
95+chompArgs suggest chunks (Args completeArgsList) =
96+ chompArgsHelp suggest chunks completeArgsList [] []
97+
98+
99+chompArgsHelp :: Suggest -> [Chunk] -> [CompleteArgs a] -> [Suggest] -> [(CompleteArgs a, ArgError)] -> (IO [String], Either Error a)
100+chompArgsHelp suggest chunks completeArgsList revSuggest revArgErrors =
101+ case completeArgsList of
102+ [] ->
103+ ( foldl addSuggest (return []) revSuggest
104+ , Left (BadArgs (reverse revArgErrors))
105+ )
106+
107+ completeArgs : others ->
108+ case chompCompleteArgs suggest chunks completeArgs of
109+ (s1, Left argError) ->
110+ chompArgsHelp suggest chunks others (s1:revSuggest) ((completeArgs,argError):revArgErrors)
111+
112+ (s1, Right value) ->
113+ ( addSuggest (return []) s1
114+ , Right value
115+ )
116+
117+
118+addSuggest :: IO [String] -> Suggest -> IO [String]
119+addSuggest everything suggest =
120+ case suggest of
121+ NoSuggestion ->
122+ everything
123+
124+ Suggest _ ->
125+ everything
126+
127+ Suggestions newStuff ->
128+ (++) <$> newStuff <*> everything
129+
130+
131+
132+-- COMPLETE ARGS
133+
134+
135+chompCompleteArgs :: Suggest -> [Chunk] -> CompleteArgs a -> (Suggest, Either ArgError a)
136+chompCompleteArgs suggest chunks completeArgs =
137+ let
138+ numChunks = length chunks
139+ in
140+ case completeArgs of
141+ Exactly requiredArgs ->
142+ chompExactly suggest chunks (chompRequiredArgs numChunks requiredArgs)
143+
144+ Optional requiredArgs parser ->
145+ chompOptional suggest chunks (chompRequiredArgs numChunks requiredArgs) parser
146+
147+ Multiple requiredArgs parser ->
148+ chompMultiple suggest chunks (chompRequiredArgs numChunks requiredArgs) parser
149+
150+
151+chompExactly :: Suggest -> [Chunk] -> Chomper ArgError a -> (Suggest, Either ArgError a)
152+chompExactly suggest chunks (Chomper chomper) =
153+ let
154+ ok s cs value =
155+ case map _chunk cs of
156+ [] -> (s, Right value)
157+ es -> (s, Left (ArgExtras es))
158+
159+ err s argError =
160+ (s, Left argError)
161+ in
162+ chomper suggest chunks ok err
163+
164+
165+chompOptional :: Suggest -> [Chunk] -> Chomper ArgError (Maybe a -> b) -> Parser a -> (Suggest, Either ArgError b)
166+chompOptional suggest chunks (Chomper chomper) parser =
167+ let
168+ ok s1 cs func =
169+ case cs of
170+ [] ->
171+ (s1, Right (func Nothing))
172+
173+ Chunk index string : others ->
174+ case tryToParse s1 parser index string of
175+ (s2, Left expectation) ->
176+ (s2, Left (ArgBad string expectation))
177+
178+ (s2, Right value) ->
179+ case map _chunk others of
180+ [] -> (s2, Right (func (Just value)))
181+ es -> (s2, Left (ArgExtras es))
182+
183+ err s1 argError =
184+ (s1, Left argError)
185+ in
186+ chomper suggest chunks ok err
187+
188+
189+chompMultiple :: Suggest -> [Chunk] -> Chomper ArgError ([a] -> b) -> Parser a -> (Suggest, Either ArgError b)
190+chompMultiple suggest chunks (Chomper chomper) parser =
191+ let
192+ err s1 argError =
193+ (s1, Left argError)
194+ in
195+ chomper suggest chunks (chompMultipleHelp parser []) err
196+
197+
198+chompMultipleHelp :: Parser a -> [a] -> Suggest -> [Chunk] -> ([a] -> b) -> (Suggest, Either ArgError b)
199+chompMultipleHelp parser revArgs suggest chunks func =
200+ case chunks of
201+ [] ->
202+ (suggest, Right (func (reverse revArgs)))
203+
204+ Chunk index string : otherChunks ->
205+ case tryToParse suggest parser index string of
206+ (s1, Left expectation) ->
207+ (s1, Left (ArgBad string expectation))
208+
209+ (s1, Right arg) ->
210+ chompMultipleHelp parser (arg:revArgs) s1 otherChunks func
211+
212+
213+
214+-- REQUIRED ARGS
215+
216+
217+chompRequiredArgs :: Int -> RequiredArgs a -> Chomper ArgError a
218+chompRequiredArgs numChunks args =
219+ case args of
220+ Done value ->
221+ return value
222+
223+ Required funcArgs argParser ->
224+ do func <- chompRequiredArgs numChunks funcArgs
225+ arg <- chompArg numChunks argParser
226+ return (func arg)
227+
228+
229+chompArg :: Int -> Parser a -> Chomper ArgError a
230+chompArg numChunks parser@(Parser singular _ _ _ toExamples) =
231+ Chomper $ \suggest chunks ok err ->
232+ case chunks of
233+ [] ->
234+ let
235+ newSuggest = makeSuggestion suggest (suggestArg parser numChunks)
236+ theError = ArgMissing (Expectation singular (toExamples ""))
237+ in
238+ err newSuggest theError
239+
240+ Chunk index string : otherChunks ->
241+ case tryToParse suggest parser index string of
242+ (newSuggest, Left expectation) ->
243+ err newSuggest (ArgBad string expectation)
244+
245+ (newSuggest, Right arg) ->
246+ ok newSuggest otherChunks arg
247+
248+
249+suggestArg :: Parser a -> Int -> Int -> Maybe (IO [String])
250+suggestArg (Parser _ _ _ toSuggestions _) numChunks targetIndex =
251+ if numChunks <= targetIndex then
252+ Just (toSuggestions "")
253+ else
254+ Nothing
255+
256+
257+
258+-- PARSER
259+
260+
261+tryToParse :: Suggest -> Parser a -> Int -> String -> (Suggest, Either Expectation a)
262+tryToParse suggest (Parser singular _ parse toSuggestions toExamples) index string =
263+ let
264+ newSuggest =
265+ makeSuggestion suggest $ \targetIndex ->
266+ if index == targetIndex then Just (toSuggestions string) else Nothing
267+
268+ outcome =
269+ case parse string of
270+ Nothing ->
271+ Left (Expectation singular (toExamples string))
272+
273+ Just value ->
274+ Right value
275+ in
276+ (newSuggest, outcome)
277+
278+
279+
280+-- FLAGS
281+
282+
283+chompFlags :: Flags a -> Chomper FlagError a
284+chompFlags flags =
285+ do value <- chompFlagsHelp flags
286+ checkForUnknownFlags flags
287+ return value
288+
289+
290+chompFlagsHelp :: Flags a -> Chomper FlagError a
291+chompFlagsHelp flags =
292+ case flags of
293+ FDone value ->
294+ return value
295+
296+ FMore funcFlags argFlag ->
297+ do func <- chompFlagsHelp funcFlags
298+ arg <- chompFlag argFlag
299+ return (func arg)
300+
301+
302+
303+-- FLAG
304+
305+
306+chompFlag :: Flag a -> Chomper FlagError a
307+chompFlag flag =
308+ case flag of
309+ OnOff flagName _ ->
310+ chompOnOffFlag flagName
311+
312+ Flag flagName parser _ ->
313+ chompNormalFlag flagName parser
314+
315+
316+chompOnOffFlag :: String -> Chomper FlagError Bool
317+chompOnOffFlag flagName =
318+ Chomper $ \suggest chunks ok err ->
319+ case findFlag flagName chunks of
320+ Nothing ->
321+ ok suggest chunks False
322+
323+ Just (FoundFlag before value after) ->
324+ case value of
325+ DefNope ->
326+ ok suggest (before ++ after) True
327+
328+ Possibly chunk ->
329+ ok suggest (before ++ chunk : after) True
330+
331+ Definitely _ string ->
332+ err suggest (FlagWithValue flagName string)
333+
334+
335+chompNormalFlag :: String -> Parser a -> Chomper FlagError (Maybe a)
336+chompNormalFlag flagName parser@(Parser singular _ _ _ toExamples) =
337+ Chomper $ \suggest chunks ok err ->
338+ case findFlag flagName chunks of
339+ Nothing ->
340+ ok suggest chunks Nothing
341+
342+ Just (FoundFlag before value after) ->
343+ let
344+ attempt index string =
345+ case tryToParse suggest parser index string of
346+ (newSuggest, Left expectation) ->
347+ err newSuggest (FlagWithBadValue flagName string expectation)
348+
349+ (newSuggest, Right flagValue) ->
350+ ok newSuggest (before ++ after) (Just flagValue)
351+ in
352+ case value of
353+ Definitely index string ->
354+ attempt index string
355+
356+ Possibly (Chunk index string) ->
357+ attempt index string
358+
359+ DefNope ->
360+ err suggest (FlagWithNoValue flagName (Expectation singular (toExamples "")))
361+
362+
363+
364+-- FIND FLAG
365+
366+
367+data FoundFlag =
368+ FoundFlag
369+ { _before :: [Chunk]
370+ , _value :: Value
371+ , _after :: [Chunk]
372+ }
373+
374+
375+data Value
376+ = Definitely Int String
377+ | Possibly Chunk
378+ | DefNope
379+
380+
381+findFlag :: String -> [Chunk] -> Maybe FoundFlag
382+findFlag flagName chunks =
383+ findFlagHelp [] ("--" ++ flagName) ("--" ++ flagName ++ "=") chunks
384+
385+
386+findFlagHelp :: [Chunk] -> String -> String -> [Chunk] -> Maybe FoundFlag
387+findFlagHelp revPrev loneFlag flagPrefix chunks =
388+ let
389+ succeed value after =
390+ Just (FoundFlag (reverse revPrev) value after)
391+
392+ deprefix string =
393+ drop (length flagPrefix) string
394+ in
395+ case chunks of
396+ [] ->
397+ Nothing
398+
399+ chunk@(Chunk index string) : rest ->
400+ if List.isPrefixOf flagPrefix string then
401+ succeed (Definitely index (deprefix string)) rest
402+
403+ else if string /= loneFlag then
404+ findFlagHelp (chunk:revPrev) loneFlag flagPrefix rest
405+
406+ else
407+ case rest of
408+ [] ->
409+ succeed DefNope []
410+
411+ argChunk@(Chunk _ potentialArg) : restOfRest ->
412+ if List.isPrefixOf "-" potentialArg then
413+ succeed DefNope rest
414+ else
415+ succeed (Possibly argChunk) restOfRest
416+
417+
418+
419+-- CHECK FOR UNKNOWN FLAGS
420+
421+
422+checkForUnknownFlags :: Flags a -> Chomper FlagError ()
423+checkForUnknownFlags flags =
424+ Chomper $ \suggest chunks ok err ->
425+ case filter startsWithDash chunks of
426+ [] ->
427+ ok suggest chunks ()
428+
429+ unknownFlags@(Chunk _ unknownFlag : _) ->
430+ err
431+ (makeSuggestion suggest (suggestFlag unknownFlags flags))
432+ (FlagUnknown unknownFlag flags)
433+
434+
435+suggestFlag :: [Chunk] -> Flags a -> Int -> Maybe (IO [String])
436+suggestFlag unknownFlags flags targetIndex =
437+ case unknownFlags of
438+ [] ->
439+ Nothing
440+
441+ Chunk index _ : otherUnknownFlags ->
442+ if index == targetIndex then
443+ Just (return (getFlagNames flags []))
444+ else
445+ suggestFlag otherUnknownFlags flags targetIndex
446+
447+
448+startsWithDash :: Chunk -> Bool
449+startsWithDash (Chunk _ string) =
450+ List.isPrefixOf "-" string
451+
452+
453+getFlagNames :: Flags a -> [String] -> [String]
454+getFlagNames flags names =
455+ case flags of
456+ FDone _ ->
457+ names
458+
459+ FMore subFlags flag ->
460+ getFlagNames subFlags (getFlagName flag : names)
461+
462+
463+getFlagName :: Flag a -> String
464+getFlagName flag =
465+ case flag of
466+ Flag name _ _ ->
467+ name
468+
469+ OnOff name _ ->
470+ name
471+
472+
473+
474+-- CHOMPER INSTANCES
475+
476+
477+instance Functor (Chomper x) where
478+ fmap func (Chomper chomper) =
479+ Chomper $ \i w ok err ->
480+ let
481+ ok1 s1 cs1 value =
482+ ok s1 cs1 (func value)
483+ in
484+ chomper i w ok1 err
485+
486+
487+instance Applicative (Chomper x) where
488+ pure value =
489+ Chomper $ \ss cs ok _ ->
490+ ok ss cs value
491+
492+ (<*>) (Chomper funcChomper) (Chomper argChomper) =
493+ Chomper $ \s cs ok err ->
494+ let
495+ ok1 s1 cs1 func =
496+ let
497+ ok2 s2 cs2 value =
498+ ok s2 cs2 (func value)
499+ in
500+ argChomper s1 cs1 ok2 err
501+ in
502+ funcChomper s cs ok1 err
503+
504+
505+instance Monad (Chomper x) where
506+ return = pure
507+
508+ (>>=) (Chomper aChomper) callback =
509+ Chomper $ \s cs ok err ->
510+ let
511+ ok1 s1 cs1 a =
512+ case callback a of
513+ Chomper bChomper -> bChomper s1 cs1 ok err
514+ in
515+ aChomper s cs ok1 err
ui/terminal/src/Terminal/Args/Error.hsnew file+449
@@ -0,0 +1,449 @@
1+{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Terminal.Args.Error
4+ ( Error(..)
5+ , ArgError(..)
6+ , FlagError(..)
7+ , Expectation(..)
8+ , exitWithHelp
9+ , exitWithError
10+ , exitWithUnknown
11+ , exitWithOverview
12+ )
13+ where
14+
15+
16+import Data.Monoid ((<>))
17+import qualified Data.List as List
18+import qualified Data.Maybe as Maybe
19+import GHC.IO.Handle (hIsTerminalDevice)
20+import qualified System.Environment as Env
21+import qualified System.Exit as Exit
22+import qualified System.FilePath as FP
23+import System.IO (stderr)
24+import qualified Text.PrettyPrint.ANSI.Leijen as P
25+
26+import Elm.Utils (nearbyNames, distance)
27+import Terminal.Args.Internal
28+
29+
30+
31+-- ERROR
32+
33+
34+data Error where
35+ BadArgs :: [(CompleteArgs a, ArgError)] -> Error
36+ BadFlag :: FlagError -> Error
37+
38+
39+data ArgError
40+ = ArgMissing Expectation
41+ | ArgBad String Expectation
42+ | ArgExtras [String]
43+
44+
45+data FlagError where
46+ FlagWithValue :: String -> String -> FlagError
47+ FlagWithBadValue :: String -> String -> Expectation -> FlagError
48+ FlagWithNoValue :: String -> Expectation -> FlagError
49+ FlagUnknown :: String -> Flags a -> FlagError
50+
51+
52+data Expectation =
53+ Expectation
54+ { _type :: String
55+ , _examples :: IO [String]
56+ }
57+
58+
59+
60+-- EXIT
61+
62+
63+exitSuccess :: [P.Doc] -> IO a
64+exitSuccess =
65+ exitWith Exit.ExitSuccess
66+
67+
68+exitFailure :: [P.Doc] -> IO a
69+exitFailure =
70+ exitWith (Exit.ExitFailure 1)
71+
72+
73+exitWith :: Exit.ExitCode -> [P.Doc] -> IO a
74+exitWith code docs =
75+ do isTerminal <- hIsTerminalDevice stderr
76+ let adjust = if isTerminal then id else P.plain
77+ P.displayIO stderr $ P.renderPretty 1 80 $
78+ adjust $ P.vcat $ concatMap (\d -> [d,""]) docs
79+ Exit.exitWith code
80+
81+
82+getExeName :: IO String
83+getExeName =
84+ FP.takeFileName <$> Env.getProgName
85+
86+
87+stack :: [P.Doc] -> P.Doc
88+stack docs =
89+ P.vcat $ List.intersperse "" docs
90+
91+
92+reflow :: String -> P.Doc
93+reflow string =
94+ P.fillSep $ map P.text $ words string
95+
96+
97+
98+-- HELP
99+
100+
101+exitWithHelp :: Maybe String -> String -> Args args -> Flags flags -> IO a
102+exitWithHelp maybeCommand details (Args args) flags =
103+ do command <- toCommand maybeCommand
104+ exitSuccess $
105+ [ reflow details
106+ , P.indent 4 $ P.dullcyan $ P.vcat $ map (argsToDoc command) args
107+ ]
108+ ++
109+ case flagsToDocs flags [] of
110+ [] ->
111+ []
112+
113+ docs@(_:_) ->
114+ [ "It also accepts the following flags to customize its behavior:"
115+ , P.indent 4 $ stack docs
116+ ]
117+
118+
119+toCommand :: Maybe String -> IO String
120+toCommand maybeCommand =
121+ do exeName <- getExeName
122+ return $
123+ case maybeCommand of
124+ Nothing ->
125+ exeName
126+
127+ Just command ->
128+ exeName ++ " " ++ command
129+
130+
131+argsToDoc :: String -> CompleteArgs a -> P.Doc
132+argsToDoc command args =
133+ case args of
134+ Exactly required ->
135+ argsToDocHelp command required []
136+
137+ Multiple required (Parser _ plural _ _ _) ->
138+ argsToDocHelp command required ["zero or more " ++ plural]
139+
140+ Optional required (Parser singular _ _ _ _) ->
141+ argsToDocHelp command required ["optional " ++ singular]
142+
143+
144+argsToDocHelp :: String -> RequiredArgs a -> [String] -> P.Doc
145+argsToDocHelp command args names =
146+ case args of
147+ Done _ ->
148+ P.hang 4 $ P.hsep $ map P.text $
149+ command : map toToken names
150+
151+ Required others (Parser singular _ _ _ _) ->
152+ argsToDocHelp command others (singular : names)
153+
154+
155+toToken :: String -> String
156+toToken string =
157+ "<" ++ map (\c -> if c == ' ' then '-' else c) string ++ ">"
158+
159+
160+flagsToDocs :: Flags flags -> [P.Doc] -> [P.Doc]
161+flagsToDocs flags docs =
162+ case flags of
163+ FDone _ ->
164+ docs
165+
166+ FMore more flag ->
167+ let
168+ flagDoc =
169+ P.vcat $
170+ case flag of
171+ Flag name (Parser singular _ _ _ _) description ->
172+ [ P.dullcyan $ P.text $ "--" ++ name ++ "=<" ++ singular ++ ">"
173+ , P.indent 4 $ reflow description
174+ ]
175+
176+ OnOff name description ->
177+ [ P.dullcyan $ P.text $ "--" ++ name
178+ , P.indent 4 $ reflow description
179+ ]
180+ in
181+ flagsToDocs more (flagDoc:docs)
182+
183+
184+
185+-- OVERVIEW
186+
187+
188+exitWithOverview :: P.Doc -> P.Doc -> [Interface] -> IO a
189+exitWithOverview intro outro interfaces =
190+ do exeName <- getExeName
191+ exitSuccess
192+ [ intro
193+ , "The most common commands are:"
194+ , P.indent 4 $ stack $ Maybe.mapMaybe (toSummary exeName) interfaces
195+ , "There are a bunch of other commands as well though. Here is a full list:"
196+ , P.indent 4 $ P.dullcyan $ toCommandList exeName interfaces
197+ , "Adding the --help flag gives a bunch of additional details about each one."
198+ , outro
199+ ]
200+
201+
202+toSummary :: String -> Interface -> Maybe P.Doc
203+toSummary exeName (Interface name summary _ _ _ _) =
204+ case summary of
205+ Uncommon ->
206+ Nothing
207+
208+ Common summaryString ->
209+ Just $
210+ P.vcat
211+ [ P.dullcyan $ P.text $ exeName ++ " " ++ name
212+ , P.indent 4 $ reflow summaryString
213+ ]
214+
215+
216+toCommandList :: String -> [Interface] -> P.Doc
217+toCommandList exeName interfaces =
218+ let
219+ names = map toName interfaces
220+ width = maximum (map length names)
221+
222+ toExample name =
223+ P.text $ exeName ++ " " ++ name ++ replicate (width - length name) ' ' ++ " --help"
224+ in
225+ P.vcat (map toExample names)
226+
227+
228+
229+-- UNKNOWN
230+
231+
232+exitWithUnknown :: String -> [String] -> IO a
233+exitWithUnknown unknown knowns =
234+ let
235+ suggestions =
236+ case map toGreen (nearbyNames id unknown knowns) of
237+ [] ->
238+ []
239+
240+ [nearby] ->
241+ ["Try",nearby,"instead?"]
242+
243+ [a,b] ->
244+ ["Try",a,"or",b,"instead?"]
245+
246+ abcs@(_:_:_:_) ->
247+ ["Try"] ++ map (<> ",") (init abcs) ++ ["or",last abcs,"instead?"]
248+ in
249+ do exeName <- getExeName
250+ exitFailure
251+ [ P.fillSep $ ["There","is","no",toRed unknown,"command."] ++ suggestions
252+ , reflow $ "Run `" ++ exeName ++ "` with no arguments to get more hints."
253+ ]
254+
255+
256+
257+-- ERROR TO DOC
258+
259+
260+exitWithError :: Maybe String -> Error -> IO a
261+exitWithError maybeCommand err =
262+ exitFailure =<<
263+ case err of
264+ BadFlag flagError ->
265+ flagErrorToDocs flagError
266+
267+ BadArgs argErrors ->
268+ case argErrors of
269+ [] ->
270+ error "TODO no possible args"
271+
272+ [(args, argError)] ->
273+ argErrorToDocs maybeCommand args argError
274+
275+ _:_:_ ->
276+ error "TODO show possible arg configurations"
277+
278+
279+toGreen :: String -> P.Doc
280+toGreen str =
281+ P.green (P.text str)
282+
283+
284+toYellow :: String -> P.Doc
285+toYellow str =
286+ P.yellow (P.text str)
287+
288+
289+toRed :: String -> P.Doc
290+toRed str =
291+ P.red (P.text str)
292+
293+
294+
295+-- ARG ERROR TO DOC
296+
297+
298+argErrorHelp :: Maybe String -> CompleteArgs a -> [P.Doc] -> IO [P.Doc]
299+argErrorHelp maybeCommand args details =
300+ do command <- toCommand maybeCommand
301+ return $
302+ [ "I was expecting arguments like this:"
303+ , P.indent 4 $ P.dullcyan $ argsToDoc command args
304+ ]
305+ ++ details
306+
307+
308+argErrorToDocs :: Maybe String -> CompleteArgs a -> ArgError -> IO [P.Doc]
309+argErrorToDocs maybeCommand args argError =
310+ argErrorHelp maybeCommand args =<<
311+ case argError of
312+ ArgMissing (Expectation tipe makeExamples) ->
313+ do examples <- makeExamples
314+ return
315+ [ P.fillSep
316+ ["Everything","you","have","is","fine,","but","in","addition,","I","was"
317+ ,"expecting","a",toYellow (toToken tipe),"value.","For","example:"
318+ ]
319+ , P.indent 4 $ P.green $ P.vcat $ map P.text examples
320+ ]
321+
322+ ArgBad string (Expectation tipe makeExamples) ->
323+ do examples <- makeExamples
324+ return
325+ [ "I am having trouble with this argument though:"
326+ , P.indent 4 $ toRed string
327+ , P.fillSep
328+ ["It","is","supposed","to","be","a"
329+ ,toYellow (toToken tipe),"value,","like","this:"
330+ ]
331+ , P.indent 4 $ P.green $ P.vcat $ map P.text examples
332+ ]
333+
334+ ArgExtras extras ->
335+ let
336+ (these, them) =
337+ case extras of
338+ [_] -> ("this extra argument", "it")
339+ _ -> ("these extra arguments", "them")
340+ in
341+ return
342+ [ reflow $ "That worked, but I did not know what to do with " ++ these ++ ":"
343+ , P.indent 4 $ P.red $ P.vcat $ map P.text extras
344+ , reflow $ "Try removing " ++ them ++ "?"
345+ ]
346+
347+
348+
349+-- FLAG ERROR TO DOC
350+
351+
352+flagErrorHelp :: String -> String -> [P.Doc] -> IO [P.Doc]
353+flagErrorHelp summary original explanation =
354+ return $
355+ [ reflow summary
356+ , P.indent 4 (toRed original)
357+ ]
358+ ++ explanation
359+
360+
361+flagErrorToDocs :: FlagError -> IO [P.Doc]
362+flagErrorToDocs flagError =
363+ case flagError of
364+ FlagWithValue flagName value ->
365+ flagErrorHelp
366+ "This on/off flag was given a value:"
367+ ("--" ++ flagName ++ "=" ++ value)
368+ [ "An on/off flag either exists or not. It cannot have an equals sign and value.\n\
369+ \Maybe you want this instead?"
370+ , P.indent 4 $ toGreen $ "--" ++ flagName
371+ ]
372+
373+ FlagWithNoValue flagName (Expectation tipe makeExamples) ->
374+ do examples <- makeExamples
375+ flagErrorHelp
376+ "This flag needs more information:"
377+ ("--" ++ flagName)
378+ [ P.fillSep ["It","needs","a",toYellow (toToken tipe),"like","this:"]
379+ , P.indent 4 $ P.vcat $ map toGreen $
380+ case take 4 examples of
381+ [] ->
382+ ["--" ++ flagName ++ "=" ++ toToken tipe]
383+
384+ _:_ ->
385+ map (\example -> "--" ++ flagName ++ "=" ++ example) examples
386+ ]
387+
388+ FlagWithBadValue flagName badValue (Expectation tipe makeExamples) ->
389+ do examples <- makeExamples
390+ flagErrorHelp
391+ "This flag was given a bad value:"
392+ ("--" ++ flagName ++ "=" ++ badValue)
393+ [ P.fillSep $
394+ ["I","need","a","valid",toYellow (toToken tipe),"value.","For","example:"
395+ ]
396+ , P.indent 4 $ P.vcat $ map toGreen $
397+ case take 4 examples of
398+ [] ->
399+ ["--" ++ flagName ++ "=" ++ toToken tipe]
400+
401+ _:_ ->
402+ map (\example -> "--" ++ flagName ++ "=" ++ example) examples
403+ ]
404+
405+ FlagUnknown unknown flags ->
406+ flagErrorHelp
407+ "I do not recognize this flag:"
408+ unknown
409+ (
410+ let unknownName = takeWhile ('=' /=) (dropWhile ('-' ==) unknown) in
411+ case getNearbyFlags unknownName flags [] of
412+ [] ->
413+ []
414+
415+ [thisOne] ->
416+ [ P.fillSep ["Maybe","you","want",P.green thisOne,"instead?"]
417+ ]
418+
419+ suggestions ->
420+ [ P.fillSep ["Maybe","you","want","one","of","these","instead?"]
421+ , P.indent 4 $ P.green $ P.vcat suggestions
422+ ]
423+ )
424+
425+
426+getNearbyFlags :: String -> Flags a -> [(Int, String)] -> [P.Doc]
427+getNearbyFlags unknown flags unsortedFlags =
428+ case flags of
429+ FMore more flag ->
430+ getNearbyFlags unknown more (getNearbyFlagsHelp unknown flag : unsortedFlags)
431+
432+ FDone _ ->
433+ map P.text $ map snd $ List.sortOn fst $
434+ case filter (\(d,_) -> d < 3) unsortedFlags of
435+ [] ->
436+ unsortedFlags
437+
438+ nearbyUnsortedFlags ->
439+ nearbyUnsortedFlags
440+
441+
442+getNearbyFlagsHelp :: String -> Flag a -> (Int, String)
443+getNearbyFlagsHelp unknown flag =
444+ case flag of
445+ OnOff flagName _ ->
446+ ( distance unknown flagName, "--" ++ flagName )
447+
448+ Flag flagName (Parser singular _ _ _ _) _ ->
449+ ( distance unknown flagName, "--" ++ flagName ++ "=" ++ toToken singular )
ui/terminal/src/Terminal/Args/Helpers.hsnew file+125
@@ -0,0 +1,125 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Terminal.Args.Helpers
3+ ( version
4+ , elmFile
5+ , package
6+ )
7+ where
8+
9+
10+import qualified Data.Char as Char
11+import qualified Data.Text as Text
12+import qualified System.FilePath as FP
13+
14+import Terminal.Args (Parser(..), suggestFiles)
15+import qualified Elm.Package as Pkg
16+
17+
18+
19+-- VERSION
20+
21+
22+version :: Parser Pkg.Version
23+version =
24+ Parser
25+ { _singular = "version"
26+ , _plural = "versions"
27+ , _parser = parseVersion
28+ , _suggest = suggestVersion
29+ , _examples = return . exampleVersions
30+ }
31+
32+
33+parseVersion :: String -> Maybe Pkg.Version
34+parseVersion str =
35+ Pkg.versionFromText (Text.pack str)
36+
37+
38+suggestVersion :: String -> IO [String]
39+suggestVersion _ =
40+ return []
41+
42+
43+exampleVersions :: String -> [String]
44+exampleVersions string =
45+ let
46+ chunks = map Text.unpack (Text.splitOn "." (Text.pack string))
47+ isNumber str = not (null str) && all Char.isDigit str
48+ in
49+ if all isNumber chunks then
50+ case chunks of
51+ [x] -> [ x ++ ".0.0" ]
52+ [x,y] -> [ x ++ "." ++ y ++ ".0" ]
53+ x:y:z:_ -> [ x ++ "." ++ y ++ "." ++ z ]
54+ _ -> ["1.0.0", "2.0.3"]
55+
56+ else
57+ ["1.0.0", "2.0.3"]
58+
59+
60+
61+-- ELM FILE
62+
63+
64+elmFile :: Parser FilePath
65+elmFile =
66+ Parser
67+ { _singular = "elm file"
68+ , _plural = "elm files"
69+ , _parser = parseElmFile
70+ , _suggest = suggestFiles ["elm"]
71+ , _examples = exampleElmFiles
72+ }
73+
74+
75+parseElmFile :: String -> Maybe FilePath
76+parseElmFile string =
77+ if FP.takeExtension string == "elm" then
78+ Just string
79+ else
80+ Nothing
81+
82+
83+exampleElmFiles :: String -> IO [String]
84+exampleElmFiles _ =
85+ return ["Main.elm","src/Main.elm"]
86+
87+
88+
89+-- PACKAGE
90+
91+
92+package :: Parser Pkg.Name
93+package =
94+ Parser
95+ { _singular = "package"
96+ , _plural = "packages"
97+ , _parser = parsePackage
98+ , _suggest = suggestPackages
99+ , _examples = examplePackages
100+ }
101+
102+
103+parsePackage :: String -> Maybe Pkg.Name
104+parsePackage string =
105+ either (const Nothing) Just $
106+ Pkg.fromText (Text.pack string)
107+
108+
109+suggestPackages :: String -> IO [String]
110+suggestPackages _ =
111+ return []
112+
113+
114+examplePackages :: String -> IO [String]
115+examplePackages string =
116+ case Pkg.fromText (Text.pack string) of
117+ Left (_, suggestions@(_:_)) ->
118+ return suggestions
119+
120+ _ ->
121+ return
122+ [ "elm-lang/http"
123+ , "elm-lang/json"
124+ , "elm-community/random-extra"
125+ ]
ui/terminal/src/Terminal/Args/Internal.hsnew file+96
@@ -0,0 +1,96 @@
1+{-# LANGUAGE GADTs #-}
2+module Terminal.Args.Internal
3+ ( Interface(..)
4+ , toName
5+ , Summary(..)
6+ , Details(..)
7+ , Flags(..)
8+ , Flag(..)
9+ , Parser(..)
10+ , Args(..)
11+ , CompleteArgs(..)
12+ , RequiredArgs(..)
13+ )
14+ where
15+
16+
17+
18+-- INTERFACE
19+
20+
21+data Interface where
22+ Interface
23+ :: String
24+ -> Summary
25+ -> Details
26+ -> Args args
27+ -> Flags flags
28+ -> (args -> flags -> IO ())
29+ -> Interface
30+
31+
32+toName :: Interface -> String
33+toName (Interface name _ _ _ _ _) =
34+ name
35+
36+
37+
38+{-| The information that shows when you run the executable with no arguments.
39+If you say it is `Common`, you need to tell people what it does. Try to keep
40+it to two or three lines. If you say it is `Uncommon` you can rely on `Details`
41+for a more complete explanation.
42+-}
43+data Summary = Common String | Uncommon
44+
45+
46+{-| When you run `elm command --help` this is the first thing people will read.
47+Say what the command does.
48+-}
49+newtype Details = Details String
50+
51+
52+
53+-- FLAGS
54+
55+
56+data Flags a where
57+ FDone :: a -> Flags a
58+ FMore :: Flags (a -> b) -> Flag a -> Flags b
59+
60+
61+data Flag a where
62+ Flag :: String -> Parser a -> String -> Flag (Maybe a)
63+ OnOff :: String -> String -> Flag Bool
64+
65+
66+
67+-- PARSERS
68+
69+
70+data Parser a =
71+ Parser
72+ { _singular :: String
73+ , _plural :: String
74+ , _parser :: String -> Maybe a
75+ , _suggest :: String -> IO [String]
76+ , _examples :: String -> IO [String]
77+ }
78+
79+
80+
81+-- ARGS
82+
83+
84+newtype Args a =
85+ Args [CompleteArgs a]
86+
87+
88+data CompleteArgs args where
89+ Exactly :: RequiredArgs args -> CompleteArgs args
90+ Multiple :: RequiredArgs ([a] -> args) -> Parser a -> CompleteArgs args
91+ Optional :: RequiredArgs (Maybe a -> args) -> Parser a -> CompleteArgs args
92+
93+
94+data RequiredArgs a where
95+ Done :: a -> RequiredArgs a
96+ Required :: RequiredArgs (a -> b) -> Parser a -> RequiredArgs b