module System.Console.Docopt.OptParse
  where

import Control.Monad (unless)

import qualified Data.Map as M
import           Data.List (intercalate, nub, (\\))

import System.Console.Docopt.ParseUtils
import System.Console.Docopt.Types


-- | The meat and potatoes.
--   @delim@ is an obscure delimiter with which to intercalate the argv list,
--   @fmt@ is the OptPattern together with metadata to tell the parser how to parse args.
--   Together, these let @buildOptParser@ build a parsec parser that can be applied to an argv.
buildOptParser :: String -> OptFormat -> CharParser OptParserState ()
buildOptParser :: String -> OptFormat -> CharParser OptParserState ()
buildOptParser String
delim fmt :: OptFormat
fmt@(OptPattern
pattern, OptInfoMap
infomap) =

  let -- Helpers
      argDelim :: ParsecT String u Identity String
argDelim = (ParsecT String u Identity String
-> ParsecT String u Identity String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT String u Identity String
 -> ParsecT String u Identity String)
-> ParsecT String u Identity String
-> ParsecT String u Identity String
forall a b. (a -> b) -> a -> b
$ String -> ParsecT String u Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
delim) ParsecT String u Identity String
-> String -> ParsecT String u Identity String
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"space between arguments"

      makeParser :: OptPattern -> CharParser OptParserState ()
makeParser OptPattern
p = String -> OptFormat -> CharParser OptParserState ()
buildOptParser String
delim (OptPattern
p, OptInfoMap
infomap)

      argDelimIfNotInShortOptStack :: CharParser OptParserState ()
argDelimIfNotInShortOptStack = do
        OptParserState
st <- ParsecT String OptParserState Identity OptParserState
forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
        if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ OptParserState -> Bool
inShortOptStack OptParserState
st
          then ParsecT String OptParserState Identity String
-> CharParser OptParserState ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional ParsecT String OptParserState Identity String
forall u. ParsecT String u Identity String
argDelim
          else () -> CharParser OptParserState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      updateOptWith :: (Option -> OptionInfo -> String -> Arguments -> Arguments) ->
                       Option ->
                       String ->
                       CharParser OptParserState ()
      updateOptWith :: (Option -> OptionInfo -> String -> Arguments -> Arguments)
-> Option -> String -> CharParser OptParserState ()
updateOptWith Option -> OptionInfo -> String -> Arguments -> Arguments
updateFn Option
opt String
val = do
        OptParserState
st <- ParsecT String OptParserState Identity OptParserState
forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
        let optInfo :: OptionInfo
optInfo = (OptParserState -> OptInfoMap
optInfoMap OptParserState
st) OptInfoMap -> Option -> OptionInfo
forall k a. Ord k => Map k a -> k -> a
M.! Option
opt
        (OptParserState -> OptParserState) -> CharParser OptParserState ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
updateState ((OptParserState -> OptParserState)
 -> CharParser OptParserState ())
-> (OptParserState -> OptParserState)
-> CharParser OptParserState ()
forall a b. (a -> b) -> a -> b
$ (Arguments -> Arguments) -> OptParserState -> OptParserState
updateParsedArgs ((Arguments -> Arguments) -> OptParserState -> OptParserState)
-> (Arguments -> Arguments) -> OptParserState -> OptParserState
forall a b. (a -> b) -> a -> b
$ Option -> OptionInfo -> String -> Arguments -> Arguments
updateFn Option
opt OptionInfo
optInfo String
val

      updateSt_saveOccurrence :: Option -> String -> CharParser OptParserState ()
updateSt_saveOccurrence Option
opt String
val = (Option -> OptionInfo -> String -> Arguments -> Arguments)
-> Option -> String -> CharParser OptParserState ()
updateOptWith Option -> OptionInfo -> String -> Arguments -> Arguments
saveOccurrence Option
opt String
val
      updateSt_assertPresent :: Option -> CharParser OptParserState ()
updateSt_assertPresent Option
opt = (Option -> OptionInfo -> String -> Arguments -> Arguments)
-> Option -> String -> CharParser OptParserState ()
updateOptWith (\Option
opt OptionInfo
info String
_ -> Option -> OptionInfo -> Arguments -> Arguments
assertPresent Option
opt OptionInfo
info) Option
opt String
""

      updateSt_inShortOptStack :: Bool -> ParsecT s OptParserState Identity ()
updateSt_inShortOptStack = (OptParserState -> OptParserState)
-> ParsecT s OptParserState Identity ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
updateState ((OptParserState -> OptParserState)
 -> ParsecT s OptParserState Identity ())
-> (Bool -> OptParserState -> OptParserState)
-> Bool
-> ParsecT s OptParserState Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> OptParserState -> OptParserState
updateInShortOptStack

  in case OptPattern
pattern of
  (Sequence [OptPattern]
pats) ->
      CharParser OptParserState () -> CharParser OptParserState ()
forall (m :: * -> *) s t b.
(Stream s m t, Show t) =>
ParsecT s OptParserState m b -> ParsecT s OptParserState m b
assertTopConsumesAll (CharParser OptParserState () -> CharParser OptParserState ())
-> CharParser OptParserState () -> CharParser OptParserState ()
forall a b. (a -> b) -> a -> b
$ (CharParser OptParserState ()
 -> CharParser OptParserState () -> CharParser OptParserState ())
-> CharParser OptParserState ()
-> [CharParser OptParserState ()]
-> CharParser OptParserState ()
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (CharParser OptParserState ()
-> CharParser OptParserState () -> CharParser OptParserState ()
forall a b.
ParsecT String OptParserState Identity a
-> ParsecT String OptParserState Identity b
-> ParsecT String OptParserState Identity b
andThen) (() -> CharParser OptParserState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) [CharParser OptParserState ()]
ps
      where assertTopConsumesAll :: ParsecT s OptParserState m b -> ParsecT s OptParserState m b
assertTopConsumesAll ParsecT s OptParserState m b
p = do
              OptParserState
st <- ParsecT s OptParserState m OptParserState
forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
              if OptParserState -> Bool
inTopLevelSequence OptParserState
st
                then do
                  (OptParserState -> OptParserState) -> ParsecT s OptParserState m ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
updateState ((OptParserState -> OptParserState)
 -> ParsecT s OptParserState m ())
-> (OptParserState -> OptParserState)
-> ParsecT s OptParserState m ()
forall a b. (a -> b) -> a -> b
$ \OptParserState
st -> OptParserState
st {inTopLevelSequence :: Bool
inTopLevelSequence = Bool
False}
                  ParsecT s OptParserState m b
p ParsecT s OptParserState m b
-> ParsecT s OptParserState m () -> ParsecT s OptParserState m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT s OptParserState m ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
                else ParsecT s OptParserState m b
p
            inner_pats :: [OptFormat]
inner_pats = (\OptPattern
pat -> (OptPattern
pat, OptInfoMap
infomap)) (OptPattern -> OptFormat) -> [OptPattern] -> [OptFormat]
forall a b. (a -> b) -> [a] -> [b]
`map` [OptPattern]
pats
            ps :: [CharParser OptParserState ()]
ps = (String -> OptFormat -> CharParser OptParserState ()
buildOptParser String
delim) (OptFormat -> CharParser OptParserState ())
-> [OptFormat] -> [CharParser OptParserState ()]
forall a b. (a -> b) -> [a] -> [b]
`map` [OptFormat]
inner_pats
            andThen :: ParsecT String OptParserState Identity a
-> ParsecT String OptParserState Identity b
-> ParsecT String OptParserState Identity b
andThen = \ParsecT String OptParserState Identity a
p1 ParsecT String OptParserState Identity b
p2 -> do
              ParsecT String OptParserState Identity a
p1
              CharParser OptParserState ()
argDelimIfNotInShortOptStack
              ParsecT String OptParserState Identity b
p2
  (OneOf [OptPattern]
pats) ->
      [CharParser OptParserState ()] -> CharParser OptParserState ()
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice ([CharParser OptParserState ()] -> CharParser OptParserState ())
-> [CharParser OptParserState ()] -> CharParser OptParserState ()
forall a b. (a -> b) -> a -> b
$ (CharParser OptParserState () -> CharParser OptParserState ()
forall tok st a. GenParser tok st a -> GenParser tok st a
try (CharParser OptParserState () -> CharParser OptParserState ())
-> (OptPattern -> CharParser OptParserState ())
-> OptPattern
-> CharParser OptParserState ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OptPattern -> CharParser OptParserState ()
makeParser) (OptPattern -> CharParser OptParserState ())
-> [OptPattern] -> [CharParser OptParserState ()]
forall a b. (a -> b) -> [a] -> [b]
`map` [OptPattern]
pats
  (Unordered [OptPattern]
pats) -> case [OptPattern]
pats of
      OptPattern
pat:[] -> OptPattern -> CharParser OptParserState ()
makeParser OptPattern
pat
      [OptPattern]
_ ->  [CharParser OptParserState ()] -> CharParser OptParserState ()
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice ([CharParser OptParserState ()] -> CharParser OptParserState ())
-> [CharParser OptParserState ()] -> CharParser OptParserState ()
forall a b. (a -> b) -> a -> b
$ ([OptPattern] -> OptPattern -> CharParser OptParserState ()
parseThisThenRest [OptPattern]
pats) (OptPattern -> CharParser OptParserState ())
-> [OptPattern] -> [CharParser OptParserState ()]
forall a b. (a -> b) -> [a] -> [b]
`map` [OptPattern]
pats
            where parseThisThenRest :: [OptPattern] -> OptPattern -> CharParser OptParserState ()
parseThisThenRest [OptPattern]
list OptPattern
pat = CharParser OptParserState () -> CharParser OptParserState ()
forall tok st a. GenParser tok st a -> GenParser tok st a
try (CharParser OptParserState () -> CharParser OptParserState ())
-> CharParser OptParserState () -> CharParser OptParserState ()
forall a b. (a -> b) -> a -> b
$ do
                    OptPattern -> CharParser OptParserState ()
makeParser OptPattern
pat
                    let rest :: [OptPattern]
rest = [OptPattern]
list [OptPattern] -> [OptPattern] -> [OptPattern]
forall a. Eq a => [a] -> [a] -> [a]
\\ [OptPattern
pat]
                    CharParser OptParserState ()
argDelimIfNotInShortOptStack
                    OptPattern -> CharParser OptParserState ()
makeParser (OptPattern -> CharParser OptParserState ())
-> OptPattern -> CharParser OptParserState ()
forall a b. (a -> b) -> a -> b
$ [OptPattern] -> OptPattern
forall a. [Pattern a] -> Pattern a
Unordered [OptPattern]
rest
  (Optional OptPattern
pat) ->
        case OptPattern
pat of
          Unordered [OptPattern]
ps -> case [OptPattern]
ps of
            OptPattern
p:[] -> OptPattern -> CharParser OptParserState ()
makeParser (OptPattern -> CharParser OptParserState ())
-> OptPattern -> CharParser OptParserState ()
forall a b. (a -> b) -> a -> b
$ OptPattern -> OptPattern
forall a. Pattern a -> Pattern a
Optional OptPattern
p
            [OptPattern]
_  -> CharParser OptParserState () -> CharParser OptParserState ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional (CharParser OptParserState () -> CharParser OptParserState ())
-> CharParser OptParserState () -> CharParser OptParserState ()
forall a b. (a -> b) -> a -> b
$ [CharParser OptParserState ()] -> CharParser OptParserState ()
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice ([CharParser OptParserState ()] -> CharParser OptParserState ())
-> [CharParser OptParserState ()] -> CharParser OptParserState ()
forall a b. (a -> b) -> a -> b
$ ([OptPattern] -> OptPattern -> CharParser OptParserState ()
parseThisThenRest [OptPattern]
ps) (OptPattern -> CharParser OptParserState ())
-> [OptPattern] -> [CharParser OptParserState ()]
forall a b. (a -> b) -> [a] -> [b]
`map` [OptPattern]
ps
                  where parseThisThenRest :: [OptPattern] -> OptPattern -> CharParser OptParserState ()
parseThisThenRest [OptPattern]
list OptPattern
pat = CharParser OptParserState () -> CharParser OptParserState ()
forall tok st a. GenParser tok st a -> GenParser tok st a
try (CharParser OptParserState () -> CharParser OptParserState ())
-> CharParser OptParserState () -> CharParser OptParserState ()
forall a b. (a -> b) -> a -> b
$ do
                          OptPattern -> CharParser OptParserState ()
makeParser OptPattern
pat
                          let rest :: [OptPattern]
rest = [OptPattern]
list [OptPattern] -> [OptPattern] -> [OptPattern]
forall a. Eq a => [a] -> [a] -> [a]
\\ [OptPattern
pat]
                          CharParser OptParserState ()
argDelimIfNotInShortOptStack
                          OptPattern -> CharParser OptParserState ()
makeParser (OptPattern -> CharParser OptParserState ())
-> OptPattern -> CharParser OptParserState ()
forall a b. (a -> b) -> a -> b
$ OptPattern -> OptPattern
forall a. Pattern a -> Pattern a
Optional (OptPattern -> OptPattern) -> OptPattern -> OptPattern
forall a b. (a -> b) -> a -> b
$ [OptPattern] -> OptPattern
forall a. [Pattern a] -> Pattern a
Unordered [OptPattern]
rest
          OptPattern
_ -> CharParser OptParserState () -> CharParser OptParserState ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional (CharParser OptParserState () -> CharParser OptParserState ())
-> CharParser OptParserState () -> CharParser OptParserState ()
forall a b. (a -> b) -> a -> b
$ CharParser OptParserState () -> CharParser OptParserState ()
forall tok st a. GenParser tok st a -> GenParser tok st a
try (CharParser OptParserState () -> CharParser OptParserState ())
-> CharParser OptParserState () -> CharParser OptParserState ()
forall a b. (a -> b) -> a -> b
$ OptPattern -> CharParser OptParserState ()
makeParser OptPattern
pat
  (Repeated OptPattern
pat) -> do
      case OptPattern
pat of
        (Optional OptPattern
p) -> (CharParser OptParserState () -> CharParser OptParserState ()
forall tok st a. GenParser tok st a -> GenParser tok st a
try (CharParser OptParserState () -> CharParser OptParserState ())
-> CharParser OptParserState () -> CharParser OptParserState ()
forall a b. (a -> b) -> a -> b
$ OptPattern -> CharParser OptParserState ()
makeParser OptPattern
p) CharParser OptParserState ()
-> CharParser OptParserState ()
-> ParsecT String OptParserState Identity [()]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
`sepBy` CharParser OptParserState ()
argDelimIfNotInShortOptStack
        OptPattern
_            -> (CharParser OptParserState () -> CharParser OptParserState ()
forall tok st a. GenParser tok st a -> GenParser tok st a
try (CharParser OptParserState () -> CharParser OptParserState ())
-> CharParser OptParserState () -> CharParser OptParserState ()
forall a b. (a -> b) -> a -> b
$ OptPattern -> CharParser OptParserState ()
makeParser OptPattern
pat) CharParser OptParserState ()
-> CharParser OptParserState ()
-> ParsecT String OptParserState Identity [()]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
`sepBy1` CharParser OptParserState ()
argDelimIfNotInShortOptStack
      () -> CharParser OptParserState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  (Atom Option
pat) -> case Option
pat of
      o :: Option
o@(ShortOption Char
c) ->
            do  OptParserState
st <- ParsecT String OptParserState Identity OptParserState
forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
                if OptParserState -> Bool
inShortOptStack OptParserState
st then () -> CharParser OptParserState ()
forall (m :: * -> *) a. Monad m => a -> m a
return () else Char -> ParsecT String OptParserState Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-' ParsecT String OptParserState Identity Char
-> CharParser OptParserState () -> CharParser OptParserState ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> CharParser OptParserState ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Char -> ParsecT String OptParserState Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
c
                (OptParserState -> OptParserState) -> CharParser OptParserState ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
updateState ((OptParserState -> OptParserState)
 -> CharParser OptParserState ())
-> (OptParserState -> OptParserState)
-> CharParser OptParserState ()
forall a b. (a -> b) -> a -> b
$ Bool -> OptParserState -> OptParserState
updateInShortOptStack Bool
True
                String
val <- if OptionInfo -> Bool
expectsVal (OptionInfo -> Bool) -> OptionInfo -> Bool
forall a b. (a -> b) -> a -> b
$ OptionInfo -> Option -> OptInfoMap -> OptionInfo
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault ([Option] -> OptionInfo
fromSynList []) Option
o OptInfoMap
infomap
                  then ParsecT String OptParserState Identity String
-> ParsecT String OptParserState Identity String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT String OptParserState Identity String
 -> ParsecT String OptParserState Identity String)
-> ParsecT String OptParserState Identity String
-> ParsecT String OptParserState Identity String
forall a b. (a -> b) -> a -> b
$ do
                    ParsecT String OptParserState Identity String
-> CharParser OptParserState ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional (ParsecT String OptParserState Identity String
 -> CharParser OptParserState ())
-> ParsecT String OptParserState Identity String
-> CharParser OptParserState ()
forall a b. (a -> b) -> a -> b
$ String -> ParsecT String OptParserState Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"=" ParsecT String OptParserState Identity String
-> ParsecT String OptParserState Identity String
-> ParsecT String OptParserState Identity String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String OptParserState Identity String
forall u. ParsecT String u Identity String
argDelim
                    (OptParserState -> OptParserState) -> CharParser OptParserState ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
updateState ((OptParserState -> OptParserState)
 -> CharParser OptParserState ())
-> (OptParserState -> OptParserState)
-> CharParser OptParserState ()
forall a b. (a -> b) -> a -> b
$ Bool -> OptParserState -> OptParserState
updateInShortOptStack Bool
False
                    ParsecT String OptParserState Identity Char
-> CharParser OptParserState ()
-> ParsecT String OptParserState Identity String
forall u a b. CharParser u a -> CharParser u b -> CharParser u [a]
manyTill1 ParsecT String OptParserState Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT String OptParserState Identity String
-> CharParser OptParserState ()
forall u a. CharParser u a -> CharParser u ()
lookAhead_ ParsecT String OptParserState Identity String
forall u. ParsecT String u Identity String
argDelim CharParser OptParserState ()
-> CharParser OptParserState () -> CharParser OptParserState ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> CharParser OptParserState ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof)
                  else do
                    Bool
stillInShortStack <- ParsecT String OptParserState Identity String
-> CharParser OptParserState Bool
forall a u. Show a => CharParser u a -> CharParser u Bool
isNotFollowedBy ParsecT String OptParserState Identity String
forall u. ParsecT String u Identity String
argDelim
                    Bool
-> CharParser OptParserState () -> CharParser OptParserState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
stillInShortStack (CharParser OptParserState () -> CharParser OptParserState ())
-> CharParser OptParserState () -> CharParser OptParserState ()
forall a b. (a -> b) -> a -> b
$
                      (OptParserState -> OptParserState) -> CharParser OptParserState ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
updateState ((OptParserState -> OptParserState)
 -> CharParser OptParserState ())
-> (OptParserState -> OptParserState)
-> CharParser OptParserState ()
forall a b. (a -> b) -> a -> b
$ Bool -> OptParserState -> OptParserState
updateInShortOptStack Bool
False
                    String -> ParsecT String OptParserState Identity String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
                (OptParserState -> OptParserState) -> CharParser OptParserState ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
updateState ((OptParserState -> OptParserState)
 -> CharParser OptParserState ())
-> (OptParserState -> OptParserState)
-> CharParser OptParserState ()
forall a b. (a -> b) -> a -> b
$ Option
-> (Arguments -> Option -> OptionInfo -> Arguments)
-> OptParserState
-> OptParserState
withEachSynonym Option
o ((Arguments -> Option -> OptionInfo -> Arguments)
 -> OptParserState -> OptParserState)
-> (Arguments -> Option -> OptionInfo -> Arguments)
-> OptParserState
-> OptParserState
forall a b. (a -> b) -> a -> b
$
                              \Arguments
pa Option
syn OptionInfo
info -> Option -> OptionInfo -> String -> Arguments -> Arguments
saveOccurrence Option
syn OptionInfo
info String
val Arguments
pa
          CharParser OptParserState ()
-> String -> CharParser OptParserState ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> Option -> String
humanize Option
o
      o :: Option
o@(LongOption String
name) ->
            do String -> ParsecT String OptParserState Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"--"
               String -> ParsecT String OptParserState Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
name
               String
val <- if OptionInfo -> Bool
expectsVal (OptionInfo -> Bool) -> OptionInfo -> Bool
forall a b. (a -> b) -> a -> b
$ OptionInfo -> Option -> OptInfoMap -> OptionInfo
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault ([Option] -> OptionInfo
fromSynList []) Option
o OptInfoMap
infomap
                 then do
                   String -> ParsecT String OptParserState Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"=" ParsecT String OptParserState Identity String
-> ParsecT String OptParserState Identity String
-> ParsecT String OptParserState Identity String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String OptParserState Identity String
forall u. ParsecT String u Identity String
argDelim
                   --many (notFollowedBy (string delim) >> anyChar)
                   ParsecT String OptParserState Identity Char
-> CharParser OptParserState ()
-> ParsecT String OptParserState Identity String
forall u a b. CharParser u a -> CharParser u b -> CharParser u [a]
manyTill1 ParsecT String OptParserState Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT String OptParserState Identity String
-> CharParser OptParserState ()
forall u a. CharParser u a -> CharParser u ()
lookAhead_ ParsecT String OptParserState Identity String
forall u. ParsecT String u Identity String
argDelim CharParser OptParserState ()
-> CharParser OptParserState () -> CharParser OptParserState ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> CharParser OptParserState ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof)
                 else String -> ParsecT String OptParserState Identity String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
               (OptParserState -> OptParserState) -> CharParser OptParserState ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
updateState ((OptParserState -> OptParserState)
 -> CharParser OptParserState ())
-> (OptParserState -> OptParserState)
-> CharParser OptParserState ()
forall a b. (a -> b) -> a -> b
$ Option
-> (Arguments -> Option -> OptionInfo -> Arguments)
-> OptParserState
-> OptParserState
withEachSynonym Option
o ((Arguments -> Option -> OptionInfo -> Arguments)
 -> OptParserState -> OptParserState)
-> (Arguments -> Option -> OptionInfo -> Arguments)
-> OptParserState
-> OptParserState
forall a b. (a -> b) -> a -> b
$
                           \Arguments
pa Option
syn OptionInfo
info -> Option -> OptionInfo -> String -> Arguments -> Arguments
saveOccurrence Option
syn OptionInfo
info String
val Arguments
pa
               (OptParserState -> OptParserState) -> CharParser OptParserState ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
updateState ((OptParserState -> OptParserState)
 -> CharParser OptParserState ())
-> (OptParserState -> OptParserState)
-> CharParser OptParserState ()
forall a b. (a -> b) -> a -> b
$ Bool -> OptParserState -> OptParserState
updateInShortOptStack Bool
False
          CharParser OptParserState ()
-> String -> CharParser OptParserState ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> Option -> String
humanize Option
o
      o :: Option
o@(Option
AnyOption) ->
            let synlists :: [[Option]]
synlists = [[Option]] -> [[Option]]
forall a. Eq a => [a] -> [a]
nub ([[Option]] -> [[Option]])
-> ([OptionInfo] -> [[Option]]) -> [OptionInfo] -> [[Option]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OptionInfo -> [Option]) -> [OptionInfo] -> [[Option]]
forall a b. (a -> b) -> [a] -> [b]
map OptionInfo -> [Option]
synonyms ([OptionInfo] -> [[Option]]) -> [OptionInfo] -> [[Option]]
forall a b. (a -> b) -> a -> b
$ OptInfoMap -> [OptionInfo]
forall k a. Map k a -> [a]
M.elems OptInfoMap
infomap
                --oneOf syns = OneOf (map Atom syns)
                --synparsers = oneOf `map` synlists
                oneOfSyns :: [OptPattern]
oneOfSyns = ([Option] -> OptPattern) -> [[Option]] -> [OptPattern]
forall a b. (a -> b) -> [a] -> [b]
map (\[Option]
ss -> [OptPattern] -> OptPattern
forall a. [Pattern a] -> Pattern a
OneOf ((Option -> OptPattern) -> [Option] -> [OptPattern]
forall a b. (a -> b) -> [a] -> [b]
map Option -> OptPattern
forall a. a -> Pattern a
Atom [Option]
ss)) [[Option]]
synlists
                unorderedSynParser :: CharParser OptParserState ()
unorderedSynParser = String -> OptFormat -> CharParser OptParserState ()
buildOptParser String
delim ([OptPattern] -> OptPattern
forall a. [Pattern a] -> Pattern a
Unordered [OptPattern]
oneOfSyns, OptInfoMap
infomap)
            in  CharParser OptParserState ()
unorderedSynParser
                CharParser OptParserState ()
-> String -> CharParser OptParserState ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> Option -> String
humanize Option
o
      o :: Option
o@(Argument String
name) ->
            do String
val <- ParsecT String OptParserState Identity String
-> ParsecT String OptParserState Identity String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT String OptParserState Identity String
 -> ParsecT String OptParserState Identity String)
-> ParsecT String OptParserState Identity String
-> ParsecT String OptParserState Identity String
forall a b. (a -> b) -> a -> b
$ ParsecT String OptParserState Identity Char
-> ParsecT String OptParserState Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT String OptParserState Identity String
-> CharParser OptParserState ()
forall s (m :: * -> *) t a u.
(Stream s m t, Show a) =>
ParsecT s u m a -> ParsecT s u m ()
notFollowedBy ParsecT String OptParserState Identity String
forall u. ParsecT String u Identity String
argDelim CharParser OptParserState ()
-> ParsecT String OptParserState Identity Char
-> ParsecT String OptParserState Identity Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String OptParserState Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar)
               Option -> String -> CharParser OptParserState ()
updateSt_saveOccurrence Option
o String
val
               Bool -> CharParser OptParserState ()
forall s. Bool -> ParsecT s OptParserState Identity ()
updateSt_inShortOptStack Bool
False
          CharParser OptParserState ()
-> String -> CharParser OptParserState ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> Option -> String
humanize Option
o
      o :: Option
o@(Command String
name) ->
            do String -> ParsecT String OptParserState Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
name
               Option -> CharParser OptParserState ()
updateSt_assertPresent Option
o
               Bool -> CharParser OptParserState ()
forall s. Bool -> ParsecT s OptParserState Identity ()
updateSt_inShortOptStack Bool
False
          CharParser OptParserState ()
-> String -> CharParser OptParserState ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> Option -> String
humanize Option
o


-- ** Helpers


-- | converts a parser to return its user-state
--   instead of its return value
returnState :: CharParser u a -> CharParser u u
returnState :: CharParser u a -> CharParser u u
returnState CharParser u a
p = CharParser u a
p CharParser u a -> CharParser u u -> CharParser u u
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CharParser u u
forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState

updateInShortOptStack :: Bool -> OptParserState -> OptParserState
updateInShortOptStack :: Bool -> OptParserState -> OptParserState
updateInShortOptStack Bool
b OptParserState
ops = OptParserState
ops {inShortOptStack :: Bool
inShortOptStack = Bool
b}

updateParsedArgs :: (Arguments -> Arguments) -> OptParserState -> OptParserState
updateParsedArgs :: (Arguments -> Arguments) -> OptParserState -> OptParserState
updateParsedArgs Arguments -> Arguments
f OptParserState
st = OptParserState
st {parsedArgs :: Arguments
parsedArgs = Arguments -> Arguments
f (Arguments -> Arguments) -> Arguments -> Arguments
forall a b. (a -> b) -> a -> b
$ OptParserState -> Arguments
parsedArgs OptParserState
st}

saveOccurrence :: Option -> OptionInfo -> String -> Arguments -> Arguments
saveOccurrence :: Option -> OptionInfo -> String -> Arguments -> Arguments
saveOccurrence Option
opt OptionInfo
info String
newval Arguments
argmap = (Maybe ArgValue -> Maybe ArgValue)
-> Option -> Arguments -> Arguments
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter Maybe ArgValue -> Maybe ArgValue
updateCurrentVal Option
opt Arguments
argmap
    where updateCurrentVal :: Maybe ArgValue -> Maybe ArgValue
updateCurrentVal Maybe ArgValue
m_oldval = case Maybe ArgValue
m_oldval of
            Maybe ArgValue
Nothing     -> (String
newval String -> ArgValue -> Maybe ArgValue
`updateFrom`) (ArgValue -> Maybe ArgValue) -> Maybe ArgValue -> Maybe ArgValue
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (OptionInfo -> Option -> Maybe ArgValue
optInitialValue OptionInfo
info Option
opt)
            Just ArgValue
oldval -> String
newval String -> ArgValue -> Maybe ArgValue
`updateFrom` ArgValue
oldval
          updateFrom :: String -> ArgValue -> Maybe ArgValue
updateFrom String
newval ArgValue
oldval = ArgValue -> Maybe ArgValue
forall a. a -> Maybe a
Just (ArgValue -> Maybe ArgValue) -> ArgValue -> Maybe ArgValue
forall a b. (a -> b) -> a -> b
$ case ArgValue
oldval of
            MultiValue [String]
vs -> [String] -> ArgValue
MultiValue ([String] -> ArgValue) -> [String] -> ArgValue
forall a b. (a -> b) -> a -> b
$ String
newval String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
vs
            Value String
v       -> String -> ArgValue
Value String
newval
            ArgValue
NoValue       -> String -> ArgValue
Value String
newval
            Counted Int
n     -> Int -> ArgValue
Counted (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
            ArgValue
Present       -> ArgValue
Present
            ArgValue
NotPresent    -> ArgValue
Present

assertPresent :: Option -> OptionInfo -> Arguments -> Arguments
assertPresent :: Option -> OptionInfo -> Arguments -> Arguments
assertPresent Option
opt OptionInfo
info Arguments
argmap = Option -> OptionInfo -> String -> Arguments -> Arguments
saveOccurrence Option
opt OptionInfo
info String
"" Arguments
argmap

withEachSynonym :: Option ->
                   (Arguments -> Option -> OptionInfo -> Arguments) ->
                   OptParserState ->
                   OptParserState
withEachSynonym :: Option
-> (Arguments -> Option -> OptionInfo -> Arguments)
-> OptParserState
-> OptParserState
withEachSynonym Option
opt Arguments -> Option -> OptionInfo -> Arguments
savefn OptParserState
st =
  let infomap :: OptInfoMap
infomap = OptParserState -> OptInfoMap
optInfoMap OptParserState
st
      args :: Arguments
args = OptParserState -> Arguments
parsedArgs OptParserState
st
      syns :: [Option]
syns = OptionInfo -> [Option]
synonyms (OptionInfo -> [Option]) -> OptionInfo -> [Option]
forall a b. (a -> b) -> a -> b
$ OptionInfo -> Option -> OptInfoMap -> OptionInfo
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault ([Option] -> OptionInfo
fromSynList []) Option
opt OptInfoMap
infomap
      -- give the savefn each opt's info, as well
      foldsavefn :: Arguments -> Option -> Arguments
foldsavefn = \Arguments
args Option
opt ->
                    let info :: OptionInfo
info = OptionInfo -> Option -> OptInfoMap -> OptionInfo
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault ([Option] -> OptionInfo
fromSynList []) Option
opt OptInfoMap
infomap
                    in Arguments -> Option -> OptionInfo -> Arguments
savefn Arguments
args Option
opt OptionInfo
info
  in OptParserState
st {parsedArgs :: Arguments
parsedArgs = (Arguments -> Option -> Arguments)
-> Arguments -> [Option] -> Arguments
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Arguments -> Option -> Arguments
foldsavefn Arguments
args [Option]
syns}


optInitialValue :: OptionInfo -> Option -> Maybe ArgValue
optInitialValue :: OptionInfo -> Option -> Maybe ArgValue
optInitialValue OptionInfo
info Option
opt =
  let repeatable :: Bool
repeatable = OptionInfo -> Bool
isRepeated OptionInfo
info
  in case Option
opt of
    Command String
name  -> ArgValue -> Maybe ArgValue
forall a. a -> Maybe a
Just (ArgValue -> Maybe ArgValue) -> ArgValue -> Maybe ArgValue
forall a b. (a -> b) -> a -> b
$ if Bool
repeatable then Int -> ArgValue
Counted Int
0 else ArgValue
NotPresent
    Argument String
name -> ArgValue -> Maybe ArgValue
forall a. a -> Maybe a
Just (ArgValue -> Maybe ArgValue) -> ArgValue -> Maybe ArgValue
forall a b. (a -> b) -> a -> b
$ if Bool
repeatable then [String] -> ArgValue
MultiValue [] else ArgValue
NoValue
    Option
AnyOption     -> Maybe ArgValue
forall a. Maybe a
Nothing -- no storable value for [options] shortcut
    Option
_             -> case OptionInfo -> Bool
expectsVal OptionInfo
info of
      Bool
True  -> ArgValue -> Maybe ArgValue
forall a. a -> Maybe a
Just (ArgValue -> Maybe ArgValue) -> ArgValue -> Maybe ArgValue
forall a b. (a -> b) -> a -> b
$ if Bool
repeatable then [String] -> ArgValue
MultiValue [] else ArgValue
NoValue
      Bool
False -> ArgValue -> Maybe ArgValue
forall a. a -> Maybe a
Just (ArgValue -> Maybe ArgValue) -> ArgValue -> Maybe ArgValue
forall a b. (a -> b) -> a -> b
$ if Bool
repeatable then Int -> ArgValue
Counted Int
0 else ArgValue
NotPresent

optDefaultValue :: OptionInfo -> Option -> Maybe ArgValue
optDefaultValue :: OptionInfo -> Option -> Maybe ArgValue
optDefaultValue OptionInfo
info Option
opt =
  let repeatable :: Bool
repeatable = OptionInfo -> Bool
isRepeated OptionInfo
info
  in case Option
opt of
    Command String
name  -> ArgValue -> Maybe ArgValue
forall a. a -> Maybe a
Just (ArgValue -> Maybe ArgValue) -> ArgValue -> Maybe ArgValue
forall a b. (a -> b) -> a -> b
$ if Bool
repeatable then Int -> ArgValue
Counted Int
0 else ArgValue
NotPresent
    Argument String
name -> ArgValue -> Maybe ArgValue
forall a. a -> Maybe a
Just (ArgValue -> Maybe ArgValue) -> ArgValue -> Maybe ArgValue
forall a b. (a -> b) -> a -> b
$ if Bool
repeatable then [String] -> ArgValue
MultiValue [] else ArgValue
NoValue
    Option
AnyOption     -> Maybe ArgValue
forall a. Maybe a
Nothing -- no storable value for [options] shortcut
    Option
_               -> case OptionInfo -> Bool
expectsVal OptionInfo
info of
      Bool
True  -> case OptionInfo -> Maybe String
defaultVal OptionInfo
info of
        Just String
dval -> ArgValue -> Maybe ArgValue
forall a. a -> Maybe a
Just (ArgValue -> Maybe ArgValue) -> ArgValue -> Maybe ArgValue
forall a b. (a -> b) -> a -> b
$ if Bool
repeatable
                            then [String] -> ArgValue
MultiValue ([String] -> ArgValue) -> [String] -> ArgValue
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
words String
dval
                            else String -> ArgValue
Value String
dval
        Maybe String
Nothing   -> ArgValue -> Maybe ArgValue
forall a. a -> Maybe a
Just (ArgValue -> Maybe ArgValue) -> ArgValue -> Maybe ArgValue
forall a b. (a -> b) -> a -> b
$ if Bool
repeatable then [String] -> ArgValue
MultiValue [] else ArgValue
NoValue
      Bool
False -> ArgValue -> Maybe ArgValue
forall a. a -> Maybe a
Just (ArgValue -> Maybe ArgValue) -> ArgValue -> Maybe ArgValue
forall a b. (a -> b) -> a -> b
$ if Bool
repeatable then Int -> ArgValue
Counted Int
0 else ArgValue
NotPresent


getArguments :: OptFormat -> [String] -> Either ParseError Arguments
getArguments :: OptFormat -> [String] -> Either ParseError Arguments
getArguments OptFormat
optfmt [String]
argv =
    let (OptPattern
pattern, OptInfoMap
infomap) = OptFormat
optfmt

        -- delimiter used to flatten argv to parsable String
        -- TODO: parse argv without a nasty intercalate hack
        delim :: String
delim = String
"«»"
        argvString :: String
argvString = String
delim String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
`intercalate` [String]
argv

        p :: ParsecT String OptParserState Identity Arguments
p = OptParserState -> Arguments
parsedArgs (OptParserState -> Arguments)
-> ParsecT String OptParserState Identity OptParserState
-> ParsecT String OptParserState Identity Arguments
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CharParser OptParserState ()
-> ParsecT String OptParserState Identity OptParserState
forall u a. CharParser u a -> CharParser u u
returnState (String -> OptFormat -> CharParser OptParserState ()
buildOptParser String
delim OptFormat
optfmt)

        patAtoms :: [Option]
patAtoms = OptPattern -> [Option]
forall a. Eq a => Pattern a -> [a]
atoms OptPattern
pattern
        infoKeys :: [Option]
infoKeys = ([Option] -> [Option] -> [Option]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Option
AnyOption]) ([Option] -> [Option]) -> [Option] -> [Option]
forall a b. (a -> b) -> a -> b
$ OptInfoMap -> [Option]
forall k a. Map k a -> [k]
M.keys OptInfoMap
infomap
        allAtoms :: [Option]
allAtoms = [Option] -> [Option]
forall a. Eq a => [a] -> [a]
nub ([Option] -> [Option]) -> [Option] -> [Option]
forall a b. (a -> b) -> a -> b
$ [Option]
patAtoms [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
infoKeys
        defaultArgVals :: Arguments
defaultArgVals = (Arguments -> Option -> Arguments)
-> Arguments -> [Option] -> Arguments
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Arguments -> Option -> Arguments
f Arguments
forall k a. Map k a
M.empty [Option]
allAtoms
            where f :: Arguments -> Option -> Arguments
f Arguments
argmap Option
atom = (Maybe ArgValue -> Maybe ArgValue)
-> Option -> Arguments -> Arguments
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (\Maybe ArgValue
_ -> OptionInfo -> Option -> Maybe ArgValue
optDefaultValue (OptInfoMap
infomap OptInfoMap -> Option -> OptionInfo
forall k a. Ord k => Map k a -> k -> a
M.! Option
atom) Option
atom) Option
atom Arguments
argmap

        initialState :: OptParserState
initialState = (OptInfoMap -> OptParserState
fromOptInfoMap OptInfoMap
infomap)

        e_parsedArgs :: Either ParseError Arguments
e_parsedArgs = ParsecT String OptParserState Identity Arguments
-> OptParserState
-> String
-> String
-> Either ParseError Arguments
forall tok st a.
GenParser tok st a -> st -> String -> [tok] -> Either ParseError a
runParser ParsecT String OptParserState Identity Arguments
p OptParserState
initialState String
"argv" String
argvString

        fillMissingDefaults :: Arguments -> Arguments
fillMissingDefaults Arguments
pargs = Arguments -> Arguments -> Arguments
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Arguments
pargs Arguments
defaultArgVals

    in Arguments -> Arguments
fillMissingDefaults (Arguments -> Arguments)
-> Either ParseError Arguments -> Either ParseError Arguments
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either ParseError Arguments
e_parsedArgs