{-# 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 :: forall a. Mode a -> [String] -> Either String a
process = forall a. Mode a -> [String] -> Either String a
processMode


processMode :: Mode a -> [String] -> Either String a
processMode :: forall a. Mode a -> [String] -> Either String a
processMode Mode a
m [String]
args =
    case LookupName (Mode a)
find of
        Ambiguous [String]
xs -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> String -> [String] -> String
ambiguous String
"mode" String
a [String]
xs
        Found Mode a
x -> forall a. Mode a -> [String] -> Either String a
processMode Mode a
x [String]
as
        LookupName (Mode a)
NotFound
            | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. Mode a -> ([Arg a], Maybe (Arg a))
modeArgs Mode a
m) Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing (forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. Mode a -> ([Arg a], Maybe (Arg a))
modeArgs Mode a
m) Bool -> Bool -> Bool
&& [String]
args forall a. Eq a => a -> a -> Bool
/= [] Bool -> Bool -> Bool
&&
              Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ forall a. Mode a -> [Mode a]
modeModes Mode a
m) Bool -> Bool -> Bool
&& Bool -> Bool
not (String
"-" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
args)
                -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
missing String
"mode" forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Mode a -> [String]
modeNames forall a b. (a -> b) -> a -> b
$ forall a. Mode a -> [Mode a]
modeModes Mode a
m
            | Bool
otherwise -> forall a. Mode a -> a -> Either String a
modeCheck Mode a
m forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Mode a -> a -> [String] -> Either String a
processFlags Mode a
m (forall a. Mode a -> a
modeValue Mode a
m) [String]
args
    where
        (LookupName (Mode a)
find,String
a,[String]
as) = case [String]
args of
            [] -> (forall a. LookupName a
NotFound,String
"",[])
            String
x:[String]
xs -> (forall a. [([String], a)] -> String -> LookupName a
lookupName (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Mode a -> [String]
modeNames forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$ forall a. Mode a -> [Mode a]
modeModes Mode a
m) String
x, String
x, [String]
xs)


data S a = S
    {forall a. S a -> a
val :: a -- The value you are accumulating
    ,forall a. S a -> [String]
args :: [String] -- The arguments you are processing through
    ,forall a. S a -> Int
argsCount :: Int -- The number of unnamed arguments you have seen
    ,forall a. S a -> [String]
errs :: [String] -- The errors you have seen
    }

stop :: Mode a -> S a -> Maybe (Either String a)
stop :: forall a. Mode a -> S a -> Maybe (Either String a)
stop Mode a
mode S{a
Int
[String]
errs :: [String]
argsCount :: Int
args :: [String]
val :: a
errs :: forall a. S a -> [String]
argsCount :: forall a. S a -> Int
args :: forall a. S a -> [String]
val :: forall a. S a -> a
..}
    | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
errs = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [String]
errs
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
args = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ if Int
argsCount forall a. Ord a => a -> a -> Bool
>= Int
mn then forall a b. b -> Either a b
Right a
val else
        forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Expected " forall a. [a] -> [a] -> [a]
++ (if forall a. a -> Maybe a
Just Int
mn forall a. Eq a => a -> a -> Bool
== Maybe Int
mx then String
"exactly" else String
"at least") forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
mn forall a. [a] -> [a] -> [a]
++ String
" unnamed arguments, but got only " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
argsCount
    | Bool
otherwise = forall a. Maybe a
Nothing
    where (Int
mn, Maybe Int
mx) = forall a. Mode a -> (Int, Maybe Int)
argsRange Mode a
mode

err :: S a -> String -> S a
err :: forall a. S a -> String -> S a
err S a
s String
x = S a
s{errs :: [String]
errs=String
xforall a. a -> [a] -> [a]
:forall a. S a -> [String]
errs S a
s}

upd :: S a -> (a -> Either String a) -> S a
upd :: forall a. S a -> (a -> Either String a) -> S a
upd S a
s a -> Either String a
f = case a -> Either String a
f forall a b. (a -> b) -> a -> b
$ forall a. S a -> a
val S a
s of
    Left String
x -> forall a. S a -> String -> S a
err S a
s String
x
    Right a
x -> S a
s{val :: a
val=a
x}


processFlags :: Mode a -> a -> [String] -> Either String a
processFlags :: forall a. Mode a -> a -> [String] -> Either String a
processFlags Mode a
mode a
val_ [String]
args_ = S a -> Either String a
f forall a b. (a -> b) -> a -> b
$ forall a. a -> [String] -> Int -> [String] -> S a
S a
val_ [String]
args_ Int
0 []
    where f :: S a -> Either String a
f S a
s = forall a. a -> Maybe a -> a
fromMaybe (S a -> Either String a
f forall a b. (a -> b) -> a -> b
$ forall a. Mode a -> S a -> S a
processFlag Mode a
mode S a
s) forall a b. (a -> b) -> a -> b
$ forall a. Mode a -> S a -> Maybe (Either String a)
stop Mode a
mode S a
s


pickFlags :: Bool -> Mode a -> [([String], (FlagInfo, Flag a))]
pickFlags Bool
long Mode a
mode = [(forall a. (a -> Bool) -> [a] -> [a]
filter (\String
x -> (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
x forall a. Ord a => a -> a -> Bool
> Int
1) forall a. Eq a => a -> a -> Bool
== Bool
long) forall a b. (a -> b) -> a -> b
$ forall a. Flag a -> [String]
flagNames Flag a
flag,(forall a. Flag a -> FlagInfo
flagInfo Flag a
flag,Flag a
flag)) | Flag a
flag <- forall a. Mode a -> [Flag a]
modeFlags Mode a
mode]


processFlag :: Mode a -> S a -> S a
processFlag :: forall a. Mode a -> S a -> S a
processFlag Mode a
mode s_ :: S a
s_@S{args :: forall a. S a -> [String]
args=(Char
'-':Char
'-':String
xs):[String]
ys} | String
xs forall a. Eq a => a -> a -> Bool
/= String
"" =
    case forall a. [([String], a)] -> String -> LookupName a
lookupName (forall {a}. Bool -> Mode a -> [([String], (FlagInfo, Flag a))]
pickFlags Bool
True Mode a
mode) String
a of
        Ambiguous [String]
poss -> forall a. S a -> String -> S a
err S a
s forall a b. (a -> b) -> a -> b
$ String -> String -> [String] -> String
ambiguous String
"flag" (String
"--" forall a. [a] -> [a] -> [a]
++ String
a) [String]
poss
        LookupName (FlagInfo, Flag a)
NotFound -> forall a. S a -> String -> S a
err S a
s forall a b. (a -> b) -> a -> b
$ String
"Unknown flag: --" forall a. [a] -> [a] -> [a]
++ String
a
        Found (FlagInfo
arg,Flag a
flag) -> case FlagInfo
arg of
            FlagInfo
FlagNone | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
b -> forall a. S a -> (a -> Either String a) -> S a
upd S a
s forall a b. (a -> b) -> a -> b
$ forall a. Flag a -> Update a
flagValue Flag a
flag String
""
                     | Bool
otherwise -> forall a. S a -> String -> S a
err S a
s forall a b. (a -> b) -> a -> b
$ String
"Unhandled argument to flag, none expected: --" forall a. [a] -> [a] -> [a]
++ String
xs
            FlagInfo
FlagReq | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
b Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
ys -> forall a. S a -> String -> S a
err S a
s forall a b. (a -> b) -> a -> b
$ String
"Flag requires argument: --" forall a. [a] -> [a] -> [a]
++ String
xs
                    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
b -> forall a. S a -> (a -> Either String a) -> S a
upd S a
s{args :: [String]
args=forall a. [a] -> [a]
tail [String]
ys} forall a b. (a -> b) -> a -> b
$ forall a. Flag a -> Update a
flagValue Flag a
flag forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [String]
ys
                    | Bool
otherwise -> forall a. S a -> (a -> Either String a) -> S a
upd S a
s forall a b. (a -> b) -> a -> b
$ forall a. Flag a -> Update a
flagValue Flag a
flag forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail String
b
            FlagInfo
_ | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
b -> forall a. S a -> (a -> Either String a) -> S a
upd S a
s forall a b. (a -> b) -> a -> b
$ forall a. Flag a -> Update a
flagValue Flag a
flag forall a b. (a -> b) -> a -> b
$ FlagInfo -> String
fromFlagOpt FlagInfo
arg
              | Bool
otherwise -> forall a. S a -> (a -> Either String a) -> S a
upd S a
s forall a b. (a -> b) -> a -> b
$ forall a. Flag a -> Update a
flagValue Flag a
flag forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail String
b
    where
        s :: S a
s = S a
s_{args :: [String]
args=[String]
ys}
        (String
a,String
b) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'=') String
xs


processFlag Mode a
mode s_ :: S a
s_@S{args :: forall a. S a -> [String]
args=(Char
'-':Char
x:String
xs):[String]
ys} | Char
x forall a. Eq a => a -> a -> Bool
/= Char
'-' =
    case forall a. [([String], a)] -> String -> LookupName a
lookupName (forall {a}. Bool -> Mode a -> [([String], (FlagInfo, Flag a))]
pickFlags Bool
False Mode a
mode) [Char
x] of
        Ambiguous [String]
poss -> forall a. S a -> String -> S a
err S a
s forall a b. (a -> b) -> a -> b
$ String -> String -> [String] -> String
ambiguous String
"flag" [Char
'-',Char
x] [String]
poss
        LookupName (FlagInfo, Flag a)
NotFound -> forall a. S a -> String -> S a
err S a
s forall a b. (a -> b) -> a -> b
$ String
"Unknown flag: -" forall a. [a] -> [a] -> [a]
++ [Char
x]
        Found (FlagInfo
arg,Flag a
flag) -> case FlagInfo
arg of
            FlagInfo
FlagNone | String
"=" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
xs -> forall a. S a -> String -> S a
err S a
s forall a b. (a -> b) -> a -> b
$ String
"Unhandled argument to flag, none expected: -" forall a. [a] -> [a] -> [a]
++ [Char
x]
                     | Bool
otherwise -> forall a. S a -> (a -> Either String a) -> S a
upd S a
s_{args :: [String]
args=[Char
'-'forall a. a -> [a] -> [a]
:String
xs|String
xsforall a. Eq a => a -> a -> Bool
/=String
""] forall a. [a] -> [a] -> [a]
++ [String]
ys} forall a b. (a -> b) -> a -> b
$ forall a. Flag a -> Update a
flagValue Flag a
flag String
""
            FlagInfo
FlagReq | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
xs Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
ys -> forall a. S a -> String -> S a
err S a
s forall a b. (a -> b) -> a -> b
$ String
"Flag requires argument: -" forall a. [a] -> [a] -> [a]
++ [Char
x]
                    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
xs -> forall a. S a -> (a -> Either String a) -> S a
upd S a
s_{args :: [String]
args=forall a. [a] -> [a]
tail [String]
ys} forall a b. (a -> b) -> a -> b
$ forall a. Flag a -> Update a
flagValue Flag a
flag forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [String]
ys
                    | Bool
otherwise -> forall a. S a -> (a -> Either String a) -> S a
upd S a
s_{args :: [String]
args=[String]
ys} forall a b. (a -> b) -> a -> b
$ forall a. Flag a -> Update a
flagValue Flag a
flag forall a b. (a -> b) -> a -> b
$ if String
"=" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
xs then forall a. [a] -> [a]
tail String
xs else String
xs
            FlagOpt String
x | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
xs -> forall a. S a -> (a -> Either String a) -> S a
upd S a
s_{args :: [String]
args=[String]
ys} forall a b. (a -> b) -> a -> b
$ forall a. Flag a -> Update a
flagValue Flag a
flag String
x
                      | Bool
otherwise -> forall a. S a -> (a -> Either String a) -> S a
upd S a
s_{args :: [String]
args=[String]
ys} forall a b. (a -> b) -> a -> b
$ forall a. Flag a -> Update a
flagValue Flag a
flag forall a b. (a -> b) -> a -> b
$ if String
"=" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
xs then forall a. [a] -> [a]
tail String
xs else String
xs
            FlagOptRare String
x | String
"=" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
xs -> forall a. S a -> (a -> Either String a) -> S a
upd S a
s_{args :: [String]
args=[String]
ys} forall a b. (a -> b) -> a -> b
$ forall a. Flag a -> Update a
flagValue Flag a
flag forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail String
xs
                          | Bool
otherwise -> forall a. S a -> (a -> Either String a) -> S a
upd S a
s_{args :: [String]
args=[Char
'-'forall a. a -> [a] -> [a]
:String
xs|String
xsforall a. Eq a => a -> a -> Bool
/=String
""] forall a. [a] -> [a] -> [a]
++ [String]
ys} forall a b. (a -> b) -> a -> b
$ forall a. Flag a -> Update a
flagValue Flag a
flag String
x
    where
        s :: S a
s = S a
s_{args :: [String]
args=[String]
ys}


processFlag Mode a
mode s_ :: S a
s_@S{args :: forall a. S a -> [String]
args=String
"--":[String]
ys} = S a -> S a
f S a
s_{args :: [String]
args=[String]
ys}
    where f :: S a -> S a
f S a
s | forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ forall a. Mode a -> S a -> Maybe (Either String a)
stop Mode a
mode S a
s = S a
s
              | Bool
otherwise = S a -> S a
f forall a b. (a -> b) -> a -> b
$ forall a. Mode a -> S a -> S a
processArg Mode a
mode S a
s

processFlag Mode a
mode S a
s = forall a. Mode a -> S a -> S a
processArg Mode a
mode S a
s

processArg :: Mode a -> S a -> S a
processArg Mode a
mode s_ :: S a
s_@S{args :: forall a. S a -> [String]
args=String
x:[String]
ys, argsCount :: forall a. S a -> Int
argsCount=Int
count} = case forall a. Mode a -> Int -> Maybe (Arg a)
argsPick Mode a
mode Int
count of
    Maybe (Arg a)
Nothing -> forall a. S a -> String -> S a
err S a
s forall a b. (a -> b) -> a -> b
$ String
"Unhandled argument, " forall a. [a] -> [a] -> [a]
++ String
str forall a. [a] -> [a] -> [a]
++ String
" expected: " forall a. [a] -> [a] -> [a]
++ String
x
        where str :: String
str = if Int
count forall a. Eq a => a -> a -> Bool
== Int
0 then String
"none" else String
"at most " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
count
    Just Arg a
arg -> case forall a. Arg a -> Update a
argValue Arg a
arg String
x (forall a. S a -> a
val S a
s) of
            Left String
e -> forall a. S a -> String -> S a
err S a
s forall a b. (a -> b) -> a -> b
$ String
"Unhandled argument, " forall a. [a] -> [a] -> [a]
++ String
e forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
x
            Right a
v -> S a
s{val :: a
val=a
v}
    where
        s :: S a
s = S a
s_{args :: [String]
args=[String]
ys, argsCount :: Int
argsCount=Int
countforall a. Num a => a -> a -> a
+Int
1}


-- find the minimum and maximum allowed number of arguments (Nothing=infinite)
argsRange :: Mode a -> (Int, Maybe Int)
argsRange :: forall a. Mode a -> (Int, Maybe Int)
argsRange Mode{modeArgs :: forall a. Mode a -> ([Arg a], Maybe (Arg a))
modeArgs=([Arg a]
lst,Maybe (Arg a)
end)} = (Int
mn,Maybe Int
mx)
    where mn :: Int
mn = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Arg a -> Bool
argRequire) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ [Arg a]
lst forall a. [a] -> [a] -> [a]
++ forall a. Maybe a -> [a]
maybeToList Maybe (Arg a)
end
          mx :: Maybe Int
mx = if forall a. Maybe a -> Bool
isJust Maybe (Arg a)
end then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Arg a]
lst


argsPick :: Mode a -> Int -> Maybe (Arg a)
argsPick :: forall a. Mode a -> Int -> Maybe (Arg a)
argsPick Mode{modeArgs :: forall a. Mode a -> ([Arg a], Maybe (Arg a))
modeArgs=([Arg a]
lst,Maybe (Arg a)
end)} Int
i = if Int
i forall a. Ord a => a -> a -> Bool
< forall (t :: * -> *) a. Foldable t => t a -> Int
length [Arg a]
lst then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Arg a]
lst forall a. [a] -> Int -> a
!! Int
i else Maybe (Arg a)
end


---------------------------------------------------------------------
-- UTILITIES

ambiguous :: String -> String -> [String] -> String
ambiguous String
typ String
got [String]
xs = String
"Ambiguous " forall a. [a] -> [a] -> [a]
++ String
typ forall a. [a] -> [a] -> [a]
++ String
" '" forall a. [a] -> [a] -> [a]
++ String
got forall a. [a] -> [a] -> [a]
++ String
"', could be any of: " forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
xs
missing :: String -> [String] -> String
missing String
typ [String]
xs = String
"Missing " forall a. [a] -> [a] -> [a]
++ String
typ forall a. [a] -> [a] -> [a]
++ String
", wanted any of: " forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
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 :: forall a. [([String], a)] -> String -> LookupName a
lookupName [([String], a)]
names String
value =
    case ((String -> String -> Bool) -> [(String, a)]
match forall a. Eq a => a -> a -> Bool
(==), (String -> String -> Bool) -> [(String, a)]
match forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf) of
        ([],[]) -> forall a. LookupName a
NotFound
        ([],[(String, a)
x]) -> forall a. a -> LookupName a
Found forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd (String, a)
x
        ([],[(String, a)]
xs) -> forall a. [String] -> LookupName a
Ambiguous forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(String, a)]
xs
        ([(String, a)
x],[(String, a)]
_) -> forall a. a -> LookupName a
Found forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd (String, a)
x
        ([(String, a)]
xs,[(String, a)]
_) -> forall a. [String] -> LookupName a
Ambiguous forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(String, a)]
xs
    where
        match :: (String -> String -> Bool) -> [(String, a)]
match String -> String -> Bool
op = [(forall a. [a] -> a
head [String]
ys,a
v) | ([String]
xs,a
v) <- [([String], a)]
names, let ys :: [String]
ys = forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
op String
value) [String]
xs, [String]
ys forall a. Eq a => a -> a -> Bool
/= []]