SimpleParser.hs

{-# LANGUAGE ExistentialQuantification #-}
-- | A simple command line parser that can parse options that take an
-- optional argument, one or two arguments, or a variable number of
-- arguments. For sample code that uses this parser, see
-- "System.Console.MultiArg.SampleParser".
module System.Console.MultiArg.SimpleParser (
  -- * Interspersion control
  Intersperse (Intersperse, StopOptions)

    -- * The parser
  , simple

    -- * Parsing multi-mode command lines
  , Mode(..)
  , modes
  ) where

import qualified System.Console.MultiArg.Prim as P
import qualified System.Console.MultiArg.Combinator as C
import qualified Control.Monad.Exception.Synchronous as Ex
import Control.Applicative ( many, (<|>), optional,
                             (<$), (<*>), (<*), (<$>))
import Data.List (find)
import Data.Maybe (catMaybes, fromJust)
import qualified Data.Set as Set


-- | What to do after encountering the first non-option,
-- non-option-argument word on the command line? In either case, no
-- more options are parsed after a stopper.
data Intersperse =
  Intersperse
  -- ^ Additional options are allowed on the command line after
  -- encountering the first positional argument. For example, if @a@
  -- and @b@ are options, in the command line @-a posarg -b@, @b@ will
  -- be parsed as an option. If @b@ is /not/ an option and the same
  -- command line is entered, then @-b@ will result in an error
  -- because @-b@ starts with a hyphen and therefore \"looks like\" an
  -- option.

  | StopOptions
    -- ^ No additional options will be parsed after encountering the
    -- first positional argument. For example, if @a@ and @b@ are
    -- options, in the command line @-a posarg -b@, @b@ will be parsed
    -- as a positional argument rather than as an option.

-- | Parse a command line.
simple ::
  Intersperse
  -- ^ What to do after encountering the first positional argument

  -> [C.OptSpec a]
  -- ^ All possible options

  -> (String -> a)
  -- ^ How to handle positional arguments. This function is applied to
  -- the appropriate string every time the parser encounters a
  -- positional argument.

  -> [String]
  -- ^ The command line to parse. This function correctly handles
  -- Unicode strings; however, because 'System.Environment.getArgs'
  -- does not always correctly handle Unicode strings, consult the
  -- documentation in 'System.Console.MultiArg.GetArgs' and consider
  -- using the functions in there if there is any chance that you will
  -- be parsing command lines that have non-ASCII strings.

  -> Ex.Exceptional P.Error [a]
simple i os p as =
  let optParser = C.parseOption os
      parser = case i of
        Intersperse -> parseIntersperse optParser p
        StopOptions -> parseStopOpts optParser p
  in P.parse as parser

parseOptsNoIntersperse :: P.Parser a -> P.Parser [a]
parseOptsNoIntersperse p = P.manyTill p e where
  e = P.end <|> nonOpt
  nonOpt = P.lookAhead next
  next = (() <$ P.nonOptionPosArg) <|> P.stopper


parseStopOpts :: P.Parser a -> (String -> a) -> P.Parser [a]
parseStopOpts optParser p =
  (\opts args -> opts ++ map p args)
  <$> parseOptsNoIntersperse optParser
  <* optional P.stopper
  <*> many P.nextWord


-- | @parseIntersperse o p@ parses options and positional arguments,
-- where o is a parser that parses options, and p is a function that,
-- when applied to a string, returns the appropriate type.
parseIntersperse :: P.Parser a -> (String -> a) -> P.Parser [a]
parseIntersperse optParser p =
  let pa = (Just . p) <$> P.nonOptionPosArg
      po = Just <$> optParser
      ps = Nothing <$ P.stopper
      parser = po <|> ps <|> pa
  in catMaybes <$> P.manyTill parser P.end

-- | Provides information on each mode that you wish to parse.
data Mode result = forall b. Mode
  { mName :: String
    -- ^ How the user identifies the mode on the command line. For
    -- example, with @git@ this would be @commit@, @pull@, etc.

  , mIntersperse :: Intersperse
    -- ^ Each mode may have options and positional arguments; may
    -- these be interspersed?

  , mOpts :: [C.OptSpec b]
    -- ^ Options for this mode

  , mPosArgs :: String -> b
    -- ^ How to parse positional arguments for this mode

  , mProcess :: [b] -> result
    -- ^ Processes the options after they have been parsed.
  
  }

instance Functor Mode where
  fmap f (Mode nm i os pa p) =
    Mode nm i os pa (f . p)

processModeArgs :: Mode result -> P.Parser result
processModeArgs (Mode _ i os pa p) = do
  let prsr = case i of
        Intersperse -> parseIntersperse
        StopOptions -> parseStopOpts
  rs <- prsr (C.parseOption os) pa <* P.end
  return $ p rs

-- | Parses a command line that may feature options followed by a
-- mode followed by more options and then followed by positional
-- arguments.
modes
  :: [C.OptSpec a]
     -- ^ Global options. These come after the program name but before
     -- the mode name.

  -> ([a] -> Ex.Exceptional String b)
     -- ^ This function is applied to all the global options after
     -- they are parsed. To indicate a failure, return an Exception
     -- String; otherwise, return a successful value. This allows you
     -- to process the global options before the mode is parsed. (If
     -- you don't need to do any preprocessing, pass @return@ here.)
     -- If you indicate a failure here, parsing of the command line
     -- will stop and this error message will be returned.

  -> (b -> Either (String -> c) [Mode result])
     -- ^ This function determines whether modes will be parsed and,
     -- if so, which ones. The function is applied to the result of
     -- the pre-processing of the global options, so which modes are
     -- parsed and the behavior of those modes can vary depending on
     -- the global options. Return a Left to indicate that you do not
     -- want to parse modes at all. For instance, if the user passed a
     -- @--help@ option, you may not want to look for a mode after
     -- that. Otherwise, to parse modes, return a Right with a list of
     -- the modes.

  -> [String]
     -- ^ The command line to parse (presumably from 'getArgs')

  -> Ex.Exceptional P.Error (b, Either [c] result)
     -- ^ Returns an Exception if an error was encountered when
     -- parsing the command line (including if the global options
     -- procesor returned an Exception.) Otherwise, returns a
     -- pair. The first element of the pair is the result of the
     -- global options processor. The second element of the pair is an
     -- Either. It is Left if no modes were parsed, with a list of the
     -- positional arguments. It is a Right if modes were parsed, with
     -- the result of parsing the arguments to the mode.

modes globals lsToB getCmds ss = P.parse ss $ do
  gs <- P.manyTill (C.parseOption globals) endOrNonOpt
  b <- case lsToB gs of
    Ex.Exception e -> fail e
    Ex.Success g -> return g
  let cmds = getCmds b
  case cmds of
    Left fPa -> do
      posArgs <- (fmap (fmap fPa) $ many P.nextWord) <* P.end
      return (b, Left posArgs)
    Right cds -> do
      let cmdWords = Set.fromList . map mName $ cds
      (_, w) <- P.matchApproxWord cmdWords
      let cmd = fromJust . find (\c -> mName c == w) $ cds
      r <- processModeArgs cmd
      return (b, Right r)

-- | Looks at the next word. Succeeds if it is a non-option, or if we
-- are at the end of input. Fails otherwise.
endOrNonOpt :: P.Parser ()
endOrNonOpt = (P.lookAhead P.nonOptionPosArg >> return ())
              <|> P.end