{-# LANGUAGE Rank2Types #-}
module Options.Applicative.Common (
  -- * Option parsers
  --
  -- | A 'Parser' is composed of a list of options. Several kinds of options
  -- are supported:
  --
  --  * Flags: simple no-argument options. When a flag is encountered on the
  --  command line, its value is returned.
  --
  --  * Options: options with an argument. An option can define a /reader/,
  --  which converts its argument from String to the desired value, or throws a
  --  parse error if the argument does not validate correctly.
  --
  --  * Arguments: positional arguments, validated in the same way as option
  --  arguments.
  --
  --  * Commands. A command defines a completely independent sub-parser. When a
  --  command is encountered, the whole command line is passed to the
  --  corresponding parser.
  --
  Parser,
  liftOpt,
  showOption,

  -- * Program descriptions
  --
  -- A 'ParserInfo' describes a command line program, used to generate a help
  -- screen. Two help modes are supported: brief and full. In brief mode, only
  -- an option and argument summary is displayed, while in full mode each
  -- available option and command, including hidden ones, is described.
  --
  -- A basic 'ParserInfo' with default values for fields can be created using
  -- the 'info' function.
  ParserInfo(..),

  -- * Running parsers
  runParser,
  runParserFully,
  evalParser,

  -- * Low-level utilities
  mapParser,
  treeMapParser,
  optionNames
  ) where

import Control.Applicative (pure, (<*>), (<$>), (<|>))
import Control.Monad (guard, mzero, msum, when)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State (StateT(..), get, put, runStateT)
import Data.List (isPrefixOf)
import Data.Maybe (maybeToList, isJust)
import Data.Monoid (Monoid(..))

import Options.Applicative.Internal
import Options.Applicative.Types

showOption :: OptName -> String
showOption (OptLong n) = "--" ++ n
showOption (OptShort n) = '-' : [n]

optionNames :: OptReader a -> [OptName]
optionNames (OptReader names _ _) = names
optionNames (FlagReader names _) = names
optionNames _ = []

isOptionPrefix :: OptName -> OptName -> Bool
isOptionPrefix (OptShort x) (OptShort y) = x == y
isOptionPrefix (OptLong x) (OptLong y) = x `isPrefixOf` y
isOptionPrefix _ _ = False

-- | Create a parser composed of a single option.
liftOpt :: Option a -> Parser a
liftOpt = OptP

data MatchResult
  = NoMatch
  | Match (Maybe String)

instance Monoid MatchResult where
  mempty = NoMatch
  mappend m@(Match _) _ = m
  mappend _ m = m

type Args = [String]

optMatches :: MonadP m => Bool -> OptReader a -> String -> Maybe (StateT Args m a)
optMatches disambiguate opt arg = case opt of
  OptReader names rdr no_arg_err -> do
    (arg1, val) <- parsed
    guard $ has_name arg1 names
    Just $ do
      args <- get
      let mb_args = uncons $ maybeToList val ++ args
      let missing_arg = lift $ missingArgP no_arg_err (crCompleter rdr)
      (arg', args') <- maybe missing_arg return mb_args
      put args'
      case runReadM (crReader rdr arg') of
        Left e -> lift $ errorFor arg1 e
        Right r -> return r
  FlagReader names x -> do
    (arg1, Nothing) <- parsed
    guard $ has_name arg1 names
    Just $ return x
  ArgReader rdr -> do
    result <- crReader rdr arg
    Just $ return result
  CmdReader _ f ->
    flip fmap (f arg) $ \subp -> StateT $ \args -> do
      setContext (Just arg) subp
      prefs <- getPrefs
      let runSubparser
            | prefBacktrack prefs = runParser
            | otherwise = \p a
            -> (,) <$> runParserFully p a <*> pure []
      runSubparser (infoParser subp) args
  where
    errorFor name (ErrorMsg msg) =
      errorP (ErrorMsg ("option " ++ showOption name ++ ": " ++ msg))
    errorFor _ e = errorP e

    parsed =
      case arg of
        '-' : '-' : arg1 ->
          Just $
          case span (/= '=') arg1 of
            (_, "") -> (OptLong arg1, Nothing)
            (arg1', _ : rest) -> (OptLong arg1', Just rest)
        '-' : arg1 ->
          case arg1 of
            [] -> Nothing
            (a : rest) -> Just (OptShort a, if null rest then Nothing else Just rest)
        _ -> Nothing
    has_name a
      | disambiguate = any (isOptionPrefix a)
      | otherwise = elem a

isArg :: OptReader a -> Bool
isArg (ArgReader _) = True
isArg _ = False

stepParser :: MonadP m => ParserPrefs -> String -> Parser a
           -> NondetT (StateT Args m) (Parser a)
stepParser _ _ (NilP _) = mzero
stepParser prefs arg (OptP opt) = do
  when (isArg (optMain opt)) cut
  case optMatches disambiguate (optMain opt) arg of
    Just matcher -> pure <$> lift matcher
    Nothing -> mzero
  where
    disambiguate = prefDisambiguate prefs
                && optVisibility opt > Internal
stepParser prefs arg (MultP p1 p2) = foldr1 (<!>)
  [ do p1' <- stepParser prefs arg p1
       return (p1' <*> p2)
  , do p2' <- stepParser prefs arg p2
       return (p1 <*> p2') ]
stepParser prefs arg (AltP p1 p2) = msum
  [ stepParser prefs arg p1
  , stepParser prefs arg p2 ]
stepParser prefs arg (BindP p k) = do
  p' <- stepParser prefs arg p
  x <- hoistMaybe $ evalParser p'
  return (k x)

-- | Apply a 'Parser' to a command line, and return a result and leftover
-- arguments.  This function returns an error if any parsing error occurs, or
-- if any options are missing and don't have a default value.
runParser :: MonadP m => Parser a -> Args -> m (a, Args)
runParser p args = case args of
  [] -> exitP p result
  (arg : argt) -> do
    prefs <- getPrefs
    x <- do_step prefs arg argt
    case x of
      Left e -> case (result, e) of
        (Just r, ErrorMsg _) -> return r
        _ -> errorP e
      Right (p', args') -> runParser p' args'
  where
    result = (,) <$> evalParser p <*> pure args
    do_step prefs arg argt = tryP
                           . (`runStateT` argt)
                           . (>>= maybe ((lift . parseError) arg) return)
                           . disamb (not (prefDisambiguate prefs))
                           $ stepParser prefs arg p

parseError :: MonadP m => String -> m a
parseError arg = errorP . ErrorMsg $ msg
  where
    msg = case arg of
      ('-':_) -> "Invalid option `" ++ arg ++ "'"
      _       -> "Invalid argument `" ++ arg ++ "'"

runParserFully :: MonadP m => Parser a -> Args -> m a
runParserFully p args = do
  (r, args') <- runParser p args
  guard $ null args'
  return r

-- | The default value of a 'Parser'.  This function returns an error if any of
-- the options don't have a default value.
evalParser :: Parser a -> Maybe a
evalParser (NilP r) = r
evalParser (OptP _) = Nothing
evalParser (MultP p1 p2) = evalParser p1 <*> evalParser p2
evalParser (AltP p1 p2) = evalParser p1 <|> evalParser p2
evalParser (BindP p k) = evalParser p >>= evalParser . k

-- | Map a polymorphic function over all the options of a parser, and collect
-- the results in a list.
mapParser :: (forall x. OptHelpInfo -> Option x -> b)
              -> Parser a -> [b]
mapParser f = flatten . treeMapParser f
  where
    flatten (Leaf x) = [x]
    flatten (MultNode xs) = xs >>= flatten
    flatten (AltNode xs) = xs >>= flatten

-- | Like 'mapParser', but collect the results in a tree structure.
treeMapParser :: (forall x . OptHelpInfo -> Option x -> b)
          -> Parser a
          -> OptTree b
treeMapParser g = simplify . go False False g
  where
    has_default :: Parser a -> Bool
    has_default p = isJust (evalParser p)

    go :: Bool -> Bool
       -> (forall x . OptHelpInfo -> Option x -> b)
       -> Parser a
       -> OptTree b
    go _ _ _ (NilP _) = MultNode []
    go m d f (OptP opt)
      | optVisibility opt > Internal
      = Leaf (f (OptHelpInfo m d) opt)
      | otherwise
      = MultNode []
    go m d f (MultP p1 p2) = MultNode [go m d f p1, go m d f p2]
    go m d f (AltP p1 p2) = AltNode [go m d' f p1, go m d' f p2]
      where d' = d || has_default p1 || has_default p2
    go _ d f (BindP p _) = go True d f p

simplify :: OptTree a -> OptTree a
simplify (Leaf x) = Leaf x
simplify (MultNode xs) =
  case concatMap (remove_mult . simplify) xs of
    [x] -> x
    xs' -> MultNode xs'
  where
    remove_mult (MultNode ts) = ts
    remove_mult t = [t]
simplify (AltNode xs) =
  case concatMap (remove_alt . simplify) xs of
    []  -> MultNode []
    [x] -> x
    xs' -> AltNode xs'
  where
    remove_alt (AltNode ts) = ts
    remove_alt (MultNode []) = []
    remove_alt t = [t]