{-# LANGUAGE Rank2Types, PatternGuards #-}
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
  runP,
  setContext,
  mapParser,
  optionNames
  ) where

import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Error
import Control.Monad.Trans.Writer
import Data.Maybe
import Data.Monoid
import Options.Applicative.Types

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

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

uncons :: [a] -> Maybe (a, [a])
uncons [] = Nothing
uncons (x : xs) = Just (x, xs)

data MatchResult
  = NoMatch
  | Match (Maybe String)

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

type Matcher a = [String] -> P (a, [String])

optMatches :: OptReader a -> String -> Maybe (Matcher a)
optMatches rdr arg = case rdr of
  OptReader names f
    | Just (arg1, val) <- parsed
    , arg1 `elem` names
    -> Just $ \args -> do
         (arg', args') <- tryP . uncons $ maybeToList val ++ args
         r <- tryP $ f arg'
         return (r, args')
    | otherwise -> Nothing
  FlagReader names x
    | Just (arg1, Nothing) <- parsed
    , arg1 `elem` names
    -> Just $ \args -> return (x, args)
  ArgReader f
    | Just result <- f 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

tryP :: Maybe a -> P a
tryP = maybe empty return

runP :: P a -> (Either String a, Context)
runP = runWriter . runErrorT

setContext :: Maybe String -> ParserInfo a -> P ()
setContext name = lift . tell . Context name

stepParser :: Parser a -> String -> [String] -> P (Parser a, [String])
stepParser (NilP _) _ _ = empty
stepParser (OptP opt) arg args
  | Just matcher <- optMatches (optMain opt) arg
  = do (r, args') <- matcher args
       return (pure r, args')
  | otherwise = empty
stepParser (MultP p1 p2) arg args = msum
  [ do (p1', args') <- stepParser p1 arg args
       return (p1' <*> p2, args')
  , do (p2', args') <- stepParser p2 arg args
       return (p1 <*> p2', args') ]
stepParser (AltP p1 p2) arg args = msum
  [ do (p1', args') <- stepParser p1 arg args
       return (p1' <|> p2, args')
  , do (p2', args') <- stepParser p2 arg args
       return (p1 <|> p2', args') ]
stepParser (BindP p k) arg args = do
  (p', args') <- stepParser p arg args
  x <- 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 :: Parser a -> [String] -> P (a, [String])
runParser p args = case args of
  [] -> result
  (arg : argt) -> do
    x <- catchError (Right <$> stepParser p arg argt)
                    (return . Left)
    case x of
      Left e -> result <|> throwError e
      Right (p', args') -> runParser p' args'
  where
    result = (,) <$> evalParser p <*> pure args

runParserFully :: Parser a -> [String] -> P 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 -> P a
evalParser (NilP r) = tryP r
evalParser (OptP _) = empty
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.
mapParser :: (forall x . OptHelpInfo -> Option x -> b)
          -> Parser a
          -> [b]
mapParser = go False False
  where
    has_default :: Parser a -> Bool
    has_default p = case runP (evalParser p) of
      (Left _, _) -> False
      (Right _, _) -> True

    go :: Bool -> Bool
       -> (forall x . OptHelpInfo -> Option x -> b)
       -> Parser a -> [b]
    go _ _ _ (NilP _) = []
    go m d f (OptP opt) = [f (OptHelpInfo m d) opt]
    go m d f (MultP p1 p2) = go m d f p1 ++ go m d f p2
    go m d f (AltP p1 p2) = 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