{-# 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 /= []]