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