1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
|
{-# LANGUAGE RecordWildCards #-}
module System.Console.CmdArgs.Explicit.Process(process) where
import System.Console.CmdArgs.Explicit.Type
import Control.Arrow
import Data.List
import Data.Maybe
-- | Process a list of flags (usually obtained from @getArgs@/@expandArgsAt@) with a mode. Returns
-- @Left@ and an error message if the command line fails to parse, or @Right@ and
-- the associated value.
process :: Mode a -> [String] -> Either String a
process = processMode
processMode :: Mode a -> [String] -> Either String a
processMode m args =
case find of
Ambiguous xs -> Left $ ambiguous "mode" a xs
Found x -> processMode x as
NotFound
| null (fst $ modeArgs m) && isNothing (snd $ modeArgs m) && args /= [] &&
not (null $ modeModes m) && not ("-" `isPrefixOf` concat args)
-> Left $ missing "mode" $ concatMap modeNames $ modeModes m
| otherwise -> either Left (modeCheck m) $ processFlags m (modeValue m) args
where
(find,a,as) = case args of
[] -> (NotFound,"",[])
x:xs -> (lookupName (map (modeNames &&& id) $ modeModes m) x, x, xs)
data S a = S
{val :: a -- The value you are accumulating
,args :: [String] -- The arguments you are processing through
,argsCount :: Int -- The number of unnamed arguments you have seen
,errs :: [String] -- The errors you have seen
}
stop :: Mode a -> S a -> Maybe (Either String a)
stop mode S{..}
| not $ null errs = Just $ Left $ last errs
| null args = Just $ if argsCount >= mn then Right val else
Left $ "Expected " ++ (if Just mn == mx then "exactly" else "at least") ++ show mn ++ " unnamed arguments, but got only " ++ show argsCount
| otherwise = Nothing
where (mn, mx) = argsRange mode
err :: S a -> String -> S a
err s x = s{errs=x:errs s}
upd :: S a -> (a -> Either String a) -> S a
upd s f = case f $ val s of
Left x -> err s x
Right x -> s{val=x}
processFlags :: Mode a -> a -> [String] -> Either String a
processFlags mode val_ args_ = f $ S val_ args_ 0 []
where f s = fromMaybe (f $ processFlag mode s) $ stop mode s
pickFlags long mode = [(filter (\x -> (length x > 1) == long) $ flagNames flag,(flagInfo flag,flag)) | flag <- modeFlags mode]
processFlag :: Mode a -> S a -> S a
processFlag mode s_@S{args=('-':'-':xs):ys} | xs /= "" =
case lookupName (pickFlags True mode) a of
Ambiguous poss -> err s $ ambiguous "flag" ("--" ++ a) poss
NotFound -> err s $ "Unknown flag: --" ++ a
Found (arg,flag) -> case arg of
FlagNone | null b -> upd s $ flagValue flag ""
| otherwise -> err s $ "Unhandled argument to flag, none expected: --" ++ xs
FlagReq | null b && null ys -> err s $ "Flag requires argument: --" ++ xs
| null b -> upd s{args=tail ys} $ flagValue flag $ head ys
| otherwise -> upd s $ flagValue flag $ tail b
_ | null b -> upd s $ flagValue flag $ fromFlagOpt arg
| otherwise -> upd s $ flagValue flag $ tail b
where
s = s_{args=ys}
(a,b) = break (== '=') xs
processFlag mode s_@S{args=('-':x:xs):ys} | x /= '-' =
case lookupName (pickFlags False mode) [x] of
Ambiguous poss -> err s $ ambiguous "flag" ['-',x] poss
NotFound -> err s $ "Unknown flag: -" ++ [x]
Found (arg,flag) -> case arg of
FlagNone | "=" `isPrefixOf` xs -> err s $ "Unhandled argument to flag, none expected: -" ++ [x]
| otherwise -> upd s_{args=['-':xs|xs/=""] ++ ys} $ flagValue flag ""
FlagReq | null xs && null ys -> err s $ "Flag requires argument: -" ++ [x]
| null xs -> upd s_{args=tail ys} $ flagValue flag $ head ys
| otherwise -> upd s_{args=ys} $ flagValue flag $ if "=" `isPrefixOf` xs then tail xs else xs
FlagOpt x | null xs -> upd s_{args=ys} $ flagValue flag x
| otherwise -> upd s_{args=ys} $ flagValue flag $ if "=" `isPrefixOf` xs then tail xs else xs
FlagOptRare x | "=" `isPrefixOf` xs -> upd s_{args=ys} $ flagValue flag $ tail xs
| otherwise -> upd s_{args=['-':xs|xs/=""] ++ ys} $ flagValue flag x
where
s = s_{args=ys}
processFlag mode s_@S{args="--":ys} = f s_{args=ys}
where f s | isJust $ stop mode s = s
| otherwise = f $ processArg mode s
processFlag mode s = processArg mode s
processArg mode s_@S{args=x:ys, argsCount=count} = case argsPick mode count of
Nothing -> err s $ "Unhandled argument, " ++ str ++ " expected: " ++ x
where str = if count == 0 then "none" else "at most " ++ show count
Just arg -> case argValue arg x (val s) of
Left e -> err s $ "Unhandled argument, " ++ e ++ ": " ++ x
Right v -> s{val=v}
where
s = s_{args=ys, argsCount=count+1}
-- find the minimum and maximum allowed number of arguments (Nothing=infinite)
argsRange :: Mode a -> (Int, Maybe Int)
argsRange Mode{modeArgs=(lst,end)} = (mn,mx)
where mn = length $ dropWhile (not . argRequire) $ reverse $ lst ++ maybeToList end
mx = if isJust end then Nothing else Just $ length lst
argsPick :: Mode a -> Int -> Maybe (Arg a)
argsPick Mode{modeArgs=(lst,end)} i = if i < length lst then Just $ lst !! i else end
---------------------------------------------------------------------
-- UTILITIES
ambiguous typ got xs = "Ambiguous " ++ typ ++ " '" ++ got ++ "', could be any of: " ++ unwords xs
missing typ xs = "Missing " ++ typ ++ ", wanted any of: " ++ unwords xs
data LookupName a = NotFound
| Ambiguous [Name]
| Found a
-- different order to lookup so can potentially partially-apply it
lookupName :: [([Name],a)] -> Name -> LookupName a
lookupName names value =
case (match (==), match isPrefixOf) of
([],[]) -> NotFound
([],[x]) -> Found $ snd x
([],xs) -> Ambiguous $ map fst xs
([x],_) -> Found $ snd x
(xs,_) -> Ambiguous $ map fst xs
where
match op = [(head ys,v) | (xs,v) <- names, let ys = filter (op value) xs, ys /= []]
|
