content: {-# OPTIONS_GHC -Wno-unused-do-bind #-}
  
  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 delim (pattern, infomap) =
  
    let -- Helpers
        argDelim = (try $ string delim) <?> "space between arguments"
  
        makeParser p = buildOptParser delim (p, infomap)
  
        argDelimIfNotInShortOptStack = do
          st <- getState
          if not $ inShortOptStack st
            then optional argDelim
            else return ()
  
        updateOptWith :: (Option -> OptionInfo -> String -> Arguments -> Arguments) ->
                         Option ->
                         String ->
                         CharParser OptParserState ()
        updateOptWith updateFn opt val = do
          st <- getState
          let optInfo = (optInfoMap st) M.! opt
          updateState $ updateParsedArgs $ updateFn opt optInfo val
  
        updateSt_saveOccurrence opt val = updateOptWith saveOccurrence opt val
        updateSt_assertPresent opt = updateOptWith (\opt info _ -> assertPresent opt info) opt ""
  
        updateSt_inShortOptStack = updateState . updateInShortOptStack
  
    in case pattern of
    (Sequence pats) ->
        assertTopConsumesAll $ foldl (andThen) (return ()) ps
        where assertTopConsumesAll p = do
                st <- getState
                if inTopLevelSequence st
                  then do
                    updateState $ \st -> st {inTopLevelSequence = False}
                    p <* eof
                  else p
              inner_pats = (\pat -> (pat, infomap)) `map` pats
              ps = (buildOptParser delim) `map` inner_pats
              andThen = \p1 p2 -> do
                p1
                argDelimIfNotInShortOptStack
                p2
    (OneOf pats) ->
        choice $ (try . makeParser) `map` pats
    (Unordered pats) -> case pats of
        pat:[] -> makeParser pat
        _ ->  choice $ (parseThisThenRest pats) `map` pats
              where parseThisThenRest list pat = try $ do
                      makeParser pat
                      let rest = list \\ [pat]
                      argDelimIfNotInShortOptStack
                      makeParser $ Unordered rest
    (Optional pat) ->
          case pat of
            Unordered ps -> case ps of
              p:[] -> makeParser $ Optional p
              _  -> optional $ choice $ (parseThisThenRest ps) `map` ps
                    where parseThisThenRest list pat = try $ do
                            makeParser pat
                            let rest = list \\ [pat]
                            argDelimIfNotInShortOptStack
                            makeParser $ Optional $ Unordered rest
            _ -> optional $ try $ makeParser pat
    (Repeated pat) -> do
        case pat of
          (Optional p) -> (try $ makeParser p) `sepBy` argDelimIfNotInShortOptStack
          _            -> (try $ makeParser pat) `sepBy1` argDelimIfNotInShortOptStack
        return ()
    (Atom pat) -> case pat of
        o@(ShortOption c) ->
              do  st <- getState
                  if inShortOptStack st then return () else char '-' >> return ()
                  char c
                  updateState $ updateInShortOptStack True
                  val <- if expectsVal $ M.findWithDefault (fromSynList []) o infomap
                    then try $ do
                      optional $ string "=" <|> argDelim
                      updateState $ updateInShortOptStack False
                      manyTill1 anyChar (lookAhead_ argDelim <|> eof)
                    else do
                      stillInShortStack <- isNotFollowedBy argDelim
                      unless stillInShortStack $
                        updateState $ updateInShortOptStack False
                      return ""
                  updateState $ withEachSynonym o $
                                \pa syn info -> saveOccurrence syn info val pa
            <?> humanize o
        o@(LongOption name) ->
              do string "--"
                 string name
                 val <- if expectsVal $ M.findWithDefault (fromSynList []) o infomap
                   then do
                     string "=" <|> argDelim
                     --many (notFollowedBy (string delim) >> anyChar)
                     manyTill1 anyChar (lookAhead_ argDelim <|> eof)
                   else return ""
                 updateState $ withEachSynonym o $
                             \pa syn info -> saveOccurrence syn info val pa
                 updateState $ updateInShortOptStack False
            <?> humanize o
        o@(AnyOption) ->
              let synlists = nub . map synonyms $ M.elems infomap
                  --oneOf syns = OneOf (map Atom syns)
                  --synparsers = oneOf `map` synlists
                  oneOfSyns = map (\ss -> OneOf (map Atom ss)) synlists
                  unorderedSynParser = buildOptParser delim (Unordered oneOfSyns, infomap)
              in  unorderedSynParser
                  <?> humanize o
        o@(Argument _name) ->
              do val <- try $ many1 (notFollowedBy argDelim >> anyChar)
                 updateSt_saveOccurrence o val
                 updateSt_inShortOptStack False
            <?> humanize o
        o@(Command name) ->
              do string name
                 updateSt_assertPresent o
                 updateSt_inShortOptStack False
            <?> humanize o
  
  
  -- ** Helpers
  
  
  -- | converts a parser to return its user-state
  --   instead of its return value
  returnState :: CharParser u a -> CharParser u u
  returnState p = p >> getState
  
  updateInShortOptStack :: Bool -> OptParserState -> OptParserState
  updateInShortOptStack b ops = ops {inShortOptStack = b}
  
  updateParsedArgs :: (Arguments -> Arguments) -> OptParserState -> OptParserState
  updateParsedArgs f st = st {parsedArgs = f $ parsedArgs st}
  
  saveOccurrence :: Option -> OptionInfo -> String -> Arguments -> Arguments
  saveOccurrence opt info newval argmap = M.alter updateCurrentVal opt argmap
      where updateCurrentVal m_oldval = case m_oldval of
              Nothing     -> (newval `updateFrom`) =<< (optInitialValue info opt)
              Just oldval -> newval `updateFrom` oldval
            updateFrom newval oldval = Just $ case oldval of
              MultiValue vs -> MultiValue $ newval : vs
              Value _v      -> Value newval
              NoValue       -> Value newval
              Counted n     -> Counted (n+1)
              Present       -> Present
              NotPresent    -> Present
  
  assertPresent :: Option -> OptionInfo -> Arguments -> Arguments
  assertPresent opt info argmap = saveOccurrence opt info "" argmap
  
  withEachSynonym :: Option ->
                     (Arguments -> Option -> OptionInfo -> Arguments) ->
                     OptParserState ->
                     OptParserState
  withEachSynonym opt savefn st =
    let infomap = optInfoMap st
        args = parsedArgs st
        syns = synonyms $ M.findWithDefault (fromSynList []) opt infomap
        -- give the savefn each opt's info, as well
        foldsavefn = \args opt ->
                      let info = M.findWithDefault (fromSynList []) opt infomap
                      in savefn args opt info
    in st {parsedArgs = foldl foldsavefn args syns}
  
  
  optInitialValue :: OptionInfo -> Option -> Maybe ArgValue
  optInitialValue info opt =
    let repeatable = isRepeated info
    in case opt of
      Command _name  -> Just $ if repeatable then Counted 0 else NotPresent
      Argument _name -> Just $ if repeatable then MultiValue [] else NoValue
      AnyOption      -> Nothing -- no storable value for [options] shortcut
      _              -> case expectsVal info of
        True  -> Just $ if repeatable then MultiValue [] else NoValue
        False -> Just $ if repeatable then Counted 0 else NotPresent
  
  optDefaultValue :: OptionInfo -> Option -> Maybe ArgValue
  optDefaultValue info opt =
    let repeatable = isRepeated info
    in case opt of
      Command _name  -> Just $ if repeatable then Counted 0 else NotPresent
      Argument _name -> Just $ if repeatable then MultiValue [] else NoValue
      AnyOption      -> Nothing -- no storable value for [options] shortcut
      _              -> case expectsVal info of
        True  -> case defaultVal info of
          Just dval -> Just $ if repeatable
                              then MultiValue $ reverse $ words dval
                              else Value dval
          Nothing   -> Just $ if repeatable then MultiValue [] else NoValue
        False -> Just $ if repeatable then Counted 0 else NotPresent
  
  
  getArguments :: OptFormat -> [String] -> Either ParseError Arguments
  getArguments optfmt argv =
      let (pattern, infomap) = optfmt
  
          -- delimiter used to flatten argv to parsable String
          -- TODO: parse argv without a nasty intercalate hack
          delim = "«»"
          argvString = delim `intercalate` argv
  
          p = parsedArgs <$> returnState (buildOptParser delim optfmt)
  
          patAtoms = atoms pattern
          infoKeys = (\\ [AnyOption]) $ M.keys infomap
          allAtoms = nub $ patAtoms ++ infoKeys
          defaultArgVals = foldl f M.empty allAtoms
              where f argmap atom = M.alter (\_ -> optDefaultValue (infomap M.! atom) atom) atom argmap
  
          initialState = (fromOptInfoMap infomap)
  
          e_parsedArgs = runParser p initialState "argv" argvString
  
          fillMissingDefaults pargs = M.union pargs defaultArgVals
  
      in fillMissingDefaults <$> e_parsedArgs
  