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