{-# LANGUAGE Rank2Types, PatternGuards, ScopedTypeVariables #-}
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,

  -- * 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
import Control.Monad
import Data.List
import Data.Maybe
import Data.Monoid

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

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 Matcher m a = [String] -> m (a, [String])

optMatches :: MonadP m => Bool -> OptReader a -> String -> Maybe (Matcher m a)
optMatches disambiguate opt arg = case opt of
  OptReader names rdr
    | Just (arg1, val) <- parsed
    , has_name arg1 names
    -> Just $ \args -> do
         let mb_args = uncons $ maybeToList val ++ args
         (arg', args') <- maybe (missingArgP (crCompleter rdr)) return mb_args
         r <- liftMaybe $ crReader rdr arg'
         return (r, args')
    | otherwise -> Nothing
  FlagReader names x
    | Just (arg1, Nothing) <- parsed
    , has_name arg1 names
    -> Just $ \args -> return (x, args)
  ArgReader rdr
    | Just result <- crReader rdr arg
    -> Just $ \args -> return (result, args)
  CmdReader _ f
    | Just subp <- f arg
    -> Just $ \args -> do
         setContext (Just arg) subp
         runParser (infoParser subp) args
  _ -> Nothing
  where
    parsed
      | '-' : '-' : arg1 <- arg
      = case span (/= '=') arg1 of
          (_, "") -> Just (OptLong arg1, Nothing)
          (arg1', _ : rest) -> Just (OptLong arg1', Just rest)
      | '-' : arg1 <- arg
      = case arg1 of
          [] -> Nothing
          [a] -> Just (OptShort a, Nothing)
          (a : rest) -> Just (OptShort a, Just rest)
      | otherwise = Nothing
    has_name a
      | disambiguate = any (isOptionPrefix a)
      | otherwise = elem a

stepParser :: MonadP m => ParserPrefs -> Parser a -> String -> [String] -> [m (Parser a, [String])]
stepParser _ (NilP _) _ _ = []
stepParser prefs (OptP opt) arg args =
  case optMatches disambiguate (optMain opt) arg of
    Just matcher -> pure $ do
      (r, args') <- matcher args
      return (pure r, args')
    Nothing -> empty
  where
    disambiguate = prefDisambiguate prefs
                && optVisibility opt > Internal
stepParser prefs (MultP p1 p2) arg args = msum
  [ flip map (stepParser prefs p1 arg args) $ \m ->
      do (p1', args') <- m
         return (p1' <*> p2, args')
  , flip map (stepParser prefs p2 arg args) $ \m ->
      do (p2', args') <- m
         return (p1 <*> p2', args') ]
stepParser prefs (AltP p1 p2) arg args = msum
  [ stepParser prefs p1 arg args
  , stepParser prefs p2 arg args ]
stepParser prefs (BindP p k) arg args =
  flip map (stepParser prefs p arg args) $ \m -> do
    (p', args') <- m
    x <- liftMaybe $ evalParser p'
    return (k x, args')

-- | 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 -> [String] -> m (a, [String])
runParser p args = case args of
  [] -> exitP p result
  (arg : argt) -> do
    prefs <- getPrefs
    x <- tryP $ do_step prefs arg argt
    case x of
      Left e -> liftMaybe result <|> errorP e
      Right (p', args') -> runParser p' args'
  where
    result = (,) <$> evalParser p <*> pure args
    do_step prefs arg argt
      | prefDisambiguate prefs
      = case parses of
          [m] -> m
          _   -> empty
      | otherwise
      = msum parses
      where parses = stepParser prefs p arg argt

runParserFully :: MonadP m => Parser a -> [String] -> 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]